yogsototh/aggreact
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Refacto

Browse source
This commit is contained in:
Yann Esposito (Yogsototh) 2019-04-14 16:44:37 +02:00
parent 06b119c0b2
commit 61f0bb5ee7
Signed by untrusted user who does not match committer: yogsototh
GPG key ID: 7B19A4C650D59646
15 changed files with 73 additions and 471 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
aggreact.cabal
View file

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 27862505c7dc62ea262fb1247ffa1117a3eeb29926688e1a74f5033583e42a66
-- hash: 5edc28ddb6ddbaae8fca1102380d6eca821d473ed494bca0e66de11e29600b9f
name: aggreact
version: 0.1.0.0
@ -46,7 +46,11 @@ library
Aggreact.Slugs.StoreService
Aggreact.Slugs.Types
Aggreact.Slugs.Views
Aggreact.User
Aggreact.Users
Aggreact.Users.Server
Aggreact.Users.StoreService
Aggreact.Users.Types
Aggreact.Users.Views
Data.IxSet.OrphanInstances
Database.Store
Database.Store.Backend.SQLite

2
src/Aggreact.hs
View file

@ -47,7 +47,7 @@ import Aggreact.Authorization
import Aggreact.Comments
import Aggreact.Homepage
import Aggreact.Slugs
import Aggreact.User
import Aggreact.Users
import Network.Wai (Application)
import Network.Wai.Handler.Warp (run)

4
src/Aggreact/Auth.hs
View file

