Modify types, create instances
This commit is contained in:
parent
ac82f6973b
commit
964972858b
@ -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
|
||||
|
@ -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"}
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user