From 61f0bb5ee7e93252ba0c65396752a65fda058796 Mon Sep 17 00:00:00 2001 From: "Yann Esposito (Yogsototh)" Date: Sun, 14 Apr 2019 16:44:37 +0200 Subject: [PATCH] Refacto --- aggreact.cabal | 8 +- src/Aggreact.hs | 2 +- src/Aggreact/Auth.hs | 4 +- src/Aggreact/Authorization.hs | 23 +- src/Aggreact/Comments/Server.hs | 2 +- src/Aggreact/Comments/StoreService.hs | 2 +- src/Aggreact/Comments/Types.hs | 39 +-- src/Aggreact/Comments/Views.hs | 2 +- src/Aggreact/Homepage.hs | 2 +- src/Aggreact/Scopes.hs | 18 +- src/Aggreact/Servant/Errors.hs | 2 +- src/Aggreact/Slugs/Server.hs | 2 +- src/Aggreact/Slugs/Types.hs | 2 +- src/Aggreact/Slugs/Views.hs | 8 +- src/Aggreact/User.hs | 428 -------------------------- 15 files changed, 73 insertions(+), 471 deletions(-) delete mode 100644 src/Aggreact/User.hs diff --git a/aggreact.cabal b/aggreact.cabal index 459dd02..e780bcc 100644 --- a/aggreact.cabal +++ b/aggreact.cabal @@ -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 diff --git a/src/Aggreact.hs b/src/Aggreact.hs index 3a70146..8dd3422 100644 --- a/src/Aggreact.hs +++ b/src/Aggreact.hs @@ -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) diff --git a/src/Aggreact/Auth.hs b/src/Aggreact/Auth.hs index f78b11c..56c001a 100644 --- a/src/Aggreact/Auth.hs +++ b/src/Aggreact/Auth.hs @@ -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 } diff --git a/src/Aggreact/Authorization.hs b/src/Aggreact/Authorization.hs index 0655d84..9a48bb5 100644 --- a/src/Aggreact/Authorization.hs +++ b/src/Aggreact/Authorization.hs @@ -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) diff --git a/src/Aggreact/Comments/Server.hs b/src/Aggreact/Comments/Server.hs index 091c0c5..3f9eb9a 100644 --- a/src/Aggreact/Comments/Server.hs +++ b/src/Aggreact/Comments/Server.hs @@ -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 (..)) -------------------------------------------------------------------------------- diff --git a/src/Aggreact/Comments/StoreService.hs b/src/Aggreact/Comments/StoreService.hs index c0ba9a4..9adbc30 100644 --- a/src/Aggreact/Comments/StoreService.hs +++ b/src/Aggreact/Comments/StoreService.hs @@ -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 () diff --git a/src/Aggreact/Comments/Types.hs b/src/Aggreact/Comments/Types.hs index cb8947c..cc3c97d 100644 --- a/src/Aggreact/Comments/Types.hs +++ b/src/Aggreact/Comments/Types.hs @@ -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 diff --git a/src/Aggreact/Comments/Views.hs b/src/Aggreact/Comments/Views.hs index 50437cf..0ca4fde 100644 --- a/src/Aggreact/Comments/Views.hs +++ b/src/Aggreact/Comments/Views.hs @@ -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 (..)) diff --git a/src/Aggreact/Homepage.hs b/src/Aggreact/Homepage.hs index 07958bf..d4d9e00 100644 --- a/src/Aggreact/Homepage.hs +++ b/src/Aggreact/Homepage.hs @@ -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 diff --git a/src/Aggreact/Scopes.hs b/src/Aggreact/Scopes.hs index b21a7c7..b612f0f 100644 --- a/src/Aggreact/Scopes.hs +++ b/src/Aggreact/Scopes.hs @@ -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") diff --git a/src/Aggreact/Servant/Errors.hs b/src/Aggreact/Servant/Errors.hs index e23e42f..323441c 100644 --- a/src/Aggreact/Servant/Errors.hs +++ b/src/Aggreact/Servant/Errors.hs @@ -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 diff --git a/src/Aggreact/Slugs/Server.hs b/src/Aggreact/Slugs/Server.hs index 957d89b..4048c82 100644 --- a/src/Aggreact/Slugs/Server.hs +++ b/src/Aggreact/Slugs/Server.hs @@ -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 (..)) -------------------------------------------------------------------------------- diff --git a/src/Aggreact/Slugs/Types.hs b/src/Aggreact/Slugs/Types.hs index 7ccf808..75bdd68 100644 --- a/src/Aggreact/Slugs/Types.hs +++ b/src/Aggreact/Slugs/Types.hs @@ -52,7 +52,7 @@ where import Protolude -import Aggreact.User (User,UserId) +import Aggreact.Users (User,UserId) import Data.Aeson (FromJSON (..), ToJSON (..), defaultOptions, diff --git a/src/Aggreact/Slugs/Views.hs b/src/Aggreact/Slugs/Views.hs index 28ddd6b..9ba0007 100644 --- a/src/Aggreact/Slugs/Views.hs +++ b/src/Aggreact/Slugs/Views.hs @@ -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 } diff --git a/src/Aggreact/User.hs b/src/Aggreact/User.hs deleted file mode 100644 index 6ab90c2..0000000 --- a/src/Aggreact/User.hs +++ /dev/null @@ -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)