@ -36,7 +36,7 @@ import Protolude
--------------------------------------------------------------------------------
import Aggreact.Html
import Aggreact.User (NewUser (..), User, UserHandler (..),
import Aggreact.Users (NewUser (..), User, UserHandler (..),
checkUserLogin, loginWidget)
--------------------------------------------------------------------------------
@ -105,7 +105,7 @@ checkCreds LoginSettings{..} (Login loginNick loginPass) origin = do
data PendingAction = NoAction | URL Text
data LoggedIn =
LoggedIn { user :: User
LoggedIn { user :: User
, pendingAction :: PendingAction
}

23
src/Aggreact/Authorization.hs
View file

@ -28,14 +28,16 @@ module Aggreact.Authorization
, AuthorizationHandler (..)
, Access(..)
, newAuthorizationHandler
, scopeToStr
)
where
import Protolude
import Aggreact.Scopes (Access (..), Scope (..), Scopes)
import Aggreact.Scopes (Access (..), Scope (..), Scopes,
displayScope, displayScopes)
import Aggreact.Servant.Errors (forbidden)
import Aggreact.User (NewUser (..), Role (..), User)
import Aggreact.Users (NewUser (..), Role (..), User)
import qualified Data.Set as Set
import qualified Data.Text as Text
@ -51,6 +53,7 @@ data AuthorizationHandler =
AuthorizationHandler
{ filterAccess :: Scope -> Maybe User -> Handler ()
, hasScope :: Scope -> Maybe User -> Bool
, userScopes :: Maybe User -> Scopes
}
newAuthorizationHandler :: AuthorizationStrategy -> IO AuthorizationHandler
@ -58,6 +61,7 @@ newAuthorizationHandler as = pure
AuthorizationHandler
{ filterAccess = filterAccess'
, hasScope = hasScope' as
, userScopes = userScopes' as
}
where
filterAccess' s mu =
@ -66,10 +70,9 @@ newAuthorizationHandler as = pure
else forbidden ("You are not allowed to do that."
<> " You need to have the following scope: "
<> "\"" <> displayScope s <> "\"."
<> " Yours are: "
<> displayScopes (userScopes' as mu)
) mu
displayScope Scope{..} = resource <> (case access of
Read -> ":read"
Write -> ":write")
strToScope :: Text -> Maybe Scope
strToScope txt =
@ -124,6 +127,12 @@ scopesFor u LoggedInOnly =
& fmap Set.fromList
& fromMaybe Set.empty
scopeToStr :: Scope -> Text
scopeToStr (Scope res acc) = res <> case acc of Read -> ":read"; Write -> ":write"
userScopes' :: AuthorizationStrategy -> Maybe User -> Scopes
userScopes' authStrat Nothing = unloggedScopes authStrat
userScopes' authStrat (Just (Entity _ u _)) = scopesFor u authStrat
hasScope' :: AuthorizationStrategy -> Scope -> Maybe User -> Bool
hasScope' authStrat s Nothing = Set.member s (unloggedScopes authStrat)
hasScope' authStrat s (Just (Entity _ u _)) = Set.member s (scopesFor u authStrat)
hasScope' authStrat s u = Set.member s (userScopes' authStrat u)

2
src/Aggreact/Comments/Server.hs
View file

@ -42,7 +42,7 @@ import Aggreact.Comments.Types
import Aggreact.Comments.Views
import Aggreact.Scopes (Scope (..))
import Aggreact.Servant.Errors
import Aggreact.User (User, UserHandler (..),
import Aggreact.Users (User, UserHandler (..),
UserId (..))
--------------------------------------------------------------------------------

2
src/Aggreact/Comments/StoreService.hs
View file

@ -43,7 +43,7 @@ import Protolude
--------------------------------------------------------------------------------
import Aggreact.Comments.Types
import qualified Aggreact.User as User
import qualified Aggreact.Users as User
--------------------------------------------------------------------------------
import Data.Time.Clock.Serialize ()

39
src/Aggreact/Comments/Types.hs
View file

@ -13,21 +13,21 @@
{-# LANGUAGE TypeSynonymInstances #-}
-- Common Pragmas (already stated in cabal file but repeated here for some tools)
{-# LANGUAGE BlockArguments #-} -- blabla do ... instead of blabla $ do ...
{-# LANGUAGE DeriveGeneric #-} -- deriving ToJSON ...
{-# LANGUAGE DerivingStrategies #-} -- remove warn about deriving strategies
{-# LANGUAGE ExplicitForAll #-} -- f :: forall a b. a -> b -> b
{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- newtype Id = Id Text deriving (StringConv Id String)
{-# LANGUAGE NamedWildCards #-} -- can use _type instead of just _
{-# LANGUAGE NoImplicitPrelude #-} -- to use protolude for example
{-# LANGUAGE NumericUnderscores #-} -- write 1_000 instead of 1000
{-# LANGUAGE OverloadedLists #-} -- write [1,2,3] :: Set
{-# LANGUAGE OverloadedStrings #-} -- write "foo" and it will be the correct text type
{-# LANGUAGE PartialTypeSignatures #-} -- write foo :: (_) => a -> Bool
{-# LANGUAGE RecordWildCards #-} -- f Conf{..} = field1 ...
{-# LANGUAGE ScopedTypeVariables #-} -- write expr :: Type inside an expression
{-# LANGUAGE StandaloneDeriving #-} -- write deriving instance ...
{-# LANGUAGE TupleSections #-} -- (a,,) instead of \x y -> (a,x,y)
{-# 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 #-}
{-# LANGUAGE TupleSections #-}
{- |
Module : Aggreact.Comments.StoreService
Description : CommentStore service
@ -52,7 +52,7 @@ where
import Protolude
import Aggreact.User (User,UserId)
import Aggreact.Users (User, UserId)
import qualified Control.Exception as Ex
import Data.Aeson (FromJSON (..), ToJSON (..),
@ -61,8 +61,8 @@ import Data.Aeson (FromJSON (..), ToJSON (..),
genericToJSON)
import Data.Char (isAlphaNum)
import Data.Data (Data (..))
import qualified Data.IxSet.Typed as IxSet
import Data.IxSet.OrphanInstances ()
import qualified Data.IxSet.Typed as IxSet
import qualified Data.Text as Text
import Data.Time.Clock.Serialize ()
import Data.Time.Format ()
@ -72,9 +72,10 @@ import qualified Data.UUID as UUID
import Database.SQLite.Simple (SQLData (..))
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.FromRow (FromRow (..), field)
import Database.SQLite.Simple.ToRow (ToRow (..))
import Database.SQLite.Simple.ToField (ToField (..))
import Database.Store (DefaultMetas (..), Entity (..), Id (..))
import Database.SQLite.Simple.ToRow (ToRow (..))
import Database.Store (DefaultMetas (..),
Entity (..), Id (..))
import Database.Store.Backend.SQLite as SQL
import qualified Generics.SOP as SOP
import qualified Web.FormUrlEncoded as Form

2
src/Aggreact/Comments/Views.hs
View file

@ -44,7 +44,7 @@ import Protolude
import Aggreact.Comments.Types
import Aggreact.Html (boilerplate, cvt, extlink,
urlEncode)
import Aggreact.User (NewUser (..), User, loginWidget)
import Aggreact.Users (NewUser (..), User, loginWidget)
--------------------------------------------------------------------------------
import Data.Aeson (ToJSON (..))

2
src/Aggreact/Homepage.hs
View file

@ -43,7 +43,7 @@ import Aggreact.Comments (Comment, CommentHandler (..),
Slug (..), displayOneComment)
import Aggreact.Css (genCss)
import Aggreact.Html (boilerplate, extlink, urlEncode)
import Aggreact.User (User, loginWidget)
import Aggreact.Users (User, loginWidget)
import Clay (Css)
import Data.String (IsString (..))
import qualified Data.Text as Text

18
src/Aggreact/Scopes.hs
View file

@ -40,11 +40,15 @@ module Aggreact.Scopes
( Scope (..)
, Scopes
, Access (..)
, displayScope
, displayScopes
)
where
import Data.Data (Data (..))
import qualified Data.Set as Set
import qualified Data.Text as Text
import Protolude
import Data.Data (Data (..))
data Scope = Scope { resource :: Text
@ -54,3 +58,15 @@ data Access = Read | Write
deriving (Eq, Ord, Data, Typeable, Generic, Show)
type Scopes = Set Scope
displayScopes :: Scopes -> Text
displayScopes scopes =
scopes &
Set.toList &
fmap displayScope &
Text.intercalate " "
displayScope :: Scope -> Text
displayScope Scope{..} = resource <> (case access of
Read -> ":read"
Write -> ":write")

2
src/Aggreact/Servant/Errors.hs
View file

@ -19,7 +19,7 @@
module Aggreact.Servant.Errors where
import Aggreact.Html (boilerplate)
import Aggreact.User (User, loginWidget)
import Aggreact.Users (User, loginWidget)
import Network.HTTP.Types (hContentType)
import Protolude

2
src/Aggreact/Slugs/Server.hs
View file

@ -42,7 +42,7 @@ import Aggreact.Servant.Errors
import Aggreact.Slugs.StoreService (SlugHandler (..))
import Aggreact.Slugs.Types
import Aggreact.Slugs.Views
import Aggreact.User (User, UserHandler (..),
import Aggreact.Users (User, UserHandler (..),
UserId (..))
--------------------------------------------------------------------------------

2
src/Aggreact/Slugs/Types.hs
View file

@ -52,7 +52,7 @@ where
import Protolude
import Aggreact.User (User,UserId)
import Aggreact.Users (User,UserId)
import Data.Aeson (FromJSON (..), ToJSON (..),
defaultOptions,

8
src/Aggreact/Slugs/Views.hs
View file

@ -44,7 +44,7 @@ import Protolude
import Aggreact.Slugs.Types
import Aggreact.Html (boilerplate, cvt, extlink,
urlEncode)
import Aggreact.User (NewUser (..), User, loginWidget)
import Aggreact.Users (NewUser (..), User, loginWidget)
--------------------------------------------------------------------------------
import Data.Aeson (ToJSON (..))
@ -89,9 +89,9 @@ displayOneSlug sl = do
data SlugPage =
SlugPage
{ spSlug :: Slug
, viewTime :: UTCTime
, muser :: Maybe User
{ spSlug :: Slug
, viewTime :: UTCTime
, muser :: Maybe User
, canCreateSlug :: Bool
}

428
src/Aggreact/User.hs
View file

@ -1,428 +0,0 @@
{-# 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.User
Description : User
Copyright : (c) 2018, Yann Esposito
License : ISC
Maintainer : yann.esposito@gmail.com
Stability : experimental
Portability : POSIX
Provide a Store abstraction.
-}
module Aggreact.User
where
import Protolude hiding (pass)
import Aggreact.Html (boilerplate, cvt, urlEncode)
import qualified Crypto.Scrypt as Crypt
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Data (Data (..))
import qualified Data.Text as Text
import qualified Data.UUID as UUID
import Database.SQLite.Simple (NamedParam (..),
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, SQLiteStore,
SearchQuery (Filter),
SearchResult (SR),
ToSQLiteFieldTypeList (..))
import qualified Database.Store.Backend.SQLite as SQL
import qualified Database.Store.CRUD as CRUD
import qualified Database.Store.Search as Search
import qualified Generics.SOP as SOP
import Servant
import Servant.Auth.Server (AuthResult (..),
FromJWT (..), ToJWT (..))
import Servant.Errors as Err
import Servant.HTML.Blaze (HTML)
import Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
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
-- * 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
-- * 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
-> 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)
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)