├── .gitignore ├── .travis.yml ├── Readme.md ├── prepare-package.sh ├── stack-lts-5.yaml ├── stack.yaml ├── users-persistent ├── LICENSE ├── Setup.hs ├── src │ └── Web │ │ └── Users │ │ ├── Persistent.hs │ │ └── Persistent │ │ └── Definitions.hs ├── test │ └── Spec.hs └── users-persistent.cabal ├── users-postgresql-simple ├── LICENSE ├── Setup.hs ├── src │ └── Web │ │ └── Users │ │ └── Postgresql.hs ├── test │ └── Spec.hs └── users-postgresql-simple.cabal ├── users-test ├── LICENSE ├── Setup.hs ├── src │ └── Web │ │ └── Users │ │ └── TestSpec.hs └── users-test.cabal └── users ├── LICENSE ├── Setup.hs ├── src └── Web │ └── Users │ └── Types.hs └── users.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .virtualenv 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | .idea/ 18 | .stack-work/ 19 | users.iml 20 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # Choose a lightweight base image; we provide our own build tools. 5 | language: c 6 | 7 | # GHC depends on GMP. You can add other dependencies here as well. 8 | addons: 9 | postgresql: "9.3" 10 | apt: 11 | packages: 12 | - libgmp-dev 13 | 14 | # The different configurations we want to test. You could also do things like 15 | # change flags or use --stack-yaml to point to a different file. 16 | env: 17 | - TRAVIS_STACK_ARGS="--resolver nightly" STACK_YAML=stack.yaml 18 | - TRAVIS_STACK_ARGS="--resolver lts" STACK_YAML=stack.yaml 19 | - TRAVIS_STACK_ARGS="" STACK_YAML=stack.yaml 20 | - TRAVIS_STACK_ARGS="--resolver lts-5" STACK_YAML=stack-lts-5.yaml 21 | 22 | before_install: 23 | # Download and unpack the stack executable 24 | - mkdir -p ~/.local/bin 25 | - export PATH=$HOME/.local/bin:$PATH 26 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 27 | 28 | # This line does all of the work: installs GHC if necessary, build the library, 29 | # executables, and test suites, and runs the test suites. --no-terminal works 30 | # around some quirks in Travis's terminal implementation. 31 | install: 32 | - stack $TRAVIS_STACK_ARGS --no-terminal --install-ghc setup 33 | - stack install cabal-install 34 | - stack solver --update-config 35 | 36 | script: 37 | - stack test --haddock 38 | 39 | # Caching so the next build will be fast too. 40 | cache: 41 | directories: 42 | - $HOME/.stack 43 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | # The 'users' Packages 2 | 3 | [![Build Status](https://travis-ci.org/agrafix/users.svg)](https://travis-ci.org/agrafix/users) 4 | 5 | A set of libraries simplifying user management for web applications. 6 | 7 | Hackage: [users](http://hackage.haskell.org/package/users) 8 | 9 | ## Why? 10 | When building a prototype, a small or medium sized Haskell web application with some type of user management, one has to reimplement that management for every project. This is tiring and error prone, thus the users package. It provides a simple API to user management, exchangable backends and a [test specification](http://hackage.haskell.org/package/users-test) for backends. 11 | 12 | ## Features 13 | 14 | * Simple API 15 | * CRUD for users 16 | * Session management 17 | * Password resetting 18 | * Activation of users 19 | 20 | ## Backends 21 | 22 | * [postgresql-simple](http://hackage.haskell.org/package/users-postgresql-simple) 23 | * [persistent](http://hackage.haskell.org/package/users-persistent) 24 | 25 | ## Contribution 26 | 27 | Feel free to extend the test specification with anything you want to have tested and submit a pull request. Backends can be either provided as pull request if they are 'mainstream' enough or you can create a separate repository and have it linked here. The major versions of all backend packages should match the major version of the core package providing the `UserStorageBackend` typeclass. 28 | -------------------------------------------------------------------------------- /prepare-package.sh: -------------------------------------------------------------------------------- 1 | #/usr/bin/env/sh 2 | set -e 3 | set -x 4 | 5 | PKG="$1" 6 | 7 | cd $PKG 8 | cabal sandbox init 9 | 10 | case "$PKG" in 11 | users-test) 12 | cabal sandbox add-source ../users 13 | ;; 14 | users-postgresql-simple) 15 | cabal sandbox add-source ../users 16 | cabal sandbox add-source ../users-test 17 | ;; 18 | users-persistent) 19 | cabal sandbox add-source ../users 20 | cabal sandbox add-source ../users-test 21 | ;; 22 | *) 23 | echo "No sandbox sources to add!" 24 | ;; 25 | esac 26 | 27 | cabal install -j8 --only-dep --enable-tests 28 | cabal configure --enable-tests 29 | cabal build 30 | -------------------------------------------------------------------------------- /stack-lts-5.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - users/ 4 | - users-persistent/ 5 | - users-postgresql-simple/ 6 | - users-test/ 7 | extra-deps: [] 8 | resolver: lts-5.17 9 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - users/ 4 | - users-persistent/ 5 | - users-postgresql-simple/ 6 | - users-test/ 7 | extra-deps: [] 8 | resolver: lts-7.9 9 | -------------------------------------------------------------------------------- /users-persistent/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 - 2016 Alexander Thiemann 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /users-persistent/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /users-persistent/src/Web/Users/Persistent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | module Web.Users.Persistent (LoginId, Persistent(..)) where 9 | 10 | import Web.Users.Types 11 | import Web.Users.Persistent.Definitions 12 | 13 | import Control.Applicative ((<|>)) 14 | import Control.Monad 15 | import Control.Monad.Trans.Maybe 16 | import Control.Monad.Reader 17 | #if MIN_VERSION_mtl(2,2,0) 18 | import Control.Monad.Except 19 | #else 20 | import Control.Monad.Error 21 | #endif 22 | import Data.Typeable 23 | import Data.Time.Clock 24 | import Database.Persist 25 | import Database.Persist.Sql 26 | import qualified Database.Esqueleto as E 27 | import qualified Data.Text as T 28 | import qualified Data.UUID as UUID 29 | import qualified Data.UUID.V4 as UUID 30 | 31 | 32 | #if MIN_VERSION_base(4,7,0) 33 | deriving instance Typeable Key 34 | #else 35 | deriving instance Typeable1 Key 36 | #endif 37 | 38 | #if MIN_VERSION_mtl(2,2,0) 39 | type ErrorT = ExceptT 40 | runErrorT :: ErrorT e m a -> m (Either e a) 41 | runErrorT = runExceptT 42 | #else 43 | -- a hack... :-( 44 | instance Error UpdateUserError where 45 | noMsg = error "Calling fail not supported" 46 | strMsg = error "Calling fail not supported" 47 | #endif 48 | 49 | packLogin :: Monad m => User -> m (UTCTime -> Login) 50 | packLogin usr = 51 | do p <- 52 | case u_password usr of 53 | PasswordHash p -> return p 54 | _ -> fail "Invalid password! Not hashed!" 55 | return $ \t -> 56 | Login 57 | { loginUsername = u_name usr 58 | , loginEmail = u_email usr 59 | , loginPassword = p 60 | , loginActive = u_active usr 61 | , loginCreatedAt = t 62 | } 63 | 64 | unpackLogin :: Login -> User 65 | unpackLogin l = 66 | (unpackLogin' l) { u_password = PasswordHidden } 67 | 68 | unpackLogin' :: Login -> User 69 | unpackLogin' l = 70 | User 71 | { u_name = loginUsername l 72 | , u_email = loginEmail l 73 | , u_password = PasswordHash (loginPassword l) 74 | , u_active = loginActive l 75 | } 76 | 77 | mkTuple :: Entity Login -> (LoginId, User) 78 | mkTuple entity = 79 | let user = unpackLogin (entityVal entity) 80 | in (entityKey entity, user) 81 | 82 | compileField :: UserField -> (forall t. EntityField Login t -> a) -> a 83 | compileField fld f = 84 | case fld of 85 | UserFieldId -> f LoginId 86 | UserFieldActive -> f LoginActive 87 | UserFieldEmail -> f LoginEmail 88 | UserFieldName -> f LoginUsername 89 | UserFieldPassword -> f LoginPassword 90 | 91 | newtype Persistent = Persistent { runPersistent :: forall a. SqlPersistT IO a -> IO a } 92 | 93 | instance UserStorageBackend Persistent where 94 | type UserId Persistent = LoginId 95 | initUserBackend conn = 96 | runPersistent conn $ runMigration migrateAll 97 | destroyUserBackend conn = 98 | runPersistent conn $ 99 | do _ <- rawExecute "DROP TABLE IF EXISTS \"login\";" [] 100 | _ <- rawExecute "DROP TABLE IF EXISTS \"login_token\";" [] 101 | return () 102 | housekeepBackend conn = 103 | do now <- getCurrentTime 104 | runPersistent conn $ deleteWhere [LoginTokenValidUntil <=. now] 105 | getUserIdByName conn userOrEmail = 106 | runPersistent conn $ 107 | do mUserA <- getBy (UniqueUsername userOrEmail) 108 | mUserB <- getBy (UniqueEmail userOrEmail) 109 | return $ fmap entityKey (mUserA <|> mUserB) 110 | getUserById conn loginId = 111 | runPersistent conn $ 112 | do mUser <- get loginId 113 | return $ fmap unpackLogin mUser 114 | listUsers conn mLimit sorter = 115 | runPersistent conn $ 116 | do let orderOpts = 117 | case sorter of 118 | SortAsc t -> compileField t Asc 119 | SortDesc t -> compileField t Desc 120 | xs <- 121 | case mLimit of 122 | Nothing -> selectList [] [orderOpts] 123 | Just (start, lim) -> 124 | selectList [] 125 | [ orderOpts 126 | , OffsetBy (fromIntegral start) 127 | , LimitTo (fromIntegral lim) 128 | ] 129 | return $ map mkTuple xs 130 | countUsers conn = 131 | liftM fromIntegral $ 132 | runPersistent conn $ count ([] :: [Filter Login]) 133 | createUser conn l = 134 | case packLogin l of 135 | Nothing -> return $ Left InvalidPassword 136 | Just mkUser -> 137 | do now <- getCurrentTime 138 | let usr = mkUser now 139 | runPersistent conn $ 140 | do mUsername <- selectFirst [LoginUsername ==. loginUsername usr] [] 141 | email <- emailInUse (loginEmail usr) 142 | case (mUsername, email) of 143 | (Just _, True) -> return $ Left UsernameAndEmailAlreadyTaken 144 | (Just _, _) -> return $ Left UsernameAlreadyTaken 145 | (Nothing, True) -> return $ Left EmailAlreadyTaken 146 | (Nothing, False) -> Right <$> insert usr 147 | updateUser conn userId updateFun = 148 | do mUser <- getUserById conn userId 149 | case mUser of 150 | Nothing -> 151 | return $ Left UserDoesntExist 152 | Just origUser -> 153 | runErrorT $ 154 | do let newUser = updateFun origUser 155 | when (u_name newUser /= u_name origUser) $ 156 | do counter <- liftIO $ runPersistent conn $ count [LoginUsername ==. u_name newUser] 157 | when (counter /= 0) $ throwError UsernameAlreadyExists 158 | when (u_email newUser /= u_email origUser) $ 159 | do emailUsed <- liftIO $ runPersistent conn $ emailInUse (u_email newUser) 160 | when emailUsed $ throwError EmailAlreadyExists 161 | liftIO $ runPersistent conn $ 162 | do update userId [ LoginUsername =. u_name newUser 163 | , LoginEmail =. u_email newUser 164 | , LoginActive =. u_active newUser 165 | ] 166 | case u_password newUser of 167 | PasswordHash p -> update userId [ LoginPassword =. p ] 168 | _ -> return () 169 | deleteUser conn userId = 170 | runPersistent conn $ delete userId 171 | withAuthUser conn userOrEmail authFn action = 172 | runMaybeT $ 173 | do login <- MaybeT . liftIO . runPersistent conn 174 | $ selectFirst ([LoginUsername ==. userOrEmail] ||. [LoginEmail ==. userOrEmail]) [] 175 | let user = unpackLogin' $ entityVal login 176 | guard $ authFn user 177 | liftIO . action . entityKey $ login 178 | authUser conn userOrEmail pwd sessionTtl = 179 | withAuthUser conn userOrEmail (\user -> verifyPassword pwd $ u_password user) $ \userId -> 180 | SessionId <$> createToken conn "session" userId sessionTtl 181 | verifySession conn (SessionId sessionId) extendTime = 182 | do mUser <- getTokenOwner conn "session" sessionId 183 | case mUser of 184 | Nothing -> return Nothing 185 | Just userId -> 186 | do extendToken conn "session" sessionId extendTime 187 | return (Just userId) 188 | createSession conn userId sessionTtl = 189 | do mUser <- getUserById conn userId 190 | case (mUser :: Maybe User) of 191 | Nothing -> return Nothing 192 | Just _ -> Just . SessionId <$> createToken conn "session" userId sessionTtl 193 | destroySession conn (SessionId sessionId) = deleteToken conn "session" sessionId 194 | requestPasswordReset conn userId timeToLive = 195 | do token <- createToken conn "password_reset" userId timeToLive 196 | return $ PasswordResetToken token 197 | requestActivationToken conn userId timeToLive = 198 | do token <- createToken conn "activation" userId timeToLive 199 | return $ ActivationToken token 200 | activateUser conn (ActivationToken token) = 201 | do mUser <- getTokenOwner conn "activation" token 202 | case mUser of 203 | Nothing -> 204 | return $ Left TokenInvalid 205 | Just userId -> 206 | do _ <- 207 | updateUser conn userId $ \user -> user { u_active = True } 208 | deleteToken conn "activation" token 209 | return $ Right () 210 | verifyPasswordResetToken conn (PasswordResetToken token) = 211 | do mUser <- getTokenOwner conn "password_reset" token 212 | case mUser of 213 | Nothing -> return Nothing 214 | Just userId -> getUserById conn userId 215 | applyNewPassword conn (PasswordResetToken token) password = 216 | do mUser <- getTokenOwner conn "password_reset" token 217 | case mUser of 218 | Nothing -> 219 | return $ Left TokenInvalid 220 | Just userId -> 221 | do _ <- 222 | updateUser conn userId $ \user -> user { u_password = password } 223 | deleteToken conn "password_reset" token 224 | return $ Right () 225 | 226 | emailInUse :: MonadIO m => T.Text -> ReaderT SqlBackend m Bool 227 | emailInUse email = 228 | do emailMatches <- 229 | E.select $ 230 | E.from $ \login -> 231 | do E.where_ $ E.lower_ (login E.^. LoginEmail) 232 | E.==. E.lower_ (E.val email) 233 | E.limit 1 234 | return login 235 | return (not $ null emailMatches) 236 | 237 | createToken :: Persistent -> String -> LoginId -> NominalDiffTime -> IO T.Text 238 | createToken conn tokenType userId timeToLive = 239 | runPersistent conn $ 240 | do tok <- liftM (T.pack . UUID.toString) $ liftIO $ UUID.nextRandom 241 | now <- liftIO getCurrentTime 242 | _ <- insert $ LoginToken tok (T.pack tokenType) now (timeToLive `addUTCTime` now) userId 243 | return tok 244 | 245 | deleteToken :: Persistent -> String -> T.Text -> IO () 246 | deleteToken conn tokenType token = 247 | runPersistent conn $ 248 | case UUID.fromString (T.unpack token) of 249 | Nothing -> return () 250 | Just _ -> 251 | do deleteBy (UniqueTypedToken token (T.pack tokenType)) 252 | return () 253 | 254 | extendToken :: Persistent -> String -> T.Text -> NominalDiffTime -> IO () 255 | extendToken conn tokenType token timeToLive = 256 | runPersistent conn $ 257 | case UUID.fromString (T.unpack token) of 258 | Nothing -> return () 259 | Just _ -> 260 | do let selC = [LoginTokenTokenType ==. T.pack tokenType, LoginTokenToken ==. token] 261 | m <- 262 | selectFirst selC [Desc LoginTokenValidUntil] 263 | case m of 264 | Nothing -> return () 265 | Just t -> 266 | do let validUntil = 267 | loginTokenValidUntil (entityVal t) 268 | now <- liftIO getCurrentTime 269 | let extendedValid = timeToLive `addUTCTime` now 270 | when (extendedValid > validUntil) $ 271 | updateWhere selC [LoginTokenValidUntil =. extendedValid] 272 | return () 273 | 274 | getTokenOwner :: Persistent -> String -> T.Text -> IO (Maybe LoginId) 275 | getTokenOwner conn tokenType token = 276 | runPersistent conn $ 277 | case UUID.fromString (T.unpack token) of 278 | Nothing -> return Nothing 279 | Just _ -> 280 | do now <- liftIO $ getCurrentTime 281 | m <- selectFirst [LoginTokenTokenType ==. T.pack tokenType, LoginTokenToken ==. token, LoginTokenValidUntil >. now] [] 282 | return $ fmap (loginTokenOwner . entityVal) m 283 | -------------------------------------------------------------------------------- /users-persistent/src/Web/Users/Persistent/Definitions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeSynonymInstances #-} 15 | 16 | module Web.Users.Persistent.Definitions where 17 | 18 | import Database.Persist.TH 19 | import Data.Time.Clock 20 | import Data.Typeable 21 | import qualified Data.Text as T 22 | 23 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 24 | Login 25 | createdAt UTCTime 26 | username T.Text 27 | email T.Text 28 | password T.Text 29 | active Bool 30 | UniqueUsername username 31 | UniqueEmail email 32 | deriving Show 33 | deriving Eq 34 | deriving Typeable 35 | LoginToken 36 | token T.Text 37 | tokenType T.Text 38 | createdAt UTCTime 39 | validUntil UTCTime 40 | owner LoginId 41 | UniqueToken token 42 | UniqueTypedToken token tokenType 43 | deriving Show 44 | deriving Eq 45 | deriving Typeable 46 | |] 47 | -------------------------------------------------------------------------------- /users-persistent/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import Web.Users.TestSpec 5 | import Web.Users.Persistent 6 | 7 | import System.IO.Temp 8 | import System.IO 9 | import Control.Monad.Logger 10 | import Database.Persist.Sqlite 11 | import Test.Hspec 12 | import qualified Data.Text as T 13 | 14 | main :: IO () 15 | main = 16 | withSystemTempFile "tempBaseXXX.db" $ \fp hdl -> 17 | do hClose hdl 18 | pool <- runNoLoggingT $ createSqlitePool (T.pack fp) 5 19 | hspec $ makeUsersSpec (Persistent $ flip runSqlPool pool) 20 | -------------------------------------------------------------------------------- /users-persistent/users-persistent.cabal: -------------------------------------------------------------------------------- 1 | name: users-persistent 2 | version: 0.5.0.2 3 | synopsis: A persistent backend for the users package 4 | description: This library is a backend driver using for 5 | . 6 | . 7 | The package itself does not expose any bindings but provides an instance for 'UserStorageBackend'. 8 | . 9 | Usage: 10 | . 11 | > module Foo where 12 | > import Web.Users.Types 13 | > import Web.Users.Persistent 14 | > -- code goes here 15 | homepage: https://github.com/agrafix/users 16 | license: MIT 17 | license-file: LICENSE 18 | author: Alexander Thiemann 19 | maintainer: Alexander Thiemann 20 | copyright: (c) 2015 - 2016 Alexander Thiemann 21 | category: Data 22 | build-type: Simple 23 | cabal-version: >=1.10 24 | 25 | source-repository head 26 | type: git 27 | location: git://github.com/agrafix/users.git 28 | 29 | library 30 | exposed-modules: Web.Users.Persistent 31 | Web.Users.Persistent.Definitions 32 | build-depends: base >=4.6 && <5, 33 | persistent >=2.0, 34 | persistent-template >=2.1, 35 | esqueleto >=2.1, 36 | users >=0.5, 37 | transformers >=0.4, 38 | mtl >=2.1, 39 | time >=1.4, 40 | bytestring >=0.10, 41 | text >=1.2, 42 | uuid >=1.3 43 | hs-source-dirs: src 44 | default-language: Haskell2010 45 | ghc-options: -auto-all -Wall -fno-warn-orphans 46 | 47 | test-suite users-persistent-tests 48 | type: exitcode-stdio-1.0 49 | hs-source-dirs: test 50 | main-is: Spec.hs 51 | build-depends: 52 | base >=4.6 && <5, 53 | hspec >=2.1, 54 | persistent-sqlite >=2.1, 55 | monad-logger >=0.3, 56 | temporary >=1.0, 57 | text, 58 | users-persistent, 59 | users-test 60 | ghc-options: -auto-all -Wall -fno-warn-orphans 61 | default-language: Haskell2010 62 | -------------------------------------------------------------------------------- /users-postgresql-simple/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 - 2016 Alexander Thiemann 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /users-postgresql-simple/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /users-postgresql-simple/src/Web/Users/Postgresql.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE CPP #-} 7 | module Web.Users.Postgresql () where 8 | 9 | import Web.Users.Types 10 | 11 | import Control.Monad 12 | #if MIN_VERSION_mtl(2,2,0) 13 | import Control.Monad.Except 14 | #else 15 | import Control.Monad.Error 16 | #endif 17 | import Data.Int 18 | import Data.Maybe 19 | import Data.Monoid 20 | import Data.Time.Clock 21 | import Database.PostgreSQL.Simple 22 | import Database.PostgreSQL.Simple.SqlQQ 23 | import Database.PostgreSQL.Simple.Types 24 | import qualified Data.ByteString.Char8 as BSC 25 | import qualified Data.Text as T 26 | import qualified Data.UUID as UUID 27 | 28 | createUsersTable :: Query 29 | createUsersTable = 30 | [sql| 31 | CREATE TABLE IF NOT EXISTS login ( 32 | lid SERIAL UNIQUE, 33 | created_at TIMESTAMPTZ NOT NULL DEFAULT CURRENT_DATE, 34 | username VARCHAR(64) NOT NULL UNIQUE, 35 | password VARCHAR(255) NOT NULL, 36 | email VARCHAR(64) NOT NULL UNIQUE, 37 | is_active BOOLEAN NOT NULL DEFAULT FALSE, 38 | CONSTRAINT "l_pk" PRIMARY KEY (lid) 39 | ); 40 | |] 41 | 42 | createUserTokenTable :: Query 43 | createUserTokenTable = 44 | [sql| 45 | CREATE TABLE IF NOT EXISTS login_token ( 46 | ltid SERIAL UNIQUE, 47 | token UUID UNIQUE, 48 | token_type VARCHAR(64) NOT NULL, 49 | lid INTEGER NOT NULL, 50 | created_at TIMESTAMPTZ NOT NULL DEFAULT CURRENT_DATE, 51 | valid_until TIMESTAMPTZ NOT NULL, 52 | CONSTRAINT "lt_pk" PRIMARY KEY (ltid), 53 | CONSTRAINT "lt_lid_fk" FOREIGN KEY (lid) REFERENCES login ON DELETE CASCADE 54 | ); 55 | |] 56 | 57 | doesIndexExist :: Connection -> String -> IO Bool 58 | doesIndexExist conn idx = 59 | do (resultSet :: [Only Int]) <- 60 | query conn [sql|SELECT 1 61 | FROM pg_class c 62 | JOIN pg_namespace n ON n.oid = c.relnamespace 63 | WHERE c.relname = ? 64 | AND n.nspname = 'public'; 65 | |] (Only idx) 66 | return (length resultSet > 0) 67 | 68 | doesExtensionExist :: Connection -> String -> IO Bool 69 | doesExtensionExist conn ext = 70 | do (resultSet :: [Only Int]) <- 71 | query conn [sql|SELECT 1 72 | FROM pg_extension e 73 | JOIN pg_namespace n ON n.oid = e.extnamespace 74 | WHERE e.extname = ? 75 | AND n.nspname = 'public'; 76 | |] (Only ext) 77 | return (length resultSet > 0) 78 | 79 | unlessM :: Monad m => m Bool -> m () -> m () 80 | unlessM check a = 81 | do r <- check 82 | unless r a 83 | 84 | #if MIN_VERSION_mtl(2,2,0) 85 | type ErrorT = ExceptT 86 | runErrorT :: ErrorT e m a -> m (Either e a) 87 | runErrorT = runExceptT 88 | #else 89 | -- a hack... :-( 90 | instance Error UpdateUserError where 91 | noMsg = error "Calling fail not supported" 92 | strMsg = error "Calling fail not supported" 93 | #endif 94 | 95 | getSqlField :: UserField -> BSC.ByteString 96 | getSqlField userField = 97 | case userField of 98 | UserFieldId -> "lid" 99 | UserFieldActive -> "is_active" 100 | UserFieldEmail -> "email" 101 | UserFieldName -> "username" 102 | UserFieldPassword -> "password" 103 | 104 | getOrderBy :: SortBy UserField -> BSC.ByteString 105 | getOrderBy sb = 106 | "ORDER BY " <> 107 | case sb of 108 | SortAsc t -> getSqlField t <> " ASC" 109 | SortDesc t -> getSqlField t <> " DESC" 110 | 111 | instance UserStorageBackend Connection where 112 | type UserId Connection = Int64 113 | initUserBackend conn = 114 | do unlessM (doesExtensionExist conn "uuid-ossp") $ 115 | do _ <- execute_ conn [sql|CREATE EXTENSION "uuid-ossp";|] 116 | return () 117 | _ <- execute_ conn createUsersTable 118 | _ <- execute_ conn createUserTokenTable 119 | unlessM (doesIndexExist conn "l_username") $ 120 | do _ <- execute_ conn [sql|CREATE INDEX l_username ON login USING btree(username);|] 121 | return () 122 | unlessM (doesIndexExist conn "l_email") $ 123 | do _ <- execute_ conn [sql|CREATE INDEX l_email ON login USING btree(email);|] 124 | return () 125 | unlessM (doesIndexExist conn "l_lower_email") $ 126 | do _ <- execute_ conn [sql|CREATE INDEX l_lower_email ON login USING btree(lower(email));|] 127 | return () 128 | unlessM (doesIndexExist conn "lt_token_type") $ 129 | do _ <- execute_ conn [sql|CREATE INDEX lt_token_type ON login_token USING btree(token_type);|] 130 | return () 131 | unlessM (doesIndexExist conn "lt_token") $ 132 | do _ <- execute_ conn [sql|CREATE INDEX lt_token ON login_token USING btree(token);|] 133 | return () 134 | return () 135 | destroyUserBackend conn = 136 | do _ <- execute_ conn [sql|DROP TABLE login_token;|] 137 | _ <- execute_ conn [sql|DROP TABLE login;|] 138 | return () 139 | housekeepBackend conn = 140 | do _ <- execute_ conn [sql|DELETE FROM login_token WHERE valid_until < NOW();|] 141 | return () 142 | -- | Retrieve a user id from the database 143 | getUserIdByName conn username = 144 | listToMaybe <$> map fromOnly <$> query conn [sql|SELECT lid FROM login WHERE (username = ? OR email = ?) LIMIT 1;|] (username, username) 145 | getUserById conn userId = 146 | do resultSet <- 147 | query conn [sql|SELECT username, email, is_active FROM login WHERE lid = ? LIMIT 1;|] (Only userId) 148 | case resultSet of 149 | ((username, email, is_active) : _) -> 150 | return $ Just $ convertUserTuple (username, PasswordHidden, email, is_active) 151 | _ -> return Nothing 152 | listUsers conn mLimit sortField = 153 | do let limitPart = 154 | case mLimit of 155 | Nothing -> "" 156 | Just (start, count) -> 157 | (Query $ BSC.pack $ " OFFSET " ++ show start ++ " LIMIT " ++ show count) 158 | sortPart = 159 | Query $ " " <> getOrderBy sortField <> " " 160 | baseQuery = 161 | [sql|SELECT lid, username, email, is_active FROM login|] 162 | fullQuery = baseQuery <> sortPart <> limitPart 163 | convertUser (lid, username, email, isActive) = 164 | (lid, convertUserTuple (username, PasswordHidden, email, isActive)) 165 | resultSet <- 166 | query_ conn fullQuery 167 | return $ map convertUser resultSet 168 | 169 | countUsers conn = 170 | do [(Only count)] <- 171 | query_ conn [sql|SELECT COUNT(lid) FROM login;|] 172 | return count 173 | createUser conn user = 174 | case u_password user of 175 | PasswordHash p -> 176 | do ([(Only emailCounter)], [(Only nameCounter)]) <- (,) <$> 177 | query conn [sql|SELECT COUNT(lid) FROM login WHERE lower(email) = lower(?) LIMIT 1;|] (Only $ u_email user) 178 | <*> query conn [sql|SELECT COUNT(lid) FROM login WHERE username = ? LIMIT 1;|] (Only $ u_name user) 179 | let both f (x, y) = (f x, f y) 180 | bothCount = both (== 1) (emailCounter :: Int64, nameCounter :: Int64) 181 | case bothCount of 182 | (True, True) -> return $ Left UsernameAndEmailAlreadyTaken 183 | (True, False) -> return $ Left EmailAlreadyTaken 184 | (False, True) -> return $ Left UsernameAlreadyTaken 185 | (False, False) -> 186 | do [(Only userId)] <- 187 | query conn [sql|INSERT INTO login (username, password, email, is_active) VALUES (?, ?, ?, ?) RETURNING lid|] 188 | (u_name user, p, u_email user, u_active user) 189 | return $ Right userId 190 | _ -> 191 | return $ Left InvalidPassword 192 | updateUser conn userId updateFun = 193 | do mUser <- getUserById conn userId 194 | case mUser of 195 | Nothing -> 196 | return $ Left UserDoesntExist 197 | Just origUser -> 198 | runErrorT $ 199 | do let newUser = updateFun origUser 200 | when (u_name newUser /= u_name origUser) $ 201 | do [(Only counter)] <- 202 | liftIO $ query conn [sql|SELECT COUNT(lid) FROM login WHERE username = ?;|] (Only $ u_name newUser) 203 | when ((counter :: Int64) /= 0) $ throwError UsernameAlreadyExists 204 | when (u_email newUser /= u_email origUser) $ 205 | do [(Only counter)] <- 206 | liftIO $ query conn [sql|SELECT COUNT(lid) FROM login WHERE lower(email) = lower(?);|] (Only $ u_email newUser) 207 | when ((counter :: Int64) /= 0) $ throwError EmailAlreadyExists 208 | liftIO $ 209 | do _ <- 210 | execute conn [sql|UPDATE login SET username = ?, email = ?, is_active = ? WHERE lid = ?;|] 211 | (u_name newUser, u_email newUser, u_active newUser, userId) 212 | case u_password newUser of 213 | PasswordHash p -> 214 | do _ <- 215 | execute conn [sql|UPDATE login SET password = ? WHERE lid = ?;|] (p, userId) 216 | return () 217 | _ -> return () 218 | return () 219 | deleteUser conn userId = 220 | do _ <- execute conn [sql|DELETE FROM login WHERE lid = ?;|] (Only userId) 221 | return () 222 | authUser conn username password sessionTtl = 223 | withAuthUser conn username (\user -> verifyPassword password $ u_password user) $ \userId -> 224 | SessionId <$> createToken conn "session" userId sessionTtl 225 | createSession conn userId sessionTtl = 226 | do mUser <- getUserById conn userId 227 | case (mUser :: Maybe User) of 228 | Nothing -> return Nothing 229 | Just _ -> Just . SessionId <$> createToken conn "session" userId sessionTtl 230 | withAuthUser conn username authFn action = 231 | do resultSet <- query conn [sql|SELECT lid, username, password, email, is_active FROM login WHERE (username = ? OR email = ?) LIMIT 1;|] (username, username) 232 | case resultSet of 233 | ((userId, name, password, email, is_active) : _) 234 | -> do let user = convertUserTuple (name, PasswordHash password, email, is_active) 235 | if authFn user 236 | then Just <$> action userId 237 | else return Nothing 238 | _ -> return Nothing 239 | verifySession conn (SessionId sessionId) extendTime = 240 | do mUser <- getTokenOwner conn "session" sessionId 241 | case mUser of 242 | Nothing -> return Nothing 243 | Just userId -> 244 | do extendToken conn "session" sessionId extendTime 245 | return (Just userId) 246 | destroySession conn (SessionId sessionId) = deleteToken conn "session" sessionId 247 | requestPasswordReset conn userId timeToLive = 248 | do token <- createToken conn "password_reset" userId timeToLive 249 | return $ PasswordResetToken token 250 | requestActivationToken conn userId timeToLive = 251 | do token <- createToken conn "activation" userId timeToLive 252 | return $ ActivationToken token 253 | activateUser conn (ActivationToken token) = 254 | do mUser <- getTokenOwner conn "activation" token 255 | case mUser of 256 | Nothing -> 257 | return $ Left TokenInvalid 258 | Just userId -> 259 | do _ <- 260 | updateUser conn userId $ \user -> user { u_active = True } 261 | deleteToken conn "activation" token 262 | return $ Right () 263 | verifyPasswordResetToken conn (PasswordResetToken token) = 264 | do mUser <- getTokenOwner conn "password_reset" token 265 | case mUser of 266 | Nothing -> return Nothing 267 | Just userId -> getUserById conn userId 268 | applyNewPassword conn (PasswordResetToken token) password = 269 | do mUser <- getTokenOwner conn "password_reset" token 270 | case mUser of 271 | Nothing -> 272 | return $ Left TokenInvalid 273 | Just userId -> 274 | do _ <- 275 | updateUser conn userId $ \user -> user { u_password = password } 276 | deleteToken conn "password_reset" token 277 | return $ Right () 278 | 279 | convertTtl :: NominalDiffTime -> Int 280 | convertTtl = round 281 | 282 | createToken :: Connection -> String -> Int64 -> NominalDiffTime -> IO T.Text 283 | createToken conn tokenType userId timeToLive = 284 | do [Only sessionToken] <- 285 | query conn [sql|INSERT INTO login_token (token, token_type, lid, valid_until) 286 | VALUES (uuid_generate_v4(), ?, ?, NOW() + '? seconds') 287 | RETURNING token;|] 288 | (tokenType, userId :: Int64, convertTtl timeToLive) 289 | return (T.pack $ UUID.toString sessionToken) 290 | 291 | deleteToken :: Connection -> String -> T.Text -> IO () 292 | deleteToken conn tokenType token = 293 | case UUID.fromString (T.unpack token) of 294 | Nothing -> return () 295 | Just uuid -> 296 | do _ <- execute conn [sql|DELETE FROM login_token WHERE token_type = ? AND token = ?;|] (tokenType, uuid) 297 | return () 298 | 299 | extendToken :: Connection -> String -> T.Text -> NominalDiffTime -> IO () 300 | extendToken conn tokenType token timeToLive = 301 | case UUID.fromString (T.unpack token) of 302 | Nothing -> return () 303 | Just uuid -> 304 | do _ <- 305 | execute conn [sql| 306 | UPDATE login_token 307 | SET valid_until = 308 | (CASE WHEN NOW() + '? seconds' > valid_until THEN NOW() + '? seconds' ELSE valid_until END) 309 | WHERE token_type = ? 310 | AND token = ?;|] (convertTtl timeToLive, convertTtl timeToLive, tokenType, uuid) 311 | return () 312 | 313 | getTokenOwner :: Connection -> String -> T.Text -> IO (Maybe Int64) 314 | getTokenOwner conn tokenType token = 315 | case UUID.fromString (T.unpack token) of 316 | Nothing -> return Nothing 317 | Just uuid -> 318 | do resultSet <- query conn [sql|SELECT lid FROM login_token WHERE token_type = ? AND token = ? AND valid_until > NOW() LIMIT 1;|] (tokenType, uuid) 319 | case resultSet of 320 | ((Only userId) : _) -> return $ Just userId 321 | _ -> return Nothing 322 | 323 | convertUserTuple :: (T.Text, Password, T.Text, Bool) -> User 324 | convertUserTuple (username, password, email, isActive) = 325 | User username email password isActive 326 | -------------------------------------------------------------------------------- /users-postgresql-simple/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import Web.Users.TestSpec 5 | import Web.Users.Postgresql () 6 | 7 | import Database.PostgreSQL.Simple 8 | import Test.Hspec 9 | 10 | main :: IO () 11 | main = 12 | do conn <- connectPostgreSQL "" 13 | hspec $ makeUsersSpec conn 14 | -------------------------------------------------------------------------------- /users-postgresql-simple/users-postgresql-simple.cabal: -------------------------------------------------------------------------------- 1 | name: users-postgresql-simple 2 | version: 0.5.0.2 3 | synopsis: A PostgreSQL backend for the users package 4 | description: This library is a backend driver using for 5 | . 6 | . 7 | It supports all postgres versions starting from 8.3 and requires the included extensions uuid-ossp. 8 | . 9 | The package itself does not expose any bindings but provides an instance for 'UserStorageBackend'. 10 | . 11 | Usage: 12 | . 13 | > module Foo where 14 | > import Web.Users.Types 15 | > import Web.Users.Postgresql () 16 | > -- code goes here 17 | homepage: https://github.com/agrafix/users 18 | bug-reports: https://github.com/agrafix/users/issues 19 | license: MIT 20 | license-file: LICENSE 21 | author: Alexander Thiemann 22 | maintainer: Alexander Thiemann 23 | copyright: (c) 2015 - 2016 Alexander Thiemann 24 | category: Web 25 | build-type: Simple 26 | cabal-version: >=1.10 27 | 28 | source-repository head 29 | type: git 30 | location: git://github.com/agrafix/users.git 31 | 32 | library 33 | exposed-modules: Web.Users.Postgresql 34 | build-depends: 35 | base >=4.6 && <5, 36 | users >=0.5.0.0, 37 | postgresql-simple >=0.4, 38 | text >=1.2, 39 | mtl >=2.1, 40 | uuid >=1.3, 41 | bytestring >=0.10, 42 | time >=1.4 43 | hs-source-dirs: src 44 | default-language: Haskell2010 45 | ghc-options: -auto-all -Wall -fno-warn-orphans 46 | 47 | test-suite users-postgresql-tests 48 | type: exitcode-stdio-1.0 49 | hs-source-dirs: test 50 | main-is: Spec.hs 51 | build-depends: 52 | base >=4.6 && <5, 53 | hspec >=2.1, 54 | postgresql-simple, 55 | users-postgresql-simple, 56 | users-test 57 | ghc-options: -auto-all -Wall -fno-warn-orphans 58 | default-language: Haskell2010 59 | -------------------------------------------------------------------------------- /users-test/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 - 2016 Alexander Thiemann 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /users-test/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /users-test/src/Web/Users/TestSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Web.Users.TestSpec 4 | ( makeUsersSpec ) 5 | where 6 | 7 | import Web.Users.Types 8 | 9 | import Control.Concurrent (threadDelay) 10 | import Control.Monad 11 | import Test.Hspec 12 | import qualified Data.Text as T 13 | 14 | mkUser :: T.Text -> T.Text -> User 15 | mkUser name email = 16 | User 17 | { u_name = name 18 | , u_email = email 19 | , u_password = makePassword "1234" 20 | , u_active = False 21 | } 22 | 23 | assertRight :: Show a => IO (Either a b) -> (b -> IO ()) -> IO () 24 | assertRight val action = 25 | do r <- val 26 | case r of 27 | Right v -> action v 28 | Left err -> expectationFailure (show err) 29 | 30 | assertLeft :: IO (Either a b) -> String -> (a -> IO ()) -> IO () 31 | assertLeft val msg action = 32 | do r <- val 33 | case r of 34 | Right _ -> expectationFailure msg 35 | Left v -> action v 36 | 37 | assertJust :: IO (Maybe a) -> String -> (a -> IO ()) -> IO () 38 | assertJust val msg action = 39 | do r <- val 40 | case r of 41 | Nothing -> expectationFailure msg 42 | Just v -> action v 43 | 44 | makeUsersSpec :: forall b. UserStorageBackend b => b -> Spec 45 | makeUsersSpec backend = 46 | before_ (initUserBackend backend) $ 47 | after_ (destroyUserBackend backend) $ 48 | do describe "core user management" $ 49 | do it "should create valid users" $ 50 | assertRight (createUser backend userA) $ const (return ()) 51 | it "should not allow duplicates" $ 52 | assertRight (createUser backend userB) $ \_ -> 53 | do assertLeft (createUser backend (mkUser "foo2" "bar2@baz.com")) 54 | "succeeded to create foo2 bar2 again" $ \err -> 55 | err `shouldBe` UsernameAndEmailAlreadyTaken 56 | assertLeft (createUser backend (mkUser "foo2" "asdas@baz.com")) 57 | "succeeded to create foo2 with different email again" $ \err -> 58 | err `shouldBe` UsernameAlreadyTaken 59 | assertLeft (createUser backend (mkUser "asdas" "bar2@baz.com")) 60 | "succeeded to create different user with same email" $ \err -> 61 | err `shouldBe` EmailAlreadyTaken 62 | assertLeft (createUser backend (mkUser "asdas" "Bar2@baz.com")) 63 | "succeeded to create different user with different email capitalisation" $ \err -> 64 | err `shouldBe` EmailAlreadyTaken 65 | it "list and count should be correct" $ 66 | assertRight (createUser backend userA) $ \userId1 -> 67 | assertRight (createUser backend userB) $ \userId2 -> 68 | do allUsers <- listUsers backend (Just (0,10)) (SortAsc UserFieldId) 69 | unless ((userId1, hidePassword userA) `elem` allUsers && (userId2, hidePassword userB) `elem` allUsers) 70 | (expectationFailure $ "create users not in user list:" ++ show allUsers) 71 | countUsers backend `shouldReturn` 2 72 | it "sorting should work" $ 73 | assertRight (createUser backend userA) $ \_ -> 74 | assertRight (createUser backend userB) $ \_ -> 75 | assertRight (createUser backend userC) $ \userId3 -> 76 | do allUsers <- listUsers backend Nothing (SortAsc UserFieldName) 77 | head allUsers `shouldBe` (userId3, hidePassword userC) 78 | it "updating and loading users should work" $ 79 | assertRight (createUser backend userA) $ \userIdA -> 80 | assertRight (createUser backend userB) $ \_ -> 81 | do assertRight (updateUser backend userIdA (\user -> user { u_name = "changed" })) $ const (return ()) 82 | assertLeft (updateUser backend userIdA (\user -> user { u_name = "foo2" })) 83 | "succeeded to set username to already used username" $ \err -> 84 | err `shouldBe` UsernameAlreadyExists 85 | assertLeft (updateUser backend userIdA (\user -> user { u_email = "bar2@baz.com" })) 86 | "succeeded to set email to already used email" $ \err -> 87 | err `shouldBe` EmailAlreadyExists 88 | userA' <- getUserById backend userIdA 89 | userA' `shouldBe` 90 | (Just $ (hidePassword userA) 91 | { u_name = "changed" 92 | }) 93 | userIdA' <- getUserIdByName backend "changed" 94 | userIdA' `shouldBe` Just userIdA 95 | it "deleting users should work" $ 96 | assertRight (createUser backend userA) $ \userIdA -> 97 | assertRight (createUser backend userB) $ \userIdB -> 98 | do deleteUser backend userIdA 99 | (allUsers :: [(UserId b, User)]) <- 100 | listUsers backend Nothing (SortAsc UserFieldId) 101 | map fst allUsers `shouldBe` [userIdB] 102 | getUserById backend userIdA `shouldReturn` (Nothing :: Maybe User) 103 | it "reusing a deleted users name should work" $ 104 | assertRight (createUser backend userA) $ \userIdA -> 105 | do deleteUser backend userIdA 106 | assertRight (createUser backend userA) $ const (return ()) 107 | describe "initialisation" $ 108 | it "calling initUserBackend multiple times should not result in errors" $ 109 | assertRight (createUser backend userA) $ \userIdA -> 110 | do initUserBackend backend 111 | userA' <- getUserById backend userIdA 112 | userA' `shouldBe` (Just $ hidePassword userA) 113 | describe "authentification" $ 114 | do it "auth as valid user with username should work" $ 115 | withAuthedUser $ const (return ()) 116 | it "auth as valid user with email should work" $ 117 | withAuthedUser' "bar@baz.com" "1234" 500 0 $ const (return ()) 118 | it "auth with invalid credentials should fail" $ 119 | assertRight (createUser backend userA) $ \_ -> 120 | do authUser backend "foo" (PasswordPlain "aaaa") 500 `shouldReturn` Nothing 121 | authUser backend "foo" (PasswordPlain "123") 500 `shouldReturn` Nothing 122 | authUser backend "bar@baz.com" (PasswordPlain "123") 500 `shouldReturn` Nothing 123 | authUser backend "bar@baz.com' OR 1 = 1 --" (PasswordPlain "123") 500 `shouldReturn` Nothing 124 | authUser backend "bar@baz.com' OR 1 = 1; --" (PasswordPlain "' OR 1 = 1; --") 500 `shouldReturn` Nothing 125 | it "sessionless auth with valid userdata should work" $ 126 | assertRight (createUser backend userA) $ \userIdA -> 127 | do withAuthUser backend "bar@baz.com" ((== "bar@baz.com") . u_email) 128 | (return . (== userIdA)) `shouldReturn` Just True 129 | withAuthUser backend "bar@baz.com" ((== "bar@baz.com") . u_email) 130 | (return . (/= userIdA)) `shouldReturn` Just False 131 | it "sessionless auth with invalid userdata should fail" $ 132 | assertRight (createUser backend userA) $ \userIdA -> 133 | withAuthUser backend "bar@baz.com" ((/= "bar@baz.com") . u_email) 134 | (return . (/= userIdA)) `shouldReturn` Nothing 135 | it "forcing a session works" $ 136 | assertRight (createUser backend userA) $ \userIdA -> 137 | assertJust (createSession backend userIdA 500) "session id missing" $ \_ -> return () 138 | it "destroy session should really remove the session" $ 139 | withAuthedUser $ \(sessionId, _) -> 140 | do destroySession backend sessionId 141 | verifySession backend sessionId 0 `shouldReturn` (Nothing :: Maybe (UserId b)) 142 | it "sessions should time out 1" $ 143 | withAuthedUserT 1 0 $ \(sessionId, _) -> 144 | do threadDelay (seconds 1) 145 | housekeepBackend backend 146 | verifySession backend sessionId 0 `shouldReturn` (Nothing :: Maybe (UserId b)) 147 | it "sessions should time out 2" $ 148 | withAuthedUserT 1 1 $ \(sessionId, _) -> 149 | do threadDelay (seconds 2) 150 | verifySession backend sessionId 0 `shouldReturn` (Nothing :: Maybe (UserId b)) 151 | describe "password reset" $ 152 | do it "generates a valid token for a user" $ 153 | assertRight (createUser backend userA) $ \userIdA -> 154 | do token <- requestPasswordReset backend userIdA 500 155 | verifyPasswordResetToken backend token `shouldReturn` (Just (hidePassword userA) :: Maybe User) 156 | it "a valid token should reset the password" $ 157 | assertRight (createUser backend userA) $ \userIdA -> 158 | do withAuthedUserNoCreate "foo" "1234" 500 0 userIdA $ const (return ()) -- old login 159 | token <- requestPasswordReset backend userIdA 500 160 | housekeepBackend backend 161 | verifyPasswordResetToken backend token `shouldReturn` (Just (hidePassword userA) :: Maybe User) 162 | assertRight (applyNewPassword backend token $ makePassword "foobar") $ const $ return () 163 | withAuthedUserNoCreate "foo" "foobar" 500 0 userIdA $ const (return ()) -- new login 164 | it "expired tokens should not do any harm" $ 165 | assertRight (createUser backend userA) $ \userIdA -> 166 | do withAuthedUserNoCreate "foo" "1234" 500 0 userIdA $ const (return ()) -- old login 167 | token <- requestPasswordReset backend userIdA 1 168 | threadDelay (seconds 1) 169 | verifyPasswordResetToken backend token `shouldReturn` (Nothing :: Maybe User) 170 | assertLeft (applyNewPassword backend token $ makePassword "foobar") 171 | "Reset password with expired token" $ const $ return () 172 | withAuthedUserNoCreate "foo" "1234" 500 0 userIdA $ const (return ()) -- still old login 173 | it "invalid tokens should not do any harm" $ 174 | assertRight (createUser backend userA) $ \userIdA -> 175 | do withAuthedUserNoCreate "foo" "1234" 500 0 userIdA $ const (return ()) -- old login 176 | let token = PasswordResetToken "Foooooooo!!!!" 177 | verifyPasswordResetToken backend token `shouldReturn` (Nothing :: Maybe User) 178 | assertLeft (applyNewPassword backend token $ makePassword "foobar") 179 | "Reset password with random token" $ const $ return () 180 | withAuthedUserNoCreate "foo" "1234" 500 0 userIdA $ const (return ()) -- still old login 181 | describe "user activation" $ 182 | do it "activates a user with a valid activation token" $ 183 | assertRight (createUser backend userA) $ \userIdA -> 184 | do token <- requestActivationToken backend userIdA 500 185 | housekeepBackend backend 186 | assertRight (activateUser backend token) $ const $ return () 187 | userA' <- getUserById backend userIdA 188 | userA' `shouldBe` 189 | (Just $ (hidePassword userA) 190 | { u_active = True 191 | }) 192 | it "does not allow expired tokens to activate a user" $ 193 | assertRight (createUser backend userA) $ \userIdA -> 194 | do token <- requestActivationToken backend userIdA 1 195 | threadDelay (seconds 1) 196 | assertLeft (activateUser backend token) "expired token activated user" $ const $ return () 197 | userA' <- getUserById backend userIdA 198 | userA' `shouldBe` 199 | (Just $ (hidePassword userA) 200 | { u_active = False 201 | }) 202 | it "does not allow invalid tokens to activate a user" $ 203 | assertRight (createUser backend userA) $ \userIdA -> 204 | do let token = ActivationToken "aaaasdlasdkaklasdlkasjdl" 205 | assertLeft (activateUser backend token) "invalid token activated user" $ const $ return () 206 | userA' <- getUserById backend userIdA 207 | userA' `shouldBe` 208 | (Just $ (hidePassword userA) 209 | { u_active = False 210 | }) 211 | where 212 | seconds x = x * 1000000 213 | userA = mkUser "foo" "bar@baz.com" 214 | userB = mkUser "foo2" "bar2@baz.com" 215 | userC = mkUser "alex" "aaaa@bbbbbb.com" 216 | withAuthedUser = withAuthedUser' "foo" "1234" 500 0 217 | withAuthedUserT = withAuthedUser' "foo" "1234" 218 | withAuthedUser' username pass sTime extTime action = 219 | assertRight (createUser backend userA) $ \userIdA -> 220 | withAuthedUserNoCreate username pass sTime extTime userIdA action 221 | withAuthedUserNoCreate username pass sTime extTime userIdA action = 222 | do mAuthRes <- authUser backend username (PasswordPlain pass) sTime 223 | case mAuthRes of 224 | Nothing -> 225 | expectationFailure $ "Can not authenticate as user " ++ show username 226 | Just sessionId -> 227 | do verifySession backend sessionId extTime `shouldReturn` Just userIdA 228 | action (sessionId, userIdA) 229 | -------------------------------------------------------------------------------- /users-test/users-test.cabal: -------------------------------------------------------------------------------- 1 | name: users-test 2 | version: 0.5.0.1 3 | synopsis: Library to test backends for the users library 4 | description: Provides HSpec helpers for backends of . 5 | . 6 | All backend packages should conform to this specification. 7 | homepage: https://github.com/agrafix/users 8 | bug-reports: https://github.com/agrafix/users/issues 9 | license: MIT 10 | license-file: LICENSE 11 | author: Alexander Thiemann 12 | maintainer: Alexander Thiemann 13 | copyright: (c) 2015 - 2016 Alexander Thiemann 14 | category: Web 15 | build-type: Simple 16 | cabal-version: >=1.10 17 | 18 | source-repository head 19 | type: git 20 | location: git://github.com/agrafix/users.git 21 | 22 | 23 | library 24 | exposed-modules: Web.Users.TestSpec 25 | build-depends: 26 | base >=4.6 && <5, 27 | hspec >=2.1, 28 | users >=0.5.0.0, 29 | text >=1.2 30 | hs-source-dirs: src 31 | default-language: Haskell2010 32 | ghc-options: -auto-all -Wall -fno-warn-orphans 33 | -------------------------------------------------------------------------------- /users/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 - 2016 Alexander Thiemann 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /users/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /users/src/Web/Users/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE ConstraintKinds #-} 7 | module Web.Users.Types 8 | ( -- * The core type class 9 | UserStorageBackend (..) 10 | -- * User representation 11 | , User(..), Password(..), makePassword, hidePassword 12 | , PasswordPlain(..), verifyPassword 13 | , UserField(..) 14 | -- * Token types 15 | , PasswordResetToken(..), ActivationToken(..), SessionId(..) 16 | -- * Error types 17 | , CreateUserError(..), UpdateUserError(..) 18 | , TokenError(..) 19 | -- * Helper typed 20 | , SortBy(..) 21 | ) 22 | where 23 | 24 | import Crypto.BCrypt 25 | import Data.Aeson 26 | import Data.Int 27 | import Data.Maybe 28 | import Data.String 29 | import Data.Time.Clock 30 | import Data.Typeable 31 | import Web.PathPieces 32 | import qualified Data.Text as T 33 | import qualified Data.Text.Encoding as T 34 | import qualified System.IO.Unsafe as U 35 | 36 | -- | Errors that happen on storage level during user creation 37 | data CreateUserError 38 | = InvalidPassword 39 | | UsernameAlreadyTaken 40 | | EmailAlreadyTaken 41 | | UsernameAndEmailAlreadyTaken 42 | deriving (Show, Eq) 43 | 44 | -- | Errors that happen on storage level during user updating 45 | data UpdateUserError 46 | = UsernameAlreadyExists 47 | | EmailAlreadyExists 48 | | UserDoesntExist 49 | deriving (Show, Eq) 50 | 51 | -- | Errors that happen on storage level during token actions 52 | data TokenError 53 | = TokenInvalid 54 | deriving (Show, Eq) 55 | 56 | -- | Sorting direction 57 | data SortBy t 58 | = SortAsc t 59 | | SortDesc t 60 | 61 | -- | Backend constraints 62 | type IsUserBackend b = 63 | ( Show (UserId b) 64 | , Eq (UserId b) 65 | , ToJSON (UserId b) 66 | , FromJSON (UserId b) 67 | , Typeable (UserId b) 68 | , PathPiece (UserId b) 69 | ) 70 | 71 | -- | An abstract backend for managing users. A backend library should implement the interface and 72 | -- an end user should build applications on top of this interface. 73 | class IsUserBackend b => UserStorageBackend b where 74 | -- | The storage backends userid 75 | type UserId b :: * 76 | -- | Initialise the backend. Call once on application launch to for 77 | -- example create missing database tables 78 | initUserBackend :: b -> IO () 79 | -- | Destory the backend. WARNING: This is only for testing! It deletes all tables and data. 80 | destroyUserBackend :: b -> IO () 81 | -- | This cleans up invalid sessions and other tokens. Call periodically as needed. 82 | housekeepBackend :: b -> IO () 83 | -- | Retrieve a user id from the database by name or email 84 | getUserIdByName :: b -> T.Text -> IO (Maybe (UserId b)) 85 | -- | Retrieve a user from the database 86 | getUserById :: b -> UserId b -> IO (Maybe User) 87 | -- | List all users unlimited, or limited, sorted by a 'UserField' 88 | listUsers :: b -> Maybe (Int64, Int64) -> SortBy UserField -> IO [(UserId b, User)] 89 | -- | Count all users 90 | countUsers :: b -> IO Int64 91 | -- | Create a user 92 | createUser :: b -> User -> IO (Either CreateUserError (UserId b)) 93 | -- | Modify a user 94 | updateUser :: b -> UserId b -> (User -> User) -> IO (Either UpdateUserError ()) 95 | -- | Delete a user 96 | deleteUser :: b -> UserId b -> IO () 97 | -- | Authentificate a user using username/email and password. The 'NominalDiffTime' describes the session duration 98 | authUser :: b -> T.Text -> PasswordPlain -> NominalDiffTime -> IO (Maybe SessionId) 99 | -- | Authentificate a user and execute a single action. 100 | withAuthUser :: b -> T.Text -> (User -> Bool) -> (UserId b -> IO r) -> IO (Maybe r) 101 | -- | Verify a 'SessionId'. The session duration can be extended by 'NominalDiffTime' 102 | verifySession :: b -> SessionId -> NominalDiffTime -> IO (Maybe (UserId b)) 103 | -- | Force create a session for a user. This is useful for support/admin login. 104 | -- If the user does not exist, this will fail. 105 | createSession :: b -> UserId b -> NominalDiffTime -> IO (Maybe SessionId) 106 | -- | Destroy a session 107 | destroySession :: b -> SessionId -> IO () 108 | -- | Request a 'PasswordResetToken' for a given user, valid for 'NominalDiffTime' 109 | requestPasswordReset :: b -> UserId b -> NominalDiffTime -> IO PasswordResetToken 110 | -- | Check if a 'PasswordResetToken' is still valid and retrieve the owner of it 111 | verifyPasswordResetToken :: b -> PasswordResetToken -> IO (Maybe User) 112 | -- | Apply a new password to the owner of 'PasswordResetToken' iff the token is still valid 113 | applyNewPassword :: b -> PasswordResetToken -> Password -> IO (Either TokenError ()) 114 | -- | Request an 'ActivationToken' for a given user, valid for 'NominalDiffTime' 115 | requestActivationToken :: b -> UserId b -> NominalDiffTime -> IO ActivationToken 116 | -- | Activate the owner of 'ActivationToken' iff the token is still valid 117 | activateUser :: b -> ActivationToken -> IO (Either TokenError ()) 118 | 119 | -- | A password reset token to send out to users via email or sms 120 | newtype PasswordResetToken 121 | = PasswordResetToken { unPasswordResetToken :: T.Text } 122 | deriving (Show, Eq, ToJSON, FromJSON, Typeable, PathPiece) 123 | 124 | -- | An activation token to send out to users via email or sms 125 | newtype ActivationToken 126 | = ActivationToken { unActivationToken :: T.Text } 127 | deriving (Show, Eq, ToJSON, FromJSON, Typeable, PathPiece) 128 | 129 | -- | A session id for identifying user sessions 130 | newtype SessionId 131 | = SessionId { unSessionId :: T.Text } 132 | deriving (Show, Eq, ToJSON, FromJSON, Typeable, PathPiece) 133 | 134 | -- | Construct a password from plaintext by hashing it 135 | makePassword :: PasswordPlain -> Password 136 | makePassword (PasswordPlain plainText) = 137 | let hash = 138 | T.decodeUtf8 $ fromJustPass $ U.unsafePerformIO $ 139 | hashPasswordUsingPolicy policy (T.encodeUtf8 plainText) 140 | in PasswordHash hash 141 | where 142 | policy = 143 | HashingPolicy 144 | { preferredHashCost = 8 145 | , preferredHashAlgorithm = "$2b$" 146 | } 147 | fromJustPass = 148 | fromMaybe (error "makePassword failed. This is probably a bcrypt library error") 149 | 150 | -- | Check a plaintext password against a password 151 | verifyPassword :: PasswordPlain -> Password -> Bool 152 | verifyPassword (PasswordPlain plainText) pwd = 153 | case pwd of 154 | PasswordHidden -> False 155 | PasswordHash hash -> 156 | validatePassword (T.encodeUtf8 hash) (T.encodeUtf8 plainText) 157 | 158 | -- | Plaintext passsword. Used for authentification. 159 | newtype PasswordPlain 160 | = PasswordPlain { unPasswordPlain :: T.Text } 161 | deriving (Show, Eq, Typeable, IsString) 162 | 163 | -- | Password representation. When updating or creating a user, use 'makePassword' to create one. 164 | -- The implementation details of this type are ONLY for use in backend implementations. 165 | data Password 166 | = PasswordHash !T.Text 167 | | PasswordHidden 168 | deriving (Show, Eq, Typeable) 169 | 170 | -- | Strip the password from the user type. 171 | hidePassword :: User -> User 172 | hidePassword user = 173 | user { u_password = PasswordHidden } 174 | 175 | -- | Fields of user datatype 176 | data UserField 177 | = UserFieldId 178 | | UserFieldName 179 | | UserFieldEmail 180 | | UserFieldPassword 181 | | UserFieldActive 182 | deriving (Show, Eq) 183 | 184 | -- | Core user datatype 185 | data User 186 | = User 187 | { u_name :: !T.Text 188 | , u_email :: !T.Text 189 | , u_password :: !Password 190 | , u_active :: !Bool 191 | } deriving (Show, Eq, Typeable) 192 | 193 | instance ToJSON User where 194 | toJSON (User name email _ active) = 195 | object 196 | [ "name" .= name 197 | , "email" .= email 198 | , "active" .= active 199 | ] 200 | 201 | instance FromJSON User where 202 | parseJSON = 203 | withObject "User" $ \obj -> 204 | User <$> obj .: "name" 205 | <*> obj .: "email" 206 | <*> (parsePassword <$> (obj .:? "password")) 207 | <*> obj .: "active" 208 | where 209 | parsePassword maybePass = 210 | case maybePass of 211 | Nothing -> PasswordHidden 212 | Just pwd -> makePassword (PasswordPlain pwd) 213 | -------------------------------------------------------------------------------- /users/users.cabal: -------------------------------------------------------------------------------- 1 | name: users 2 | version: 0.5.0.0 3 | synopsis: A library simplifying user management for web applications 4 | description: Scrap the boilerplate for managing user accounts in web applications 5 | . 6 | Features: 7 | . 8 | * Easy to understand API 9 | . 10 | * CRUD for Users 11 | . 12 | * Session Management 13 | . 14 | * Password reset functionality 15 | . 16 | * Activation functionality 17 | . 18 | Current Backends: 19 | . 20 | * 21 | . 22 | * 23 | . 24 | homepage: https://github.com/agrafix/users 25 | bug-reports: https://github.com/agrafix/users/issues 26 | license: MIT 27 | license-file: LICENSE 28 | author: Alexander Thiemann 29 | maintainer: Alexander Thiemann 30 | copyright: (c) 2015 - 2016 Alexander Thiemann 31 | category: Web 32 | build-type: Simple 33 | cabal-version: >=1.10 34 | 35 | source-repository head 36 | type: git 37 | location: git://github.com/agrafix/users.git 38 | 39 | library 40 | exposed-modules: Web.Users.Types 41 | build-depends: 42 | aeson >=0.7, 43 | base >=4.6 && <5, 44 | bcrypt >=0.0.8, 45 | path-pieces >=0.1, 46 | text >=1.2, 47 | time >=1.4 48 | hs-source-dirs: src 49 | default-language: Haskell2010 50 | ghc-options: -auto-all -Wall -fno-warn-orphans 51 | --------------------------------------------------------------------------------