Modify types, create instances

This commit is contained in:
Mats Rauhala 2018-08-04 22:05:41 +03:00
parent ac82f6973b
commit 964972858b
4 changed files with 72 additions and 31 deletions

View File

@ -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

View File

@ -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"}

View File

@ -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

View File

@ -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