diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Alexander Thiemann + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Web/Users/Types.hs b/src/Web/Users/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/Users/Types.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Web.Users.Types where + +import Control.Applicative +import Data.Aeson +import Data.Int +import Data.Time.Clock +import Data.Typeable +import Web.PathPieces +import qualified Data.Text as T + +-- | Errors that happen on storage level during user creation +data CreateUserError + = UsernameOrEmailAlreadyTaken + | InvalidPassword + deriving (Show, Eq) + +-- | Errors that happen on storage level during user updating +data UpdateUserError + = UsernameOrEmailAlreadyExists + | UserDoesntExit + deriving (Show, Eq) + +-- | Errors that happen on storage level during token actions +data TokenError + = TokenInvalid + deriving (Show, Eq) + +-- | 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 + -- | The storage backends userid + type UserId b :: * + -- | 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 () + -- | This cleans up invalid sessions and other tokens. Call periodically as needed. + housekeepBackend :: b -> IO () + -- | 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)] + -- | Count all users + countUsers :: b -> IO Int64 + -- | Create a user + createUser :: (FromJSON a, ToJSON a) => b -> User a -> 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 () + -- | 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 -> T.Text -> NominalDiffTime -> IO (Maybe SessionId) + -- | Verify a 'SessionId'. The session duration can be extended by 'NominalDiffTime' + verifySession :: b -> SessionId -> NominalDiffTime -> IO (Maybe (UserId b)) + -- | Destroy a session + destroySession :: b -> SessionId -> IO () + -- | 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)) + -- | Apply a new password to the owner of 'PasswordResetToken' iff the token is still valid + applyNewPassword :: b -> PasswordResetToken -> T.Text -> IO (Either TokenError ()) + -- | Request an 'ActivationToken' for a given user, valid for 'NominalDiffTime' + requestActivationToken :: b -> UserId b -> NominalDiffTime -> IO ActivationToken + -- | Activate the owner of 'ActivationToken' iff the token is still valid + activateUser :: b -> ActivationToken -> IO (Either TokenError ()) + +-- | A password reset token to send out to users via email or sms +newtype PasswordResetToken + = PasswordResetToken { unPasswordResetToken :: T.Text } + deriving (Show, Eq, ToJSON, FromJSON, Typeable, PathPiece) + +-- | An activation token to send out to users via email or sms +newtype ActivationToken + = ActivationToken { unActivationToken :: T.Text } + deriving (Show, Eq, ToJSON, FromJSON, Typeable, PathPiece) + +-- | A session id for identifying user sessions +newtype SessionId + = SessionId { unSessionId :: T.Text } + deriving (Show, Eq, ToJSON, FromJSON, Typeable, PathPiece) + +-- | Password representation. When updating or creating a user, set to 'PasswordPlain' +data Password + = PasswordPlain !T.Text + | PasswordHash !T.Text + | PasswordHidden + deriving (Show, Eq, Typeable) + +-- | Core user datatype. Store custom information in the 'u_more' field +data User a + = 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) = + object + [ "name" .= name + , "email" .= email + , "active" .= active + , "more" .= more + ] + +instance FromJSON a => FromJSON (User a) where + parseJSON = + withObject "User" $ \obj -> + User <$> obj .: "name" + <*> obj .: "email" + <*> (parsePassword <$> (obj .:? "password")) + <*> obj .: "active" + <*> obj .: "more" + where + parsePassword maybePass = + case maybePass of + Nothing -> PasswordHidden + Just pwd -> PasswordPlain pwd diff --git a/users.cabal b/users.cabal new file mode 100644 --- /dev/null +++ b/users.cabal @@ -0,0 +1,47 @@ +name: users +version: 0.1.0.0 +synopsis: A library simplifying user management for web applications +description: Scrap the boilerplate for managing user accounts in web applications + . + Features: + . + * Easy to understand API + . + * CRUD for Users + . + * Session Management + . + * Password reset functionality + . + * Activation functionality + . + Current Backends: + . + * + . +homepage: https://github.com/agrafix/users +bug-reports: https://github.com/agrafix/users/issues +license: MIT +license-file: LICENSE +author: Alexander Thiemann +maintainer: Alexander Thiemann +copyright: (c) 2015 Alexander Thiemann +category: Web +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/agrafix/users.git + +library + exposed-modules: Web.Users.Types + build-depends: + aeson >=0.8, + base >=4.6 && <5, + path-pieces >=0.1, + text >=1.2, + time >=1.4 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -auto-all -Wall -fno-warn-orphans