polysemy-account (empty) → 0.1.0.0

raw patch · 30 files changed

+1045/−0 lines, 30 filesdep +basedep +chronosdep +elocryptsetup-changed

Dependencies added: base, chronos, elocrypt, password, polysemy, polysemy-db, polysemy-plugin, prelate, random, sqel

Files

• LICENSE +34/−0
• Setup.hs +2/−0
• changelog.md +1/−0
• lib/Polysemy/Account.hs +88/−0
• lib/Polysemy/Account/Accounts.hs +46/−0
• lib/Polysemy/Account/Data/Account.hs +20/−0
• lib/Polysemy/Account/Data/AccountAuth.hs +21/−0
• lib/Polysemy/Account/Data/AccountAuthDescription.hs +11/−0
• lib/Polysemy/Account/Data/AccountByName.hs +13/−0
• lib/Polysemy/Account/Data/AccountCredentials.hs +17/−0
• lib/Polysemy/Account/Data/AccountName.hs +10/−0
• lib/Polysemy/Account/Data/AccountStatus.hs +19/−0
• lib/Polysemy/Account/Data/AccountsConfig.hs +36/−0
• lib/Polysemy/Account/Data/AccountsError.hs +28/−0
• lib/Polysemy/Account/Data/AuthForAccount.hs +7/−0
• lib/Polysemy/Account/Data/AuthToken.hs +9/−0
• lib/Polysemy/Account/Data/AuthedAccount.hs +22/−0
• lib/Polysemy/Account/Data/GeneratedPassword.hs +11/−0
• lib/Polysemy/Account/Data/HashedPassword.hs +10/−0
• lib/Polysemy/Account/Data/Port.hs +10/−0
• lib/Polysemy/Account/Data/Privilege.hs +18/−0
• lib/Polysemy/Account/Data/RawPassword.hs +19/−0
• lib/Polysemy/Account/Effect/Accounts.hs +56/−0
• lib/Polysemy/Account/Effect/Password.hs +17/−0
• lib/Polysemy/Account/Interpreter/AccountByName.hs +36/−0
• lib/Polysemy/Account/Interpreter/Accounts.hs +267/−0
• lib/Polysemy/Account/Interpreter/AuthForAccount.hs +35/−0
• lib/Polysemy/Account/Interpreter/Password.hs +43/−0
• polysemy-account.cabal +132/−0
• readme.md +7/−0

