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