From 964972858b8643654ab8d70b190f31bff19dfd7d Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Sat, 4 Aug 2018 22:05:41 +0300 Subject: [PATCH] Modify types, create instances --- src/API.hs | 8 -------- src/API/Users.hs | 31 ++++++++++++++++++++-------- src/Database/Schema.hs | 46 ++++++++++++++++++++++++++++++++++++------ src/Database/User.hs | 18 ++++++++--------- 4 files changed, 72 insertions(+), 31 deletions(-) diff --git a/src/API.hs b/src/API.hs index 1d6fb83..dbe61e1 100644 --- a/src/API.hs +++ b/src/API.hs @@ -18,14 +18,9 @@ import Servant.HTML.Lucid (HTML) import Lucid (HtmlT, ToHtml(..)) 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 - data Index = Index bulma :: Monad m => HtmlT m () @@ -53,7 +48,4 @@ handler = indexHandler :<|> Users.handler indexHandler :: AppM Index indexHandler = do - u <- runDB $ do - query $ select $ gen users - $logInfo $ "users: " <> (pack . show $ u) return Index diff --git a/src/API/Users.hs b/src/API/Users.hs index 00613e0..e6e7a36 100644 --- a/src/API/Users.hs +++ b/src/API/Users.hs @@ -4,7 +4,8 @@ {-# Language NoImplicitPrelude #-} {-# Language TypeOperators #-} {-# Language DuplicateRecordFields #-} -module API.Users (API, handler) where +{-# Language TypeApplications #-} +module API.Users where import Servant import ClassyPrelude @@ -13,18 +14,21 @@ import Data.Aeson import Web.FormUrlEncoded import Database (runDB) import Database.User +import Database.Schema +import Control.Lens (view) +import Data.Generics.Product data LoginForm = LoginForm { username :: Text , password :: Text } deriving (Generic, Show) -data RegisterForm = RegisterForm { username :: Text - , email :: Text - , password :: Text - , passwordAgain :: Text } +data RegisterForm = RegisterForm { username :: Username + , email :: Email + , password :: PlainPassword + , passwordAgain :: PlainPassword } deriving (Generic, Show) -data LoginStatus = LoginStatus deriving Generic +data LoginStatus = LoginStatus ( Maybe SafeUser ) deriving Generic data RegisterStatus = RegisterStatus deriving Generic @@ -42,6 +46,15 @@ instance FromJSON RegisterStatus instance FromForm RegisterForm instance ToForm RegisterForm +-- generic-lens can convert similar types to this +data SafeUser = SafeUser { email :: Email + , username :: Username + , role :: Role } + deriving (Show, Generic) + +instance ToJSON SafeUser where +instance FromJSON SafeUser where + type API = "login" :> ReqBody '[JSON, FormUrlEncoded] LoginForm :> Post '[JSON] LoginStatus :<|> "register" :> ReqBody '[JSON, FormUrlEncoded] RegisterForm :> Post '[JSON] RegisterStatus @@ -49,14 +62,16 @@ handler :: ServerT API AppM handler = loginHandler :<|> registerHandler loginHandler :: LoginForm -> AppM LoginStatus -loginHandler LoginForm{..} = throwM err403 +loginHandler LoginForm{..} = do + user <- fmap (view (super @SafeUser)) <$> runDB (validateUser (Username username) (PlainPassword password)) + return (LoginStatus user) registerHandler :: RegisterForm -> AppM RegisterStatus registerHandler RegisterForm{..} = case () of () | password /= passwordAgain -> noMatch | otherwise -> - either (const alreadyExists) (const (pure RegisterStatus)) =<< runDB (insertUser username email (PlainPassword password)) + either (const alreadyExists) (const (pure RegisterStatus)) =<< runDB (insertUser username email password) where noMatch = throwM err403{errBody = "passwords don't match"} alreadyExists = throwM err403{errBody = "User already exists"} diff --git a/src/Database/Schema.hs b/src/Database/Schema.hs index 046d7cd..b4f02c8 100644 --- a/src/Database/Schema.hs +++ b/src/Database/Schema.hs @@ -2,6 +2,7 @@ {-# Language DeriveGeneric #-} {-# Language OverloadedStrings #-} {-# Language DuplicateRecordFields #-} +{-# Language GeneralizedNewtypeDeriving #-} module Database.Schema where import ClassyPrelude @@ -9,15 +10,48 @@ import Database.Selda.Generic import Database.Selda import Database.Selda.Backend +import Data.Aeson +import Web.HttpApiData + -- | User type +newtype PlainPassword = PlainPassword Text deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq) +newtype HashedPassword = HashedPassword {unHashed :: ByteString} +data NoPassword = NoPassword + +newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData) + +newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData) + +instance SqlType HashedPassword where + mkLit = LCustom . LBlob . unHashed + fromSql (SqlBlob x) = HashedPassword x + fromSql _ = error "fromSql: Bad hash" + defaultValue = mkLit (HashedPassword "") -- Makes no sense + +instance SqlType Email where + mkLit = LCustom . LText . unEmail + fromSql (SqlString x) = Email x + fromSql _ = error "fromSql: Bad email" + defaultValue = mkLit (Email "") + +instance SqlType Username where + mkLit = LCustom . LText . unUsername + fromSql (SqlString x) = Username x + fromSql _ = error "fromSql: Bad username" + defaultValue = mkLit (Username "") + + data User pass = User { identifier :: RowID - , email :: Text - , username :: Text + , email :: Email + , username :: Username , role :: Role , password :: pass } deriving (Show, Generic) -data Role = UserRole | AdminRole deriving (Show, Read, Enum, Bounded, Typeable) +data Role = UserRole | AdminRole deriving (Show, Read, Enum, Bounded, Typeable, Generic) + +instance ToJSON Role +instance FromJSON Role instance SqlType Role where mkLit = LCustom . LText . pack . show @@ -27,10 +61,10 @@ instance SqlType Role where defaultValue = mkLit minBound -users :: GenTable (User ByteString) -users = genTable "users" [ (email :: User ByteString -> Text) :- uniqueGen +users :: GenTable (User HashedPassword) +users = genTable "users" [ (email :: User HashedPassword -> Email) :- uniqueGen , username :- uniqueGen - , (identifier :: User ByteString -> RowID) :- autoPrimaryGen ] + , (identifier :: User HashedPassword -> RowID) :- autoPrimaryGen ] -- | Book type newtype HashDigest = HashDigest { unHex :: Text } deriving Show diff --git a/src/Database/User.hs b/src/Database/User.hs index 6c89f68..cec5341 100644 --- a/src/Database/User.hs +++ b/src/Database/User.hs @@ -16,11 +16,8 @@ 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 :: (MonadLogger m, MonadIO m, MonadMask m, MonadRandom m) => Username -> Email -> PlainPassword -> SeldaT m (Either UserExistsError (User NoPassword)) insertUser username email (PlainPassword password) = getUser' username >>= maybe insert' (const (return $ Left UserExistsError)) where @@ -29,7 +26,7 @@ insertUser username email (PlainPassword password) = lift $ $logInfo $ "Inserting new user as " <> pack (show role) let bytePass = encodeUtf8 password user <- User def email username role . HashedPassword <$> lift (hashPassword 12 bytePass) - insert_ (gen users) [toRel (over (field @"password") unHashed user)] >> return (over (field @"password") (const NoPassword) user) + insert_ (gen users) [toRel user] >> return (over (field @"password") (const NoPassword) user) adminExists :: (MonadMask m, MonadLogger m, MonadIO m) => SeldaT m Bool adminExists = do @@ -42,13 +39,16 @@ adminExists = do restrict (r .== literal AdminRole) return (count r) -getUser :: (MonadMask m, MonadIO m) => Text -> SeldaT m (Maybe (User NoPassword)) +getUser :: (MonadMask m, MonadIO m) => Username -> 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 +validateUser :: (MonadMask m, MonadIO m) => Username -> PlainPassword -> SeldaT m (Maybe (User NoPassword)) +validateUser name _ = getUser name + +getUser' :: (MonadMask m, MonadIO m) => Username -> SeldaT m (Maybe ( User HashedPassword )) +getUser' name = listToMaybe . fmap fromRel <$> query q where q = do - u@(_ :*: username :*: _ :*: _ :*: _) <- select (gen users) + u@(_ :*: _ :*: username :*: _ ) <- select (gen users) restrict (username .== literal name) return u