Register new users

This commit is contained in:
Mats Rauhala 2018-08-03 23:36:38 +03:00
parent cf8360fd95
commit 93fe3a573d
9 changed files with 185 additions and 25 deletions

View File

@ -19,9 +19,11 @@ executable ebook-manager
main-is: Main.hs main-is: Main.hs
other-modules: Devel.Main other-modules: Devel.Main
, API , API
, API.Users
, Configuration , Configuration
, Database , Database
, Database.Schema , Database.Schema
, Database.User
, Server , Server
, Types , Types
-- other-extensions: -- other-extensions:
@ -55,5 +57,11 @@ executable ebook-manager
, selda , selda
, selda-postgresql , selda-postgresql
, process , process
, aeson
, http-api-data
hs-source-dirs: src hs-source-dirs: src
default-extensions: DeriveGeneric
, NoImplicitPrelude
, OverloadedStrings
, RecordWildCards
default-language: Haskell2010 default-language: Haskell2010

View File

@ -20,6 +20,8 @@ import qualified Lucid.Html5 as H
import Types import Types
import Control.Monad.Logger import Control.Monad.Logger
import qualified API.Users as Users
-- XXX: Temporary -- XXX: Temporary
import Database.Schema import Database.Schema
import Database import Database
@ -44,9 +46,13 @@ instance ToHtml Index where
toHtmlRaw = toHtml toHtmlRaw = toHtml
type API = Get '[HTML] Index type API = Get '[HTML] Index
:<|> Users.API
handler :: ServerT API AppM handler :: ServerT API AppM
handler = do handler = indexHandler :<|> Users.handler
indexHandler :: AppM Index
indexHandler = do
u <- runDB $ do u <- runDB $ do
query $ select $ gen users query $ select $ gen users
$logInfo $ "users: " <> (pack . show $ u) $logInfo $ "users: " <> (pack . show $ u)

62
src/API/Users.hs Normal file
View File

