From 93fe3a573d07607b27e4f669ebfd4c322408d904 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Fri, 3 Aug 2018 23:36:38 +0300 Subject: [PATCH] Register new users --- ebook-manager.cabal | 8 ++++++ src/API.hs | 8 +++++- src/API/Users.hs | 62 ++++++++++++++++++++++++++++++++++++++++++ src/Database.hs | 7 +++-- src/Database/Schema.hs | 22 ++++++++++++--- src/Database/User.hs | 54 ++++++++++++++++++++++++++++++++++++ src/Devel/Main.hs | 21 ++++++++++++-- src/Main.hs | 22 +++++---------- src/Types.hs | 6 ++++ 9 files changed, 185 insertions(+), 25 deletions(-) create mode 100644 src/API/Users.hs create mode 100644 src/Database/User.hs diff --git a/ebook-manager.cabal b/ebook-manager.cabal index 23c35d1..4c98c95 100644 --- a/ebook-manager.cabal +++ b/ebook-manager.cabal @@ -19,9 +19,11 @@ executable ebook-manager main-is: Main.hs other-modules: Devel.Main , API + , API.Users , Configuration , Database , Database.Schema + , Database.User , Server , Types -- other-extensions: @@ -55,5 +57,11 @@ executable ebook-manager , selda , selda-postgresql , process + , aeson + , http-api-data hs-source-dirs: src + default-extensions: DeriveGeneric + , NoImplicitPrelude + , OverloadedStrings + , RecordWildCards default-language: Haskell2010 diff --git a/src/API.hs b/src/API.hs index 218099d..1d6fb83 100644 --- a/src/API.hs +++ b/src/API.hs @@ -20,6 +20,8 @@ import qualified Lucid.Html5 as H import Types import Control.Monad.Logger +import qualified API.Users as Users + -- XXX: Temporary import Database.Schema import Database @@ -44,9 +46,13 @@ instance ToHtml Index where toHtmlRaw = toHtml type API = Get '[HTML] Index + :<|> Users.API handler :: ServerT API AppM -handler = do +handler = indexHandler :<|> Users.handler + +indexHandler :: AppM Index +indexHandler = do u <- runDB $ do query $ select $ gen users $logInfo $ "users: " <> (pack . show $ u) diff --git a/src/API/Users.hs b/src/API/Users.hs new file mode 100644 index 0000000..00613e0 --- /dev/null +++ b/src/API/Users.hs @@ -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"} diff --git a/src/Database.hs b/src/Database.hs index 4b8b714..da596f7 100644 --- a/src/Database.hs +++ b/src/Database.hs @@ -7,7 +7,10 @@ module Database , runDB , query , select - , gen ) + , gen + , fromRel + , toRel + , SeldaT ) where import Data.Generics.Product @@ -15,7 +18,7 @@ import Control.Lens (view) import Data.Pool (Pool, withResource) import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT) import Database.Selda (query, select) -import Database.Selda.Generic (gen) +import Database.Selda.Generic (gen, fromRel, toRel) import ClassyPrelude type DBLike r m = (MonadIO m, MonadReader r m, MonadBaseControl IO m, MonadMask m, HasField' "database" r (Pool SeldaConnection)) diff --git a/src/Database/Schema.hs b/src/Database/Schema.hs index b3675c1..bc6a2ab 100644 --- a/src/Database/Schema.hs +++ b/src/Database/Schema.hs @@ -1,15 +1,29 @@ {-# Language NoImplicitPrelude #-} {-# Language DeriveGeneric #-} {-# Language OverloadedStrings #-} +{-# Language DuplicateRecordFields #-} module Database.Schema where import ClassyPrelude import Database.Selda.Generic +import Database.Selda +import Database.Selda.Backend -data User = User { email :: Text - , username :: Text - , password :: ByteString } +data User pass = User { email :: Text + , username :: Text + , role :: Role + , password :: pass } 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 ] diff --git a/src/Database/User.hs b/src/Database/User.hs new file mode 100644 index 0000000..b3aec14 --- /dev/null +++ b/src/Database/User.hs @@ -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 diff --git a/src/Devel/Main.hs b/src/Devel/Main.hs index 84e8726..de3fb89 100644 --- a/src/Devel/Main.hs +++ b/src/Devel/Main.hs @@ -1,7 +1,8 @@ -{-# Language OverloadedStrings #-} module Devel.Main where -import Main (defaultMain) +import Prelude +import Control.Monad.Trans.Reader (runReaderT) +import Main (withApp, defaultMain) import Control.Concurrent import Control.Monad (void) import Data.IORef (IORef, newIORef, readIORef, writeIORef) @@ -9,6 +10,10 @@ import Foreign.Store (Store(..), lookupStore, readStore, storeAction, withStore) import GHC.Word (Word32) import Dhall (input, auto) +import Database.Schema +import Database.Selda (tryCreateTable) +import Database + update :: IO () update = do lookupStore tidStoreNum >>= maybe setupNew restart @@ -25,7 +30,17 @@ update = do withStore doneStore takeMVar readStore doneStore >>= start 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 f = withStore store $ \ref -> do diff --git a/src/Main.hs b/src/Main.hs index 5f5d3c4..29e4fa7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -17,28 +17,20 @@ import Data.Generics.Product import Data.Pool (createPool) import Database.Selda.PostgreSQL (PGConnectInfo(..), pgOpen, seldaClose) -defaultMain :: Config -> IO () -defaultMain config = do +defaultMain :: App -> IO () +defaultMain = run 8080 . server + +withApp :: Config -> (App -> IO ()) -> IO () +withApp config f = do let pgHost = view (field @"database" . field @"host") config pgPort = 5432 pgDatabase = view (field @"database" . field @"database") config pgUsername = Just (view (field @"database" . field @"username") config) pgPassword = Just (view (field @"database" . field @"password") config) database <- createPool (pgOpen (PGConnectInfo{..})) seldaClose 10 2 5 - let app = 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] + f App{..} main :: IO () main = do c <- input auto "./config/config.dhall" - defaultMain c + withApp c defaultMain diff --git a/src/Types.hs b/src/Types.hs index 2593c31..7b29f6f 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,5 +1,7 @@ {-# Language NoImplicitPrelude #-} {-# Language DeriveGeneric #-} +{-# Language TypeSynonymInstances #-} +{-# Language FlexibleInstances #-} module Types where import ClassyPrelude @@ -7,9 +9,13 @@ import Control.Monad.Logger import Configuration import Data.Pool (Pool) import Database.Selda.Backend (SeldaConnection) +import Crypto.Random.Types (MonadRandom(..)) data App = App { config :: Config , database :: Pool SeldaConnection } deriving (Generic) type AppM = LoggingT (ReaderT App IO) + +instance MonadRandom AppM where + getRandomBytes = lift . lift . getRandomBytes