diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015 Alexander Thiemann +Copyright (c) 2015 - 2016 Alexander Thiemann Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/src/Web/Users/Types.hs b/src/Web/Users/Types.hs --- a/src/Web/Users/Types.hs +++ b/src/Web/Users/Types.hs @@ -3,17 +3,21 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} module Web.Users.Types ( -- * The core type class UserStorageBackend (..) -- * User representation , User(..), Password(..), makePassword, hidePassword , PasswordPlain(..), verifyPassword + , UserField(..) -- * Token types , PasswordResetToken(..), ActivationToken(..), SessionId(..) -- * Error types , CreateUserError(..), UpdateUserError(..) , TokenError(..) + -- * Helper typed + , SortBy(..) ) where @@ -29,26 +33,18 @@ import qualified Data.Text.Encoding as T import qualified System.IO.Unsafe as U -{-# DEPRECATED UsernameOrEmailAlreadyTaken "Please use the more specific error constructors." #-} - -- | Errors that happen on storage level during user creation data CreateUserError - = UsernameOrEmailAlreadyTaken - | InvalidPassword + = InvalidPassword | UsernameAlreadyTaken | EmailAlreadyTaken | UsernameAndEmailAlreadyTaken deriving (Show, Eq) -{-# DEPRECATED UsernameOrEmailAlreadyExists "Please use the more descriptive constructors instead." #-} -{-# DEPRECATED UserDoesntExit "Please use UserDoesntExist instead." #-} - -- | Errors that happen on storage level during user updating data UpdateUserError - = UsernameOrEmailAlreadyExists - | UsernameAlreadyExists + = UsernameAlreadyExists | EmailAlreadyExists - | UserDoesntExit | UserDoesntExist deriving (Show, Eq) @@ -57,12 +53,28 @@ = TokenInvalid deriving (Show, Eq) +-- | Sorting direction +data SortBy t + = SortAsc t + | SortDesc t + +-- | Backend constraints +type IsUserBackend b = + ( Show (UserId b) + , Eq (UserId b) + , ToJSON (UserId b) + , FromJSON (UserId b) + , Typeable (UserId b) + , PathPiece (UserId b) + ) + -- | An abstract backend for managing users. A backend library should implement the interface and -- an end user should build applications on top of this interface. -class (Show (UserId b), Eq (UserId b), ToJSON (UserId b), FromJSON (UserId b), Typeable (UserId b), PathPiece (UserId b)) => UserStorageBackend b where +class IsUserBackend b => UserStorageBackend b where -- | The storage backends userid type UserId b :: * - -- | Initialise the backend. Call once on application launch to for example create missing database tables + -- | Initialise the backend. Call once on application launch to for + -- example create missing database tables initUserBackend :: b -> IO () -- | Destory the backend. WARNING: This is only for testing! It deletes all tables and data. destroyUserBackend :: b -> IO () @@ -71,31 +83,21 @@ -- | Retrieve a user id from the database getUserIdByName :: b -> T.Text -> IO (Maybe (UserId b)) -- | Retrieve a user from the database - getUserById :: (FromJSON a, ToJSON a) => b -> UserId b -> IO (Maybe (User a)) - -- | List all users (unlimited, or limited) - listUsers :: (FromJSON a, ToJSON a) => b -> Maybe (Int64, Int64) -> IO [(UserId b, User a)] + getUserById :: b -> UserId b -> IO (Maybe User) + -- | List all users unlimited, or limited, sorted by a 'UserField' + listUsers :: b -> Maybe (Int64, Int64) -> SortBy UserField -> IO [(UserId b, User)] -- | Count all users countUsers :: b -> IO Int64 -- | Create a user - createUser :: (FromJSON a, ToJSON a) => b -> User a -> IO (Either CreateUserError (UserId b)) + createUser :: b -> User -> IO (Either CreateUserError (UserId b)) -- | Modify a user - updateUser :: (FromJSON a, ToJSON a) => b -> UserId b -> (User a -> User a) -> IO (Either UpdateUserError ()) - -- | Modify details of a user - updateUserDetails :: (FromJSON a, ToJSON a) => b -> UserId b -> (a -> a) -> IO () - updateUserDetails backend userId f = - do _ <- - updateUser backend userId $ - \user -> - user - { u_more = f (u_more user) - } - return () + updateUser :: b -> UserId b -> (User -> User) -> IO (Either UpdateUserError ()) -- | Delete a user deleteUser :: b -> UserId b -> IO () -- | Authentificate a user using username/email and password. The 'NominalDiffTime' describes the session duration authUser :: b -> T.Text -> PasswordPlain -> NominalDiffTime -> IO (Maybe SessionId) -- | Authentificate a user and execute a single action. - withAuthUser :: FromJSON a => b -> T.Text -> (User a -> Bool) -> (UserId b -> IO r) -> IO (Maybe r) + withAuthUser :: b -> T.Text -> (User -> Bool) -> (UserId b -> IO r) -> IO (Maybe r) -- | Verify a 'SessionId'. The session duration can be extended by 'NominalDiffTime' verifySession :: b -> SessionId -> NominalDiffTime -> IO (Maybe (UserId b)) -- | Force create a session for a user. This is useful for support/admin login. @@ -106,7 +108,7 @@ -- | Request a 'PasswordResetToken' for a given user, valid for 'NominalDiffTime' requestPasswordReset :: b -> UserId b -> NominalDiffTime -> IO PasswordResetToken -- | Check if a 'PasswordResetToken' is still valid and retrieve the owner of it - verifyPasswordResetToken :: (FromJSON a, ToJSON a) => b -> PasswordResetToken -> IO (Maybe (User a)) + verifyPasswordResetToken :: b -> PasswordResetToken -> IO (Maybe User) -- | Apply a new password to the owner of 'PasswordResetToken' iff the token is still valid applyNewPassword :: b -> PasswordResetToken -> Password -> IO (Either TokenError ()) -- | Request an 'ActivationToken' for a given user, valid for 'NominalDiffTime' @@ -166,37 +168,43 @@ deriving (Show, Eq, Typeable) -- | Strip the password from the user type. -hidePassword :: User a -> User a +hidePassword :: User -> User hidePassword user = user { u_password = PasswordHidden } --- | Core user datatype. Store custom information in the 'u_more' field -data User a +-- | Fields of user datatype +data UserField + = UserFieldId + | UserFieldName + | UserFieldEmail + | UserFieldPassword + | UserFieldActive + deriving (Show, Eq) + +-- | Core user datatype +data User = User { u_name :: !T.Text , u_email :: !T.Text , u_password :: !Password , u_active :: !Bool - , u_more :: !a } deriving (Show, Eq, Typeable) -instance ToJSON a => ToJSON (User a) where - toJSON (User name email _ active more) = +instance ToJSON User where + toJSON (User name email _ active) = object [ "name" .= name , "email" .= email , "active" .= active - , "more" .= more ] -instance FromJSON a => FromJSON (User a) where +instance FromJSON User where parseJSON = withObject "User" $ \obj -> User <$> obj .: "name" <*> obj .: "email" <*> (parsePassword <$> (obj .:? "password")) <*> obj .: "active" - <*> obj .: "more" where parsePassword maybePass = case maybePass of diff --git a/users.cabal b/users.cabal --- a/users.cabal +++ b/users.cabal @@ -1,5 +1,5 @@ name: users -version: 0.4.0.0 +version: 0.5.0.0 synopsis: A library simplifying user management for web applications description: Scrap the boilerplate for managing user accounts in web applications . @@ -18,6 +18,7 @@ Current Backends: . * + . * . homepage: https://github.com/agrafix/users @@ -26,7 +27,7 @@ license-file: LICENSE author: Alexander Thiemann maintainer: Alexander Thiemann -copyright: (c) 2015 Alexander Thiemann +copyright: (c) 2015 - 2016 Alexander Thiemann category: Web build-type: Simple cabal-version: >=1.10 @@ -40,7 +41,7 @@ build-depends: aeson >=0.7, base >=4.6 && <5, - bcrypt >=0.0.6, + bcrypt >=0.0.8, path-pieces >=0.1, text >=1.2, time >=1.4