forgotten files
This commit is contained in:
parent
61f0bb5ee7
commit
0b499caae4
5 changed files with 613 additions and 0 deletions
25
src/Aggreact/Users.hs
Normal file
25
src/Aggreact/Users.hs
Normal file
|
@ -0,0 +1,25 @@
|
|||
{- |
|
||||
Module : Aggreact.Users
|
||||
Description : Example of a library file.
|
||||
Copyright : (c) 2018, Yann Esposito
|
||||
License : ISC
|
||||
Maintainer : yann.esposito@gmail.com
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
This module is here just to re-export sub modules.
|
||||
Because the original module was split because it was too big.
|
||||
|
||||
-}
|
||||
module Aggreact.Users
|
||||
( module Aggreact.Users.StoreService
|
||||
, module Aggreact.Users.Types
|
||||
, module Aggreact.Users.Views
|
||||
, module Aggreact.Users.Server
|
||||
)
|
||||
where
|
||||
|
||||
import Aggreact.Users.StoreService
|
||||
import Aggreact.Users.Types
|
||||
import Aggreact.Users.Views
|
||||
import Aggreact.Users.Server
|
96
src/Aggreact/Users/Server.hs
Normal file
96
src/Aggreact/Users/Server.hs
Normal file
|
@ -0,0 +1,96 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NamedWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
|
||||
{- |
|
||||
Module : Aggreact.Users.Server
|
||||
Description : Server for Users
|
||||
Copyright : (c) 2018, Yann Esposito
|
||||
License : ISC
|
||||
Maintainer : yann.esposito@gmail.com
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
Provide a Store abstraction.
|
||||
|
||||
-}
|
||||
|
||||
module Aggreact.Users.Server
|
||||
|
||||
where
|
||||
|
||||
import Protolude
|
||||
|
||||
import Aggreact.Users.StoreService
|
||||
import Aggreact.Users.Types
|
||||
import Aggreact.Users.Views
|
||||
|
||||
import Database.SQLite.Simple (NamedParam (..))
|
||||
import Database.Store
|
||||
import Database.Store.Backend.SQLite (SearchQuery (Filter))
|
||||
import qualified Database.Store.Backend.SQLite as SQL
|
||||
import Servant
|
||||
import Servant.Auth.Server (AuthResult (..))
|
||||
import Servant.Errors as Err
|
||||
import Servant.HTML.Blaze (HTML)
|
||||
|
||||
-- * User API
|
||||
|
||||
type UserAPI =
|
||||
"users" :> Capture "usernick" Nick :> Get '[HTML,JSON] UserPage
|
||||
:<|> "users" :> Capture "userid" Id :> Delete '[HTML,JSON] UserDeletedPage
|
||||
:<|> "users" :> Get '[HTML,JSON] UsersPage
|
||||
:<|> "users" :> ReqBody '[JSON,FormUrlEncoded] NewUser
|
||||
:> PostCreated '[HTML,JSON] RegisteredUserPage
|
||||
|
||||
userAPI :: UserHandler
|
||||
-- -> AuthorizationHandler
|
||||
-> AuthResult User
|
||||
-> Server UserAPI
|
||||
userAPI userHandler authResult =
|
||||
let muser = case authResult of
|
||||
(Servant.Auth.Server.Authenticated user) -> Just user
|
||||
_ -> Nothing
|
||||
in
|
||||
getUserByNick muser userHandler
|
||||
:<|> deleteUserById muser userHandler
|
||||
:<|> listUsers muser userHandler
|
||||
:<|> postUser muser userHandler
|
||||
|
||||
-- GET User
|
||||
getUserByNick :: Maybe User -> UserHandler -> Nick -> Handler UserPage
|
||||
getUserByNick muser userHandler userNick = do
|
||||
SQL.SR (SQL.Paginated mu _ _) <- liftIO $
|
||||
searchUsers userHandler Filter {params = ["nick" := userNick]}
|
||||
case mu of
|
||||
[] -> Err.notFound "user not found"
|
||||
[u] -> pure (UserPage u muser)
|
||||
_ -> Err.internalServerError "Incoherent DB"
|
||||
|
||||
getUserById :: Maybe User -> UserHandler -> Id -> Handler UserPage
|
||||
getUserById muser userHandler userId = do
|
||||
mu <- liftIO $ readUser userHandler userId
|
||||
case mu of
|
||||
Nothing -> Err.notFound "user not found"
|
||||
Just u -> pure (UserPage u muser)
|
136
src/Aggreact/Users/StoreService.hs
Normal file
136
src/Aggreact/Users/StoreService.hs
Normal file
|
@ -0,0 +1,136 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NamedWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
|
||||
{- |
|
||||
Module : Aggreact.Users.StoreService
|
||||
Description : Users store specific functions
|
||||
Copyright : (c) 2018, Yann Esposito
|
||||
License : ISC
|
||||
Maintainer : yann.esposito@gmail.com
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
Provide a Store abstraction.
|
||||
|
||||
-}
|
||||
|
||||
module Aggreact.Users.StoreService
|
||||
|
||||
where
|
||||
|
||||
import Protolude hiding (pass)
|
||||
|
||||
import Aggreact.Users.Types
|
||||
|
||||
import qualified Crypto.Scrypt as Crypt
|
||||
import Database.SQLite.Simple (NamedParam (..))
|
||||
import Database.Store
|
||||
import Database.Store.Backend.SQLite (SQLiteStore,
|
||||
SearchQuery (Filter),
|
||||
SearchResult (SR))
|
||||
import qualified Database.Store.Backend.SQLite as SQL
|
||||
import qualified Database.Store.CRUD as CRUD
|
||||
import qualified Database.Store.Search as Search
|
||||
|
||||
-- * Usage for DB
|
||||
|
||||
type UserSQLiteStore = SQLiteStore IO DefaultMetas NewUser
|
||||
type DBStore = StartedStore UserSQLiteStore
|
||||
type UserDBConf = DBConf UserSQLiteStore
|
||||
type UserSearchQuery = Search.SearchQuery UserSQLiteStore
|
||||
type UserSearchResult = Search.SearchResult UserSQLiteStore
|
||||
|
||||
hashPass :: Text -> IO HashedPassword
|
||||
hashPass pass =
|
||||
HashedPassword . toS . Crypt.getEncryptedPass
|
||||
<$> Crypt.encryptPassIO Crypt.defaultParams (Crypt.Pass (toS pass))
|
||||
|
||||
initDBUsers :: UserDBConf -> NewUser -> IO DBStore
|
||||
initDBUsers conf adminUser = do
|
||||
dbstore <- init conf
|
||||
(SR (SQL.Paginated admins _ _)) <- searchUsers' dbstore (Filter ["role" := Admin])
|
||||
case admins of
|
||||
[] -> void $ createUser' dbstore adminUser
|
||||
_ -> pure ()
|
||||
pure dbstore
|
||||
|
||||
stopDBUsers' :: DBStore -> IO ()
|
||||
stopDBUsers' = stop
|
||||
|
||||
createUser' :: DBStore -> NewUser -> IO User
|
||||
createUser' dbstore nu = do
|
||||
encpass <- hashPass (toS (password nu))
|
||||
CRUD.create dbstore (nu { password = encpass })
|
||||
|
||||
readUser' :: DBStore -> Id -> IO (Maybe User)
|
||||
readUser' = CRUD.read
|
||||
|
||||
updateUser' :: DBStore -> Id -> NewUser -> IO (Maybe User)
|
||||
updateUser' = CRUD.update
|
||||
|
||||
deleteUser' :: DBStore -> Id -> IO Bool
|
||||
deleteUser' = CRUD.delete
|
||||
|
||||
searchUsers' :: DBStore -> UserSearchQuery -> IO UserSearchResult
|
||||
searchUsers' = Search.search
|
||||
|
||||
data UserHandler = UserHandler
|
||||
{ createUser :: NewUser -> IO User
|
||||
, readUser :: Id -> IO (Maybe User)
|
||||
, updateUser :: Id -> NewUser -> IO (Maybe User)
|
||||
, deleteUser :: Id -> IO Bool
|
||||
, searchUsers :: UserSearchQuery -> IO UserSearchResult
|
||||
, stopDBUsers :: IO ()
|
||||
, dbstore :: DBStore
|
||||
}
|
||||
|
||||
-- | Init a new comment handler
|
||||
newUserHandler :: UserDBConf -> NewUser -> IO UserHandler
|
||||
newUserHandler conf adminUser = do
|
||||
dbstore <- initDBUsers conf adminUser
|
||||
pure UserHandler { createUser = createUser' dbstore
|
||||
, readUser = readUser' dbstore
|
||||
, updateUser = updateUser' dbstore
|
||||
, deleteUser = deleteUser' dbstore
|
||||
, searchUsers = searchUsers' dbstore
|
||||
, stopDBUsers = stopDBUsers' dbstore
|
||||
, dbstore = dbstore
|
||||
}
|
||||
|
||||
-- * Security
|
||||
checkUserLogin :: UserHandler -> Text -> Text -> IO (Maybe User)
|
||||
checkUserLogin uh loginNick loginPass = do
|
||||
(SQL.SR (SQL.Paginated users _ _)) <- searchUsers uh
|
||||
Filter { params = [ "nick" := loginNick ]}
|
||||
case users of
|
||||
[user] -> do
|
||||
let (goodPassword,_) = Crypt.verifyPass
|
||||
Crypt.defaultParams
|
||||
(Crypt.Pass (toS loginPass))
|
||||
(Crypt.EncryptedPass (toS (password (val user))))
|
||||
if goodPassword
|
||||
then pure (Just user)
|
||||
else pure Nothing
|
||||
_ -> pure Nothing
|
181
src/Aggreact/Users/Types.hs
Normal file
181
src/Aggreact/Users/Types.hs
Normal file
|
@ -0,0 +1,181 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NamedWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
|
||||
{- |
|
||||
Module : Aggreact.Users.Types
|
||||
Description : User related types
|
||||
Copyright : (c) 2018, Yann Esposito
|
||||
License : ISC
|
||||
Maintainer : yann.esposito@gmail.com
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
Provide a Store abstraction.
|
||||
|
||||
-}
|
||||
|
||||
module Aggreact.Users.Types
|
||||
|
||||
where
|
||||
|
||||
import Protolude
|
||||
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import Data.Data (Data (..))
|
||||
import qualified Data.Text as Text
|
||||
import Database.SQLite.Simple (SQLData (..))
|
||||
|
||||
import Database.SQLite.Simple.FromField (FromField (..),
|
||||
ResultError (..), fieldData,
|
||||
returnError)
|
||||
import Database.SQLite.Simple.FromRow (FromRow (..))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import Database.SQLite.Simple.ToRow (ToRow (..))
|
||||
import Database.Store
|
||||
import Database.Store.Backend.SQLite (SQLiteSchemas,
|
||||
ToSQLiteFieldTypeList (..))
|
||||
|
||||
|
||||
|
||||
import qualified Database.Store.Backend.SQLite as SQL
|
||||
import qualified Generics.SOP as SOP
|
||||
import Servant
|
||||
import Servant.Auth.Server (FromJWT (..), ToJWT (..))
|
||||
|
||||
import qualified Web.FormUrlEncoded as Form
|
||||
import qualified Web.HttpApiData as FormI
|
||||
|
||||
-- NewUser
|
||||
data NewUser =
|
||||
NewUser { nick :: Nick
|
||||
, email :: Email
|
||||
, password :: HashedPassword
|
||||
, role :: Role
|
||||
, trust :: Int
|
||||
} deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||
instance Form.FromForm NewUser where
|
||||
fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity}
|
||||
|
||||
newtype Nick = Nick Text
|
||||
deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||
deriving anyclass instance FromJSON Nick
|
||||
deriving anyclass instance ToJSON Nick
|
||||
instance FormI.FromHttpApiData Nick where parseUrlPiece = fmap Nick . FormI.parseUrlPiece
|
||||
deriving newtype instance FromField Nick
|
||||
deriving newtype instance ToField Nick
|
||||
instance StringConv Nick [Char] where strConv l (Nick sl) = strConv l sl
|
||||
instance StringConv Nick Text where strConv l (Nick sl) = strConv l sl
|
||||
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Nick ': rest) where
|
||||
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
|
||||
|
||||
data Role = User | Admin
|
||||
deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||
deriving anyclass instance FromJSON Role
|
||||
deriving anyclass instance ToJSON Role
|
||||
instance FormI.FromHttpApiData Role where
|
||||
parseUrlPiece x =
|
||||
case fmap Text.toLower (FormI.parseUrlPiece x) of
|
||||
Right "user" -> return User
|
||||
Right "admin" -> return Admin
|
||||
Right _ -> Left "Should be either user or admin"
|
||||
Left err -> Left err
|
||||
instance FromField Role where
|
||||
fromField f = case fieldData f of
|
||||
SQLText "User" -> return User
|
||||
SQLText "Admin" -> return Admin
|
||||
_ -> returnError ConversionFailed f "need a text containing User or Admin"
|
||||
instance ToField Role where
|
||||
toField Admin = SQLText "Admin"
|
||||
toField User = SQLText "User"
|
||||
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Role ': rest) where
|
||||
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
|
||||
|
||||
newtype Email = Email Text
|
||||
deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||
deriving anyclass instance FromJSON Email
|
||||
deriving anyclass instance ToJSON Email
|
||||
instance FormI.FromHttpApiData Email where parseUrlPiece = fmap Email . FormI.parseUrlPiece
|
||||
deriving newtype instance FromField Email
|
||||
deriving newtype instance ToField Email
|
||||
instance StringConv Email [Char] where strConv l (Email sl) = strConv l sl
|
||||
instance StringConv Email Text where strConv l (Email sl) = strConv l sl
|
||||
|
||||
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Email ': rest) where
|
||||
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
|
||||
|
||||
defaultAdminUser :: NewUser
|
||||
defaultAdminUser = NewUser { role = Admin
|
||||
, trust = 100
|
||||
, nick = Nick "admin"
|
||||
, email = Email "admin@dev.null"
|
||||
, password = HashedPassword "admin"}
|
||||
|
||||
-- * From here everything is just boilerplate
|
||||
newtype HashedPassword =
|
||||
HashedPassword Text
|
||||
deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||
deriving anyclass instance FromJWT HashedPassword
|
||||
deriving anyclass instance ToJWT HashedPassword
|
||||
deriving anyclass instance FromJSON HashedPassword
|
||||
deriving anyclass instance ToJSON HashedPassword
|
||||
deriving newtype instance FromField HashedPassword
|
||||
deriving newtype instance ToField HashedPassword
|
||||
instance FormI.FromHttpApiData HashedPassword where parseUrlPiece = fmap HashedPassword . FormI.parseUrlPiece
|
||||
instance StringConv HashedPassword [Char] where strConv l (HashedPassword sl) = strConv l sl
|
||||
instance StringConv HashedPassword Text where strConv l (HashedPassword sl) = strConv l sl
|
||||
instance StringConv HashedPassword ByteString where strConv l (HashedPassword sl) = strConv l sl
|
||||
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (HashedPassword ': rest) where
|
||||
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
|
||||
|
||||
|
||||
-- For HTTP
|
||||
deriving anyclass instance ToJSON NewUser
|
||||
deriving anyclass instance FromJSON NewUser
|
||||
|
||||
deriving instance FromJWT NewUser
|
||||
deriving instance ToJWT NewUser
|
||||
|
||||
-- For Store / SQLite
|
||||
instance SOP.Generic NewUser
|
||||
instance SOP.HasDatatypeInfo NewUser
|
||||
deriving instance SQLiteSchemas NewUser
|
||||
instance FromRow NewUser where fromRow = SQL.genericFromRow
|
||||
instance ToRow NewUser where toRow = SQL.genericToRow
|
||||
|
||||
type User = Entity DefaultMetas NewUser
|
||||
|
||||
|
||||
-- *** Field UserId
|
||||
newtype UserId = UserId Text deriving (Eq,Ord,Show,Generic,Data)
|
||||
instance StringConv UserId [Char] where strConv l (UserId sl) = strConv l sl
|
||||
instance StringConv UserId Text where strConv l (UserId sl) = strConv l sl
|
||||
deriving anyclass instance FromJSON UserId
|
||||
deriving anyclass instance ToJSON UserId
|
||||
deriving newtype instance FromField UserId
|
||||
deriving newtype instance ToField UserId
|
||||
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (UserId ': rest) where
|
||||
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
|
||||
instance FormI.FromHttpApiData UserId where
|
||||
parseUrlPiece = fmap UserId . FormI.parseUrlPiece
|
175
src/Aggreact/Users/Views.hs
Normal file
175
src/Aggreact/Users/Views.hs
Normal file
|
@ -0,0 +1,175 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NamedWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
|
||||
{- |
|
||||
Module : Aggreact.Users.Views
|
||||
Description : User
|
||||
Copyright : (c) 2018, Yann Esposito
|
||||
License : ISC
|
||||
Maintainer : yann.esposito@gmail.com
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
Provide a Store abstraction.
|
||||
|
||||
-}
|
||||
|
||||
module Aggreact.Users.Views
|
||||
|
||||
where
|
||||
|
||||
import Protolude
|
||||
|
||||
import Aggreact.Html (boilerplate, cvt, urlEncode)
|
||||
import Aggreact.Users.StoreService
|
||||
import Aggreact.Users.Types
|
||||
|
||||
import Data.Aeson (ToJSON (..))
|
||||
import qualified Data.UUID as UUID
|
||||
import Database.Store
|
||||
import Database.Store.Backend.SQLite (SearchQuery (Filter))
|
||||
import qualified Database.Store.Backend.SQLite as SQL
|
||||
import Servant
|
||||
import Servant.Errors as Err
|
||||
import Text.Blaze.Html5 ((!))
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as A
|
||||
|
||||
data UserPage =
|
||||
UserPage
|
||||
{ user :: User
|
||||
, muser :: Maybe User
|
||||
}
|
||||
|
||||
instance ToJSON UserPage where
|
||||
toJSON = toJSON . (user :: UserPage -> User)
|
||||
|
||||
instance H.ToMarkup UserPage where
|
||||
toMarkup UserPage{..} = boilerplate (loginWidget muser) $ do
|
||||
let n = toS (nick (val user))
|
||||
H.h2 $
|
||||
H.a ! A.href ("/users/" <> cvt (urlEncode n)) $ H.text (toS n)
|
||||
showUser user
|
||||
|
||||
showUser :: User -> H.Markup
|
||||
showUser user = do
|
||||
let cid = UUID.toString (toS (id user))
|
||||
nu = val user
|
||||
H.div $ do
|
||||
H.label "nick"
|
||||
H.text (toS (nick nu))
|
||||
H.div $ do
|
||||
H.label "id"
|
||||
H.text (toS cid)
|
||||
H.div $ do
|
||||
H.label "created"
|
||||
H.text (show (created (metas user)))
|
||||
H.div $ do
|
||||
H.label "email"
|
||||
H.text (toS (email (val user)))
|
||||
H.div $ do
|
||||
H.label "role"
|
||||
H.text (show (role (val user)))
|
||||
|
||||
-- DELETE User
|
||||
data UserDeletedPage =
|
||||
UserDeletedPage
|
||||
{ deleted :: Bool
|
||||
, deletedUser :: User
|
||||
, muser :: Maybe User
|
||||
}
|
||||
|
||||
instance ToJSON UserDeletedPage where
|
||||
toJSON = toJSON . deletedUser
|
||||
|
||||
instance H.ToMarkup UserDeletedPage where
|
||||
toMarkup UserDeletedPage{..} = boilerplate (loginWidget muser) $ do
|
||||
let n = toS (nick (val deletedUser))
|
||||
H.h2 $
|
||||
H.text ("User " <> n <> if deleted then " was deleted" else " couldn't be deleted!")
|
||||
|
||||
deleteUserById :: Maybe User -- ^ Logged User
|
||||
-> UserHandler
|
||||
-> Id -- ^ User id to delete
|
||||
-> Handler UserDeletedPage
|
||||
deleteUserById Nothing _ _ = unauthorized "Only admins can delete users"
|
||||
deleteUserById (Just u) userHandler userId
|
||||
| role (val u) == Admin = do
|
||||
userToDelete <- liftIO $ readUser userHandler userId
|
||||
case userToDelete of
|
||||
Nothing -> notFound "User not found!"
|
||||
Just utd -> UserDeletedPage
|
||||
<$> liftIO (deleteUser userHandler userId)
|
||||
<*> pure utd
|
||||
<*> pure (Just u)
|
||||
| otherwise = forbidden "Only admins can delete users"
|
||||
|
||||
loginWidget :: Maybe User -> H.Markup
|
||||
loginWidget Nothing = H.a ! A.href "/login" $ H.text "Login"
|
||||
loginWidget (Just (Entity _ nu _)) = H.a ! A.href ("/users/" <> cvt (nick nu)) $ H.text (toS (nick nu))
|
||||
|
||||
-- List Users
|
||||
data UsersPage =
|
||||
UsersPage
|
||||
{ users :: [User]
|
||||
, muser :: Maybe User
|
||||
}
|
||||
|
||||
instance ToJSON UsersPage where
|
||||
toJSON = toJSON . users
|
||||
|
||||
instance H.ToMarkup UsersPage where
|
||||
toMarkup UsersPage{..} = boilerplate (loginWidget muser) $ do
|
||||
H.h2 $ H.text "Users"
|
||||
traverse_ (\u -> showUser u >> H.hr) users
|
||||
|
||||
listUsers :: Maybe User -> UserHandler -> Handler UsersPage
|
||||
listUsers muser userHandler = do
|
||||
SQL.SR (SQL.Paginated mu _ _) <- liftIO $
|
||||
searchUsers userHandler Filter {params = []}
|
||||
pure (UsersPage mu muser)
|
||||
|
||||
-- Create User
|
||||
data RegisteredUserPage =
|
||||
RegisteredUsersPage
|
||||
{ user :: User
|
||||
, muser :: Maybe User
|
||||
}
|
||||
|
||||
instance ToJSON RegisteredUserPage where
|
||||
toJSON = toJSON . (user :: RegisteredUserPage -> User)
|
||||
|
||||
instance H.ToMarkup RegisteredUserPage where
|
||||
toMarkup RegisteredUsersPage{..} = boilerplate (loginWidget muser) $ do
|
||||
H.h2 $ H.text "Users"
|
||||
showUser user
|
||||
|
||||
postUser :: Maybe User
|
||||
-> UserHandler
|
||||
-> NewUser
|
||||
-> Handler RegisteredUserPage
|
||||
postUser muser userHandler nu = do
|
||||
u <- liftIO $ createUser userHandler nu
|
||||
pure (RegisteredUsersPage u muser)
|
Loading…
Reference in a new issue