@@ -0,0 +1,34 @@+Copyright (c) 2023 Torsten Schmits++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the+following conditions are met:++  1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following+  disclaimer.+  2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following+  disclaimer in the documentation and/or other materials provided with the distribution.++Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those+receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except+for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired+or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by:++  (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of+  contributors, in source or binary form) alone; or+  (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such+  copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to+  be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution.++Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this+license, whether expressly, by implication, estoppel or otherwise.++DISCLAIMER++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,1 @@+# Unreleased

@@ -0,0 +1,88 @@+-- | Description: Account management with Servant and Polysemy+module Polysemy.Account (+  -- * Effects+  Accounts,+  authenticate,+  generatePassword,+  create,+  finalizeCreate,+  addPassword,+  setStatus,+  byId,+  byName,+  update,+  Polysemy.Account.Effect.Accounts.privileges,+  updatePrivileges,+  all,+  allAuths,++  Password,+  hash,+  check,+  generate,++  -- * Interpreters+  interpretAccounts,+  interpretAccountsState,++  interpretPassword,+  interpretPasswordId,++  -- * Misc combinators+  register,+  login,+  unlockAccountName,++  -- * Data types+  Account (..),+  AuthedAccount (..),+  AccountsConfig (..),+  AccountsError (..),+  AccountsClientError (..),+  AccountCredentials (..),+  AccountName (..),+  RawPassword,+  rawPassword,+  GeneratedPassword (..),+  AccountStatus (..),+  Privilege (..),+  AccountP,+  AuthedAccountP,+  AuthToken (..),+  Port (Port),+) where++import Prelude hiding (all)++import Polysemy.Account.Accounts (login, register, unlockAccountName)+import Polysemy.Account.Data.Account (Account (..), AccountP)+import Polysemy.Account.Data.AccountCredentials (AccountCredentials (..))+import Polysemy.Account.Data.AccountName (AccountName (..))+import Polysemy.Account.Data.AccountStatus (AccountStatus (..))+import Polysemy.Account.Data.AccountsConfig (AccountsConfig (..))+import Polysemy.Account.Data.AccountsError (AccountsClientError (..), AccountsError (..))+import Polysemy.Account.Data.AuthToken (AuthToken (..))+import Polysemy.Account.Data.AuthedAccount (AuthedAccount (..), AuthedAccountP)+import Polysemy.Account.Data.GeneratedPassword (GeneratedPassword (..))+import Polysemy.Account.Data.Port (Port (..))+import Polysemy.Account.Data.Privilege (Privilege (..))+import Polysemy.Account.Data.RawPassword (RawPassword (..), rawPassword)+import Polysemy.Account.Effect.Accounts (+  Accounts,+  addPassword,+  all,+  allAuths,+  authenticate,+  byId,+  byName,+  create,+  finalizeCreate,+  generatePassword,+  privileges,+  setStatus,+  update,+  updatePrivileges,+  )+import Polysemy.Account.Effect.Password (Password, check, generate, hash)+import Polysemy.Account.Interpreter.Accounts (interpretAccounts, interpretAccountsState)+import Polysemy.Account.Interpreter.Password (interpretPassword, interpretPasswordId)

@@ -0,0 +1,46 @@+-- | Description: Misc combinators+module Polysemy.Account.Accounts where++import Sqel (Uid (Uid))++import Polysemy.Account.Data.Account (Account (Account))+import Polysemy.Account.Data.AccountAuth (AccountAuth (AccountAuth))+import Polysemy.Account.Data.AccountCredentials (AccountCredentials (AccountCredentials))+import Polysemy.Account.Data.AccountName (AccountName)+import Polysemy.Account.Data.AccountStatus (AccountStatus (Active))+import Polysemy.Account.Data.AccountsError (AccountsError)+import Polysemy.Account.Data.AuthedAccount (AuthedAccount (AuthedAccount))+import qualified Polysemy.Account.Effect.Accounts as Accounts+import Polysemy.Account.Effect.Accounts (Accounts)++-- | Convenience function for unlocking the account matching the given name.+unlockAccountName ::+  Members [Accounts i p, Stop AccountsError] r =>+  AccountName ->+  Sem r ()+unlockAccountName name = do+  Uid i _ <- Accounts.byName name+  Accounts.setStatus i Active++-- | Authenticate the given credentials against the storage backend and return the matched account's information.+login ::+  Member (Accounts i p) r =>+  AccountCredentials ->+  Sem r (AuthedAccount i p)+login (AccountCredentials username password) = do+  Uid authId (AccountAuth accountId _ _ _) <- Accounts.authenticate username password+  Uid _ (Account name status privs) <- Accounts.byId accountId+  pure (AuthedAccount accountId authId name status privs)++-- | Register an account with the given credentials.+--+-- Create the account in the storage backend, hash the password and store it, then mark the account as created.+register ::+  Member (Accounts i p) r =>+  AccountCredentials ->+  Sem r (AuthedAccount i p)+register (AccountCredentials username password) = do+  Uid accountId _ <- Accounts.create username+  Uid authId (AccountAuth _ _ _ _) <- Accounts.addPassword accountId password Nothing+  Uid _ (Account name status privs) <- Accounts.finalizeCreate accountId+  pure (AuthedAccount accountId authId name status privs)

@@ -0,0 +1,20 @@+-- | Description: Account data type+module Polysemy.Account.Data.Account where++import Polysemy.Account.Data.AccountName (AccountName)+import Polysemy.Account.Data.AccountStatus (AccountStatus)+import Polysemy.Account.Data.Privilege (Privilege)++-- | A basic user account, consisting of a name, activation status, and an arbitrary privilege type.+data Account p =+  Account {+     name :: AccountName,+     status :: AccountStatus,+     privileges :: p+  }+  deriving stock (Eq, Show, Generic)++json ''Account++-- | Convenience alias for using the default privilege type with 'Account'.+type AccountP = Account [Privilege]

@@ -0,0 +1,21 @@+-- | Description: Account auth data type+module Polysemy.Account.Data.AccountAuth where++import Chronos (Datetime)++import Polysemy.Account.Data.AccountAuthDescription (AccountAuthDescription)+import Polysemy.Account.Data.HashedPassword (HashedPassword)++-- | A hashed password associated with an account.+data AccountAuth i =+  AccountAuth {+    -- | The account ID belonging to this password.+    account :: i,+    -- | A description of the password.+    description :: AccountAuthDescription,+    -- | A password hash.+    password :: HashedPassword,+    -- | The date at which the password expires.+    expiry :: Maybe Datetime+  }+  deriving stock (Eq, Show, Generic)

@@ -0,0 +1,11 @@+-- | Description: Account auth description data type+module Polysemy.Account.Data.AccountAuthDescription where++-- | A freeform text used to describe the nature of an 'Polysemy.Account.AccountAuth', like whether it's a generated or+-- user-supplied password.+newtype AccountAuthDescription =+  AccountAuthDescription { unAccountAuthDescription :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord)++json ''AccountAuthDescription

@@ -0,0 +1,13 @@+-- | Description: Account by name query data type+module Polysemy.Account.Data.AccountByName where++import Polysemy.Account.Data.AccountName (AccountName)++-- | Query payload for looking up accounts by name.+data AccountByName =+  AccountByName { name :: AccountName }+  deriving stock (Eq, Show, Generic, Ord)++instance IsString AccountByName where+  fromString =+    AccountByName . fromString

@@ -0,0 +1,17 @@+-- | Description: Account credentials data type+module Polysemy.Account.Data.AccountCredentials where++import Polysemy.Account.Data.AccountName (AccountName)+import Polysemy.Account.Data.RawPassword (RawPassword)++-- | User-supplied credentials for login or registration.+data AccountCredentials =+  AccountCredentials {+    -- | Account name.+    username :: AccountName,+    -- | Account password.+    password :: RawPassword+  }+  deriving stock (Eq, Show)++json ''AccountCredentials

@@ -0,0 +1,10 @@+-- | Description: Account name data type+module Polysemy.Account.Data.AccountName where++-- | The name of an account.+newtype AccountName =+  AccountName { unAccountName :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord)++json ''AccountName

@@ -0,0 +1,19 @@+-- | Description: Account status data type+module Polysemy.Account.Data.AccountStatus where++-- | Basic account status.+data AccountStatus =+  -- | The account was added to storage, but not processed fully.+  Creating+  |+  -- | The account was fully created, but not approved by an admin.+  Pending+  |+  -- | The account is fully operational.+  Active+  |+  -- | An admin has disabled the account.+  Locked+  deriving stock (Eq, Show, Generic)++json ''AccountStatus

@@ -0,0 +1,36 @@+{-# language NoFieldSelectors #-}++-- | Description: Config data type for the effect 'Polysemy.Account.Accounts'.+module Polysemy.Account.Data.AccountsConfig where++import Polysemy.Account.Data.Privilege (Privilege)++-- | The configuration for the interpreter for 'Polysemy.Account.Accounts'.+--+-- The defaults, when using 'Privilege', are:+--+-- - Length 20+-- - Don't activate accounts right away+-- - 'Polysemy.Account.Web' privileges+data AccountsConfig p =+  AccountsConfig {+    -- | Length of generated passwords.+    passwordLength :: Word,+    -- | Whether new accounts should immediately be marked as active rather than pending, allowing login.+    initActive :: Bool,+    -- | The privileges assigned to a new account.+    defaultPrivileges :: p+  }+  deriving stock (Eq, Show, Generic)++json ''AccountsConfig++-- | Convenience alias for using the default privilege type with 'AccountsConfig'.+type AccountsConfigP = AccountsConfig [Privilege]++instance Default p => Default (AccountsConfig p) where+  def = AccountsConfig {+    passwordLength = 20,+    initActive = False,+    defaultPrivileges = def+  }

@@ -0,0 +1,28 @@+-- | Description: Error data types for the effect 'Polysemy.Account.Accounts'.+module Polysemy.Account.Data.AccountsError where++-- | Errors that indicate invalid client-supplied information.+data AccountsClientError =+  -- | No account was found for the given ID.+  NoAccountId+  |+  -- | Credentials did not match stored auth data.+  InvalidAuth+  |+  -- | No account was found for the given name.+  NoAccountName+  |+  -- | Name given for registration already exists in storage.+  Conflict+  deriving stock (Eq, Show)++json ''AccountsClientError++-- | Errors produced by the effect 'Polysemy.Account.Accounts'.+data AccountsError =+  -- | Errors that indicate invalid client-supplied information.+  Client AccountsClientError+  |+  -- | Error indicating storage backend failure.+  Internal Text+  deriving stock (Eq, Show)

@@ -0,0 +1,7 @@+-- | Description: Account by name query data type+module Polysemy.Account.Data.AuthForAccount where++-- | Query payload for looking up auth info by account ID.+data AuthForAccount i =+  AuthForAccount { account :: i }+  deriving stock (Eq, Show, Generic, Ord)

@@ -0,0 +1,9 @@+-- | Description: Auth token data type+module Polysemy.Account.Data.AuthToken where++-- | An auth token, used by the JWT tools in @polysemy-account-api@.+newtype AuthToken =+  AuthToken { unAuthToken :: Text }+  deriving stock (Eq, Show)++json ''AuthToken

@@ -0,0 +1,22 @@+-- | Description: Authed account data type+module Polysemy.Account.Data.AuthedAccount where++import Polysemy.Account.Data.AccountName (AccountName)+import Polysemy.Account.Data.AccountStatus (AccountStatus)+import Polysemy.Account.Data.Privilege (Privilege)++-- | An account an the ID of the password used to authenticate it.+data AuthedAccount i p =+  AuthedAccount {+    id :: i,+    authId :: i,+    name :: AccountName,+    status :: AccountStatus,+    privileges :: p+  }+  deriving stock (Eq, Show, Generic)++json ''AuthedAccount++-- | Convenience alias for using the default privilege type with 'AuthedAccount'.+type AuthedAccountP i = AuthedAccount i [Privilege]

@@ -0,0 +1,11 @@+-- | Description: Generated password data type+module Polysemy.Account.Data.GeneratedPassword where++-- | A password that was generated, intended to be shown to the user, and therefore permitted to be 'show'n, as opposed+-- to 'Polysemy.Account.RawPassword'.+newtype GeneratedPassword =+  GeneratedPassword { unGeneratedPassword :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord)++json ''GeneratedPassword

@@ -0,0 +1,10 @@+-- | Description: Hasned password data type+module Polysemy.Account.Data.HashedPassword where++-- | An internally used type containing a hash produced by "Data.Password".+newtype HashedPassword =+  HashedPassword { unAccountPassword :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord)++json ''HashedPassword

@@ -0,0 +1,10 @@+-- | Description: Port data type+module Polysemy.Account.Data.Port where++-- | An API port, used by the Servant tools in @polysemy-account-api@.+newtype Port =+  Port { unPort :: Word }+  deriving stock (Eq, Show)+  deriving newtype (Num, Ord, Enum, Real, Integral, Read)++json ''Port

@@ -0,0 +1,18 @@+{-# options_haddock prune #-}++-- | Description: Privilege data type+module Polysemy.Account.Data.Privilege where++-- | The stock privilege type, used only for admin endpoint authorization in @polysemy-account-api@.+data Privilege =+  Web+  |+  Api+  |+  Admin+  deriving stock (Eq, Show, Generic)++json ''Privilege++instance {-# overlapping #-} Default [Privilege] where+  def = [Web]

@@ -0,0 +1,19 @@+-- | Description: Raw password data type+module Polysemy.Account.Data.RawPassword where++import qualified Text.Show as Show++-- | A clear text password, supplied by the user or generated.+newtype RawPassword =+  UnsafeRawPassword { unRawPassword :: Text }+  deriving stock (Eq)++instance Show RawPassword where+  show _ =+    "--> raw password <--"++json ''RawPassword++-- | Construct a ''RawPassword'.+rawPassword :: Text -> RawPassword+rawPassword = UnsafeRawPassword

@@ -0,0 +1,56 @@+-- | Description: Accounts effect+module Polysemy.Account.Effect.Accounts where++import Chronos (Datetime)+import Prelude hiding (all)+import Sqel (Uid)++import Polysemy.Account.Data.Account (Account)+import Polysemy.Account.Data.AccountAuth (AccountAuth)+import Polysemy.Account.Data.AccountName (AccountName)+import Polysemy.Account.Data.AccountStatus (AccountStatus)+import Polysemy.Account.Data.AuthedAccount (AuthedAccount)+import Polysemy.Account.Data.GeneratedPassword (GeneratedPassword)+import Polysemy.Account.Data.Privilege (Privilege)+import Polysemy.Account.Data.RawPassword (RawPassword)++-- | This effect provides common operations for account and password management.+--+-- The first parameter is the ID type for both accounts and authentication data, which might be 'Data.UUID.UUID' or+-- @Int@.+--+-- The second parameter encodes an accounts basic privileges, mainly used for API authorization.+data Accounts i p :: Effect where+  -- | Check credentials against the storage backend.+  Authenticate :: AccountName -> RawPassword -> Accounts i p m (Uid i (AccountAuth i))+  -- | Generate a fresh password.+  GeneratePassword :: i -> Maybe Datetime -> Accounts i p m GeneratedPassword+  -- | Add an account to the storage backend, without authentication.+  Create :: AccountName -> Accounts i p m (Uid i (Account p))+  -- | Mark an account as fully created.+  FinalizeCreate :: i -> Accounts i p m (Uid i (Account p))+  -- | Associate an account with a new password, with optional expiry time.+  AddPassword :: i -> RawPassword -> Maybe Datetime -> Accounts i p m (Uid i (AccountAuth i))+  -- | Update the status of an account.+  SetStatus :: i -> AccountStatus -> Accounts i p m ()+  -- | Look up an account by its ID.+  ById :: i -> Accounts i p m (Uid i (Account p))+  -- | Look up an account by its name.+  ByName :: AccountName -> Accounts i p m (Uid i (Account p))+  -- | Look up an account and return its auth info.+  Authed :: i -> Accounts i p m (AuthedAccount i p)+  -- | Overwrite an existing account.+  Update :: Uid i (Account p) -> Accounts i p m ()+  -- | Look up an account's privileges.+  Privileges :: i -> Accounts i p m p+  -- | Update an account's privileges.+  UpdatePrivileges :: i -> (p -> p) -> Accounts i p m ()+  -- | Fetch all accounts.+  All :: Accounts i p m [Uid i (Account p)]+  -- | Fetch all auth records.+  AllAuths :: Accounts i p m [Uid i (AccountAuth i)]++makeSem ''Accounts++-- | Convenience alias for 'Accounts' using the default 'Privilege' type.+type AccountsP i = Accounts i [Privilege]

@@ -0,0 +1,17 @@+-- | Description: Password effect+module Polysemy.Account.Effect.Password where++import Polysemy.Account.Data.GeneratedPassword (GeneratedPassword)+import Polysemy.Account.Data.HashedPassword (HashedPassword)+import Polysemy.Account.Data.RawPassword (RawPassword)++-- | This effect provides password hashing, validation, and generation.+data Password :: Effect where+  -- | Hash a clear text password.+  Hash :: RawPassword -> Password m HashedPassword+  -- | Validate a password against a hash.+  Check :: RawPassword -> HashedPassword -> Password m Bool+  -- | Generate a new clear text password of the specified length.+  Generate :: Word -> Password m GeneratedPassword++makeSem ''Password

@@ -0,0 +1,36 @@+{-# options_haddock prune #-}++-- | Description: Interpreter for the query for an account by name+module Polysemy.Account.Interpreter.AccountByName where++import Polysemy.Db (DbError, PureStore, Query, Store, interpretQueryStoreConc)+import Sqel (Uid (Uid))++import Polysemy.Account.Data.Account (Account (Account))+import Polysemy.Account.Data.AccountByName (AccountByName (AccountByName))++match ::+  AccountByName ->+  Uid i (Account p) ->+  Maybe (Uid i (Account p))+match (AccountByName name) a@(Uid _ (Account accountName _ _))+  | name == accountName = Just a+  | otherwise = Nothing++type AccountQuery i p =+  [+    Query AccountByName (Maybe (Uid i (Account p))) !! DbError,+    Store i (Account p) !! DbError,+    AtomicState (PureStore i (Account p))+  ]++-- | Interpret @'Query' 'AccountByName'@ and the corresponding 'Store' in an 'AtomicState'.+interpretAccountByNameState ::+  ∀ i p r .+  Ord i =>+  Show i =>+  Member (Embed IO) r =>+  [Uid i (Account p)] ->+  InterpretersFor (AccountQuery i p) r+interpretAccountByNameState initial =+  interpretQueryStoreConc match initial

@@ -0,0 +1,267 @@+{-# options_haddock prune #-}++-- | Description: Interpreters for 'Accounts' and 'Password'+module Polysemy.Account.Interpreter.Accounts where++import Chronos (Datetime)+import Polysemy.Db (Id, Query, Store, newId)+import qualified Polysemy.Db.Effect.Query as Query+import qualified Polysemy.Db.Effect.Store as Store+import Sqel (Uid (Uid))++import Polysemy.Account.Data.Account (Account (Account))+import Polysemy.Account.Data.AccountAuth (AccountAuth (AccountAuth))+import Polysemy.Account.Data.AccountAuthDescription (AccountAuthDescription)+import Polysemy.Account.Data.AccountByName (AccountByName (AccountByName))+import Polysemy.Account.Data.AccountName (AccountName)+import qualified Polysemy.Account.Data.AccountStatus as AccountStatus+import Polysemy.Account.Data.AccountStatus (AccountStatus)+import qualified Polysemy.Account.Data.AccountsConfig as AccountsConfig+import Polysemy.Account.Data.AccountsConfig (AccountsConfig (AccountsConfig))+import Polysemy.Account.Data.AccountsError (+  AccountsClientError (Conflict, InvalidAuth, NoAccountId, NoAccountName),+  AccountsError (Client, Internal),+  )+import Polysemy.Account.Data.AuthForAccount (AuthForAccount (AuthForAccount))+import Polysemy.Account.Data.AuthedAccount (AuthedAccount (AuthedAccount))+import Polysemy.Account.Data.GeneratedPassword (GeneratedPassword (GeneratedPassword))+import Polysemy.Account.Data.RawPassword (RawPassword (UnsafeRawPassword))+import Polysemy.Account.Effect.Accounts (Accounts (..))+import qualified Polysemy.Account.Effect.Password as Password+import Polysemy.Account.Effect.Password (Password)+import Polysemy.Account.Interpreter.AccountByName (interpretAccountByNameState)+import Polysemy.Account.Interpreter.AuthForAccount (interpretAuthForAccountState)+import Polysemy.Account.Interpreter.Password (interpretPasswordId)++dbError ::+  ∀ eff e r .+  Show e =>+  Members [eff !! e, Stop AccountsError] r =>+  InterpreterFor eff r+dbError =+  resumeHoist (Internal . show)++storeError ::+  ∀ a e i r .+  Show e =>+  Members [Store i a !! e, Stop AccountsError] r =>+  InterpreterFor (Store i a) r+storeError =+  resumeHoist (Internal . show)++queryError ::+  ∀ a q e r .+  Show e =>+  Members [Query q a !! e, Stop AccountsError] r =>+  InterpreterFor (Query q a) r+queryError =+  resumeHoist (Internal . show)++config ::+  Show e =>+  Members [Reader (AccountsConfig p) !! e, Stop AccountsError] r =>+  Sem r (AccountsConfig p)+config =+  dbError ask++byId ::+  ∀ i r a .+  Members [Store i a, Stop AccountsError] r =>+  i ->+  Sem r (Uid i a)+byId accountId =+  stopNote (Client NoAccountId) =<< Store.fetch accountId++byName ::+  ∀ i r a .+  Members [Query AccountByName (Maybe (Uid i a)), Stop AccountsError] r =>+  AccountName ->+  Sem r (Uid i a)+byName name =+  stopNote (Client NoAccountName) =<< Query.query (AccountByName name)++authedAccount ::+  ∀ i p r .+  Members [Store i (Account p), Store i (AccountAuth i), Stop AccountsError] r =>+  i ->+  Sem r (AuthedAccount i p)+authedAccount authId = do+  aa <- Store.fetch authId+  Uid _ (AccountAuth accountId _ _ _) <- stopNote (Client InvalidAuth) aa+  Uid _ (Account name status privs) <- byId accountId+  pure (AuthedAccount accountId authId name status privs)++-- TODO see if Query for AccountAuth can be used without Uid, extracting it in the interpreter+authenticate ::+  Show e =>+  Member (Query AccountByName (Maybe (Uid i a)) !! e) r =>+  Member (Query (AuthForAccount i) [Uid i (AccountAuth i)] !! e) r =>+  Members [Stop AccountsError, Password] r =>+  AccountName ->+  RawPassword ->+  Sem r (Uid i (AccountAuth i))+authenticate name password = do+  Uid id' _ <- notFound =<< queryError (Query.query (AccountByName name))+  auths <- queryError (Query.query (AuthForAccount id'))+  invalid =<< findM check auths+  where+    notFound =+      stopNote (Client NoAccountName)+    check (Uid _ (AccountAuth _ _ hash _)) =+      Password.check password hash+    invalid =+      stopNote (Client InvalidAuth)++privileges ::+  ∀ i p r .+  Members [Store i (Account p), Stop AccountsError] r =>+  i ->+  Sem r p+privileges i =+  Store.fetch i >>= \case+    Just (Uid _ (Account _ _ privs)) -> pure privs+    Nothing -> stop (Client NoAccountId)++addPassword ::+  Members [Password, Store i (AccountAuth i), Id i, Stop AccountsError] r =>+  AccountAuthDescription ->+  i ->+  RawPassword ->+  Maybe Datetime ->+  Sem r (Uid i (AccountAuth i))+addPassword desc accountId password expiry = do+  hashedPassword <- Password.hash password+  authId <- newId+  let auth = Uid authId (AccountAuth accountId desc hashedPassword expiry)+  auth <$ Store.insert auth++generatePassword ::+  Show e =>+  Members [Password, Store i (AccountAuth i), Reader (AccountsConfig p) !! e, Id i, Stop AccountsError] r =>+  i ->+  Maybe Datetime ->+  Sem r GeneratedPassword+generatePassword accountId expiry = do+  AccountsConfig {..} <- config+  pw@(GeneratedPassword raw) <- Password.generate passwordLength+  coerce pw <$ addPassword "auth token" accountId (UnsafeRawPassword raw) expiry++-- | Fail if the account name is already present in the store.+-- If the account status is `Creating', however, a previous attempt has failed critically and the account can be+-- overwritten.+deletePreviousFailure ::+  Members [Store i (Account p), Stop AccountsError] r =>+  Uid i (Account p) ->+  Sem r ()+deletePreviousFailure (Uid i (Account _ AccountStatus.Creating _)) =+  void (Store.delete i)+deletePreviousFailure _ =+  stop (Client Conflict)++create ::+  ∀ i p e r .+  Members [Store i (Account p), Query AccountByName (Maybe (Uid i (Account p))), Reader (AccountsConfig p) !! e] r =>+  Members [Id i, Stop AccountsError] r =>+  AccountName ->+  p ->+  Sem r (Uid i (Account p))+create name privs = do+  traverse_ deletePreviousFailure =<< Query.query (AccountByName name)+  accountId <- newId+  let account = Uid accountId (Account name AccountStatus.Creating privs)+  account <$ Store.upsert account++finishCreate ::+  ∀ i p r .+  Members [Store i (Account p), Stop AccountsError] r =>+  Bool ->+  i ->+  Sem r (Uid i (Account p))+finishCreate active accountId = do+  account :: Uid i (Account p) <- stopNote (Internal "Account absent after password creation") =<< Store.fetch accountId+  let updatedAccount = account & #payload . #status .~ status+  updatedAccount <$ Store.upsert (account & #payload . #status .~ status)+  where+    status = if active then AccountStatus.Active else AccountStatus.Pending++setStatus ::+  Members [Store i (Account p), Stop AccountsError] r =>+  i ->+  AccountStatus ->+  Sem r ()+setStatus accountId status = do+  account <- stopNote (Client NoAccountId) =<< Store.fetch accountId+  Store.upsert (account & #payload . #status .~ status)++updatePrivileges ::+  ∀ i p e r .+  Show e =>+  Members [Store i (Account p) !! e, Stop AccountsError] r =>+  i ->+  (p -> p) ->+  Sem r ()+updatePrivileges i f =+  dbError (Store.fetch i) >>= \case+    Just account ->+      dbError (Store.upsert (account & #payload . #privileges %~ f))+    Nothing ->+      stop (Client NoAccountId)++-- | Interpret 'Accounts' using 'Store' and 'Query' from [Polysemy.Db]("Polysemy.Db") as the storage backend.+interpretAccounts ::+  ∀ e i p r .+  Show e =>+  Member (Query AccountByName (Maybe (Uid i (Account p))) !! e) r =>+  Member (Query (AuthForAccount i) [Uid i (AccountAuth i)] !! e) r =>+  Members [Password, Store i (Account p) !! e, Store i (AccountAuth i) !! e, Reader (AccountsConfig p) !! e, Id i] r =>+  InterpreterFor (Accounts i p !! AccountsError) r+interpretAccounts =+  interpretResumable \case+    Authenticate name password ->+      authenticate name password+    GeneratePassword accountId expiry ->+      storeError (generatePassword accountId expiry)+    Create name -> do+      AccountsConfig {..} <- config+      queryError (storeError (create name defaultPrivileges))+    FinalizeCreate accountId -> do+      AccountsConfig {..} <- config+      storeError (finishCreate initActive accountId)+    AddPassword accountId password expiry ->+      storeError (addPassword "user login" accountId password expiry)+    SetStatus accountId status ->+      storeError (setStatus accountId status)+    ById accountId ->+      storeError (byId accountId)+    ByName name ->+      queryError (byName name)+    Authed authId ->+      storeError (storeError @(Account _) (authedAccount authId))+    Update account ->+      storeError (Store.upsert account)+    Privileges i ->+      storeError (privileges i)+    UpdatePrivileges i f ->+      updatePrivileges i f+    All ->+      storeError Store.fetchAll+    AllAuths ->+      storeError Store.fetchAll++-- | Interpret 'Accounts' and 'Password' using 'AtomicState' as storage backend.+interpretAccountsState ::+  ∀ i p r .+  Ord i =>+  Show i =>+  Members [Log, Id i, Embed IO] r =>+  AccountsConfig p ->+  [Uid i (Account p)] ->+  [Uid i (AccountAuth i)] ->+  InterpretersFor [Accounts i p !! AccountsError, Password] r+interpretAccountsState conf accounts auths =+  interpretPasswordId .+  raiseResumable (runReader conf) .+  interpretAccountByNameState accounts .+  interpretAuthForAccountState auths .+  interpretAccounts .+  insertAt @1

@@ -0,0 +1,35 @@+-- | Description: Interpreter for the query for auth info by account ID+module Polysemy.Account.Interpreter.AuthForAccount where++import Polysemy.Db (DbError, PureStore, Query, Store, interpretQueryStoreConc)+import Sqel (Uid (Uid))++import Polysemy.Account.Data.AccountAuth (AccountAuth (AccountAuth))+import Polysemy.Account.Data.AuthForAccount (AuthForAccount (AuthForAccount))++match ::+  Eq i =>+  AuthForAccount i ->+  Uid i (AccountAuth i) ->+  Maybe (Uid i (AccountAuth i))+match (AuthForAccount queryId) a@(Uid _ (AccountAuth accountId _ _ _))+  | queryId == accountId = Just a+  | otherwise = Nothing++type AuthQuery i p =+  [+    Query (AuthForAccount i) [Uid i (AccountAuth i)] !! DbError,+    Store i (AccountAuth i) !! DbError,+    AtomicState (PureStore i (AccountAuth i))+  ]++-- | Interpret @'Query' 'AccountAuth'@ and the corresponding 'Store' in an 'AtomicState'.+interpretAuthForAccountState ::+  ∀ i r p .+  Ord i =>+  Show i =>+  Member (Embed IO) r =>+  [Uid i (AccountAuth i)] ->+  InterpretersFor (AuthQuery i p) r+interpretAuthForAccountState initial =+  interpretQueryStoreConc match initial

@@ -0,0 +1,43 @@+-- | Description: Interpreters for 'Password'+module Polysemy.Account.Interpreter.Password where++import Data.Elocrypt (genOptions, genPassword)+import Data.Password.Argon2 (+  PasswordCheck (PasswordCheckSuccess),+  PasswordHash (PasswordHash),+  checkPassword,+  hashPassword,+  mkPassword,+  )+import qualified Data.Text as Text+import System.Random (getStdGen)++import Polysemy.Account.Data.GeneratedPassword (GeneratedPassword (GeneratedPassword))+import Polysemy.Account.Data.HashedPassword (HashedPassword (HashedPassword))+import Polysemy.Account.Data.RawPassword (RawPassword (UnsafeRawPassword))+import Polysemy.Account.Effect.Password (Password (..))++-- | Interpret 'Password' trivially, not performing any hashing and generating sequences of asterisks.+interpretPasswordId ::+  InterpreterFor Password r+interpretPasswordId =+  interpret \case+    Hash (UnsafeRawPassword pw) ->+      pure (HashedPassword pw)+    Check (UnsafeRawPassword pw) (HashedPassword apw) ->+      pure (pw == apw)+    Generate len ->+      pure (GeneratedPassword (Text.replicate (fromIntegral len) "*"))++-- | Interpret 'Password' using the Argon2 algorithm and "Data.Elocrypt"-generated passwords.+interpretPassword ::+  Member (Embed IO) r =>+  InterpreterFor Password r+interpretPassword =+  interpret \case+    Hash (UnsafeRawPassword pw) ->+      coerce <$> hashPassword (mkPassword pw)+    Check (UnsafeRawPassword pw) (HashedPassword apw) ->+      pure (PasswordCheckSuccess == checkPassword (mkPassword pw) (PasswordHash apw))+    Generate len ->+      GeneratedPassword . toText . fst . genPassword (fromIntegral len) genOptions <$> embed getStdGen

@@ -0,0 +1,132 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.35.0.+--+-- see: https://github.com/sol/hpack++name:           polysemy-account+version:        0.1.0.0+synopsis:       Account management with Servant and Polysemy+description:    See https://hackage.haskell.org/package/polysemy-account/docs/Polysemy-Account.html+category:       Web+author:         Torsten Schmits+maintainer:     hackage@tryp.io+copyright:      2023 Torsten Schmits+license:        BSD-2-Clause-Patent+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    changelog.md+    readme.md++library+  exposed-modules:+      Polysemy.Account+      Polysemy.Account.Accounts+      Polysemy.Account.Data.Account+      Polysemy.Account.Data.AccountAuth+      Polysemy.Account.Data.AccountAuthDescription+      Polysemy.Account.Data.AccountByName+      Polysemy.Account.Data.AccountCredentials+      Polysemy.Account.Data.AccountName+      Polysemy.Account.Data.AccountsConfig+      Polysemy.Account.Data.AccountsError+      Polysemy.Account.Data.AccountStatus+      Polysemy.Account.Data.AuthedAccount+      Polysemy.Account.Data.AuthForAccount+      Polysemy.Account.Data.AuthToken+      Polysemy.Account.Data.GeneratedPassword+      Polysemy.Account.Data.HashedPassword+      Polysemy.Account.Data.Port+      Polysemy.Account.Data.Privilege+      Polysemy.Account.Data.RawPassword+      Polysemy.Account.Effect.Accounts+      Polysemy.Account.Effect.Password+      Polysemy.Account.Interpreter.AccountByName+      Polysemy.Account.Interpreter.Accounts+      Polysemy.Account.Interpreter.AuthForAccount+      Polysemy.Account.Interpreter.Password+  hs-source-dirs:+      lib+  default-extensions:+      StandaloneKindSignatures+      OverloadedRecordDot+      NoFieldSelectors+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyCase+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedLabels+      OverloadedLists+      OverloadedStrings+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      RoleAnnotations+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -fplugin=Polysemy.Plugin+  build-depends:+      base >=4.12 && <5+    , chronos+    , elocrypt+    , password ==3.0.*+    , polysemy+    , polysemy-db+    , polysemy-plugin+    , prelate >=0.5+    , random+    , sqel+  mixins:+      base hiding (Prelude)+    , prelate (Prelate as Prelude)+    , prelate hiding (Prelate)+  default-language: Haskell2010

@@ -0,0 +1,7 @@+# About++This is a Haskell library for [Polysemy](https://hackage.haskell.org/package/polysemy) that provides effects for+managing accounts with Argon2-hashed password authentication.++Consult the [Haddocks](https://hackage.haskell.org/package/polysemy-account/docs/Polysemy-Account.html) for more+documentation.