@ -0,0 +1,62 @@
{-# Language DataKinds #-}
{-# Language TypeFamilies #-}
{-# Language OverloadedStrings #-}
{-# Language NoImplicitPrelude #-}
{-# Language TypeOperators #-}
{-# Language DuplicateRecordFields #-}
module API.Users (API, handler) where
import Servant
import ClassyPrelude
import Types
import Data.Aeson
import Web.FormUrlEncoded
import Database (runDB)
import Database.User
data LoginForm = LoginForm { username :: Text
, password :: Text }
deriving (Generic, Show)
data RegisterForm = RegisterForm { username :: Text
, email :: Text
, password :: Text
, passwordAgain :: Text }
deriving (Generic, Show)
data LoginStatus = LoginStatus deriving Generic
data RegisterStatus = RegisterStatus deriving Generic
instance FromJSON LoginForm
instance ToJSON LoginForm
instance ToJSON LoginStatus
instance FromJSON LoginStatus
instance FromForm LoginForm
instance ToForm LoginForm
instance FromJSON RegisterForm
instance ToJSON RegisterForm
instance ToJSON RegisterStatus
instance FromJSON RegisterStatus
instance FromForm RegisterForm
instance ToForm RegisterForm
type API = "login" :> ReqBody '[JSON, FormUrlEncoded] LoginForm :> Post '[JSON] LoginStatus
:<|> "register" :> ReqBody '[JSON, FormUrlEncoded] RegisterForm :> Post '[JSON] RegisterStatus
handler :: ServerT API AppM
handler = loginHandler :<|> registerHandler
loginHandler :: LoginForm -> AppM LoginStatus
loginHandler LoginForm{..} = throwM err403
registerHandler :: RegisterForm -> AppM RegisterStatus
registerHandler RegisterForm{..} =
case () of
() | password /= passwordAgain -> noMatch
| otherwise ->
either (const alreadyExists) (const (pure RegisterStatus)) =<< runDB (insertUser username email (PlainPassword password))
where
noMatch = throwM err403{errBody = "passwords don't match"}
alreadyExists = throwM err403{errBody = "User already exists"}

View File

@ -7,7 +7,10 @@ module Database
, runDB , runDB
, query , query
, select , select
, gen ) , gen
, fromRel
, toRel
, SeldaT )
where where
import Data.Generics.Product import Data.Generics.Product
@ -15,7 +18,7 @@ import Control.Lens (view)
import Data.Pool (Pool, withResource) import Data.Pool (Pool, withResource)
import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT) import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT)
import Database.Selda (query, select) import Database.Selda (query, select)
import Database.Selda.Generic (gen) import Database.Selda.Generic (gen, fromRel, toRel)
import ClassyPrelude import ClassyPrelude
type DBLike r m = (MonadIO m, MonadReader r m, MonadBaseControl IO m, MonadMask m, HasField' "database" r (Pool SeldaConnection)) type DBLike r m = (MonadIO m, MonadReader r m, MonadBaseControl IO m, MonadMask m, HasField' "database" r (Pool SeldaConnection))

View File

@ -1,15 +1,29 @@
{-# Language NoImplicitPrelude #-} {-# Language NoImplicitPrelude #-}
{-# Language DeriveGeneric #-} {-# Language DeriveGeneric #-}
{-# Language OverloadedStrings #-} {-# Language OverloadedStrings #-}
{-# Language DuplicateRecordFields #-}
module Database.Schema where module Database.Schema where
import ClassyPrelude import ClassyPrelude
import Database.Selda.Generic import Database.Selda.Generic
import Database.Selda
import Database.Selda.Backend
data User = User { email :: Text data User pass = User { email :: Text
, username :: Text , username :: Text
, password :: ByteString } , role :: Role
, password :: pass }
deriving (Show, Generic) deriving (Show, Generic)
users :: GenTable User data Role = UserRole | AdminRole deriving (Show, Read, Enum, Bounded, Typeable)
instance SqlType Role where
mkLit = LCustom . LText . pack . show
fromSql sql = case sql of
SqlString x -> fromMaybe (error "fromSql: Not a valid role") . readMay . unpack $ x
_ -> error "fromSql: Not a valid role"
defaultValue = mkLit minBound
users :: GenTable (User ByteString)
users = genTable "users" [ email :- primaryGen ] users = genTable "users" [ email :- primaryGen ]

54
src/Database/User.hs Normal file
View File

@ -0,0 +1,54 @@
{-# Language LambdaCase #-}
{-# Language TypeApplications #-}
{-# Language DataKinds #-}
{-# Language TemplateHaskell #-}
module Database.User where
import ClassyPrelude
import Database
import Database.Schema
import Database.Selda
import Control.Lens (over, _Just)
import Data.Generics.Product
import Crypto.KDF.BCrypt
import Crypto.Random.Types (MonadRandom)
import Control.Monad.Logger
data UserExistsError = UserExistsError
newtype PlainPassword = PlainPassword Text
newtype HashedPassword = HashedPassword {unHashed :: ByteString}
data NoPassword = NoPassword
insertUser :: (MonadLogger m, MonadIO m, MonadMask m, MonadRandom m) => Text -> Text -> PlainPassword -> SeldaT m (Either UserExistsError (User NoPassword))
insertUser username email (PlainPassword password) =
getUser' username >>= maybe insert' (const (return $ Left UserExistsError))
where
insert' = adminExists >>= \e -> Right <$> if e then insertAs UserRole else insertAs AdminRole
insertAs role = do
lift $ $logInfo $ "Inserting new user as " <> pack (show role)
let bytePass = encodeUtf8 password
user <- User email username role . HashedPassword <$> lift (hashPassword 12 bytePass)
insert_ (gen users) [toRel (over (field @"password") unHashed user)] >> return (over (field @"password") (const NoPassword) user)
adminExists :: (MonadMask m, MonadLogger m, MonadIO m) => SeldaT m Bool
adminExists = do
r <- query q
lift $ $logInfo $ "Admin users: " <> (pack (show r))
return $ maybe False (> 0) . listToMaybe $ r
where
q = aggregate $ do
(_ :*: _ :*: r :*: _) <- select (gen users)
restrict (r .== literal AdminRole)
return (count r)
getUser :: (MonadMask m, MonadIO m) => Text -> SeldaT m (Maybe (User NoPassword))
getUser name = over (_Just . field @"password") (const NoPassword) <$> getUser' name
getUser' :: (MonadMask m, MonadIO m) => Text -> SeldaT m (Maybe ( User HashedPassword ))
getUser' name = over (_Just . field @"password") HashedPassword . listToMaybe . fmap fromRel <$> query q
where
q = do
u@(username :*: _ :*: _ :*: _) <- select (gen users)
restrict (username .== literal name)
return u

View File

@ -1,7 +1,8 @@
{-# Language OverloadedStrings #-}
module Devel.Main where module Devel.Main where
import Main (defaultMain) import Prelude
import Control.Monad.Trans.Reader (runReaderT)
import Main (withApp, defaultMain)
import Control.Concurrent import Control.Concurrent
import Control.Monad (void) import Control.Monad (void)
import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.IORef (IORef, newIORef, readIORef, writeIORef)
@ -9,6 +10,10 @@ import Foreign.Store (Store(..), lookupStore, readStore, storeAction, withStore)
import GHC.Word (Word32) import GHC.Word (Word32)
import Dhall (input, auto) import Dhall (input, auto)
import Database.Schema
import Database.Selda (tryCreateTable)
import Database
update :: IO () update :: IO ()
update = do update = do
lookupStore tidStoreNum >>= maybe setupNew restart lookupStore tidStoreNum >>= maybe setupNew restart
@ -25,7 +30,17 @@ update = do
withStore doneStore takeMVar withStore doneStore takeMVar
readStore doneStore >>= start readStore doneStore >>= start
start :: MVar () -> IO ThreadId start :: MVar () -> IO ThreadId
start done = forkFinally (input auto "./config/devel.dhall" >>= defaultMain) (\_ -> putMVar done ()) start done = forkFinally develMain (\_ -> putMVar done ())
develMain :: IO ()
develMain = do
conf <- input auto "./config/devel.dhall"
withApp conf $ \app -> do
void $ runReaderT (runDB migrate) app
defaultMain app
where
migrate = do
tryCreateTable (gen users)
modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO () modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()
modifyStoredIORef store f = withStore store $ \ref -> do modifyStoredIORef store f = withStore store $ \ref -> do

View File

@ -17,28 +17,20 @@ import Data.Generics.Product
import Data.Pool (createPool) import Data.Pool (createPool)
import Database.Selda.PostgreSQL (PGConnectInfo(..), pgOpen, seldaClose) import Database.Selda.PostgreSQL (PGConnectInfo(..), pgOpen, seldaClose)
defaultMain :: Config -> IO () defaultMain :: App -> IO ()
defaultMain config = do defaultMain = run 8080 . server
withApp :: Config -> (App -> IO ()) -> IO ()
withApp config f = do
let pgHost = view (field @"database" . field @"host") config let pgHost = view (field @"database" . field @"host") config
pgPort = 5432 pgPort = 5432
pgDatabase = view (field @"database" . field @"database") config pgDatabase = view (field @"database" . field @"database") config
pgUsername = Just (view (field @"database" . field @"username") config) pgUsername = Just (view (field @"database" . field @"username") config)
pgPassword = Just (view (field @"database" . field @"password") config) pgPassword = Just (view (field @"database" . field @"password") config)
database <- createPool (pgOpen (PGConnectInfo{..})) seldaClose 10 2 5 database <- createPool (pgOpen (PGConnectInfo{..})) seldaClose 10 2 5
let app = App{..} f App{..}
run 8080 (server app)
-- migrate :: Pg -> IO ()
-- migrate Pg{..} = do
-- -- Credentials visible on ps
-- -- XXX: Modify this to write the credentials to a temporary file or something
-- callProcess "flyway" $ fmap unpack [ "migrate"
-- , "-locations=filesystem:migrations/"
-- , "-url=jdbc:postgresql://" <> host <> "/" <> database
-- , "-user=" <> username
-- , "-password=" <> password]
main :: IO () main :: IO ()
main = do main = do
c <- input auto "./config/config.dhall" c <- input auto "./config/config.dhall"
defaultMain c withApp c defaultMain

View File

@ -1,5 +1,7 @@
{-# Language NoImplicitPrelude #-} {-# Language NoImplicitPrelude #-}
{-# Language DeriveGeneric #-} {-# Language DeriveGeneric #-}
{-# Language TypeSynonymInstances #-}
{-# Language FlexibleInstances #-}
module Types where module Types where
import ClassyPrelude import ClassyPrelude
@ -7,9 +9,13 @@ import Control.Monad.Logger
import Configuration import Configuration
import Data.Pool (Pool) import Data.Pool (Pool)
import Database.Selda.Backend (SeldaConnection) import Database.Selda.Backend (SeldaConnection)
import Crypto.Random.Types (MonadRandom(..))
data App = App { config :: Config data App = App { config :: Config
, database :: Pool SeldaConnection } , database :: Pool SeldaConnection }
deriving (Generic) deriving (Generic)
type AppM = LoggingT (ReaderT App IO) type AppM = LoggingT (ReaderT App IO)
instance MonadRandom AppM where
getRandomBytes = lift . lift . getRandomBytes