users-postgresql-simple (empty) → 0.1.0.0
raw patch · 5 files changed
+351/−0 lines, 5 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, hspec, mtl, postgresql-simple, text, time, users, users-postgresql-simple, users-test, uuid
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- src/Web/Users/Postgresql.hs +257/−0
- test/Spec.hs +13/−0
- users-postgresql-simple.cabal +59/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Web/Users/Postgresql.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Web.Users.Postgresql () where++import Web.Users.Types++import Control.Monad+import Control.Monad.Except+import Data.Aeson+import Data.Int+import Data.Maybe+import Data.Monoid+import Data.Time.Clock+import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.SqlQQ+import Database.PostgreSQL.Simple.Types+import qualified Data.ByteString.Char8 as BSC+import qualified Data.Text as T+import qualified Data.UUID as UUID++createUsersTable :: Query+createUsersTable =+ [sql|+ CREATE TABLE IF NOT EXISTS login (+ lid SERIAL UNIQUE,+ created_at TIMESTAMPTZ NOT NULL DEFAULT CURRENT_DATE,+ username VARCHAR(64) NOT NULL UNIQUE,+ password VARCHAR(255) NOT NULL,+ email VARCHAR(64) NOT NULL UNIQUE,+ is_active BOOLEAN NOT NULL DEFAULT FALSE,+ more JSON,+ CONSTRAINT "l_pk" PRIMARY KEY (lid));+ |]++createUserTokenTable :: Query+createUserTokenTable =+ [sql|+ CREATE TABLE IF NOT EXISTS login_token (+ ltid SERIAL UNIQUE,+ token UUID UNIQUE,+ token_type VARCHAR(64) NOT NULL,+ lid INTEGER NOT NULL,+ created_at TIMESTAMPTZ NOT NULL DEFAULT CURRENT_DATE,+ valid_until TIMESTAMPTZ NOT NULL,+ CONSTRAINT "lt_pk" PRIMARY KEY (ltid),+ CONSTRAINT "lt_lid_fk" FOREIGN KEY (lid) REFERENCES login ON DELETE CASCADE+ );+ |]++doesIndexExist :: Connection -> String -> IO Bool+doesIndexExist conn idx =+ do (resultSet :: [Only Int]) <-+ query conn [sql|SELECT 1+ FROM pg_class c+ JOIN pg_namespace n ON n.oid = c.relnamespace+ WHERE c.relname = ?+ AND n.nspname = 'public';+ |] (Only idx)+ return (length resultSet > 0)++unlessM :: Monad m => m Bool -> m () -> m ()+unlessM check a =+ do r <- check+ unless r a++instance UserStorageBackend Connection where+ type UserId Connection = Int64+ initUserBackend conn =+ do _ <- execute_ conn [sql|CREATE EXTENSION IF NOT EXISTS pgcrypto;|]+ _ <- execute_ conn [sql|CREATE EXTENSION IF NOT EXISTS "uuid-ossp";|]+ _ <- execute_ conn createUsersTable+ _ <- execute_ conn createUserTokenTable+ unlessM (doesIndexExist conn "l_username") $+ do _ <- execute_ conn [sql|CREATE INDEX l_username ON login USING btree(username);|]+ return ()+ unlessM (doesIndexExist conn "l_email") $+ do _ <- execute_ conn [sql|CREATE INDEX l_email ON login USING btree(email);|]+ return ()+ unlessM (doesIndexExist conn "lt_token_type") $+ do _ <- execute_ conn [sql|CREATE INDEX lt_token_type ON login_token USING btree(token_type);|]+ return ()+ unlessM (doesIndexExist conn "lt_token") $+ do _ <- execute_ conn [sql|CREATE INDEX lt_token ON login_token USING btree(token);|]+ return ()+ return ()+ destroyUserBackend conn =+ do _ <- execute_ conn [sql|DROP TABLE login_token;|]+ _ <- execute_ conn [sql|DROP TABLE login;|]+ return ()+ housekeepBackend conn =+ do _ <- execute_ conn [sql|DELETE FROM login_token WHERE valid_until < NOW();|]+ return ()+ getUserById conn userId =+ do resultSet <-+ query conn [sql|SELECT username, email, is_active, more FROM login WHERE lid = ? LIMIT 1;|] (Only userId)+ case resultSet of+ (userTuple : _) ->+ return $ convertUserTuple userTuple+ _ -> return Nothing+ listUsers conn mLimit =+ do let limitPart =+ case mLimit of+ Nothing -> ""+ Just (start, count) ->+ (Query $ BSC.pack $ " LIMIT " ++ show start ++ ", " ++ show count)+ baseQuery =+ [sql|SELECT lid, username, email, is_active, more FROM login|]+ fullQuery = baseQuery <> limitPart+ convertUser (lid, username, email, isActive, more) =+ do user <- convertUserTuple (username, email, isActive, more)+ return (lid, user)+ resultSet <-+ query_ conn fullQuery+ return $ catMaybes $ map convertUser resultSet++ countUsers conn =+ do [(Only count)] <-+ query_ conn [sql|SELECT COUNT(lid) FROM login;|]+ return count+ createUser conn user =+ case u_password user of+ PasswordPlain p ->+ do [(Only counter)] <-+ query conn [sql|SELECT COUNT(lid) FROM login WHERE username = ? OR email = ?;|] (u_name user, u_email user)+ if (counter :: Int64) /= 0+ then return $ Left UsernameOrEmailAlreadyTaken+ else do [(Only userId)] <-+ query conn [sql|INSERT INTO login (username, password, email, is_active, more) VALUES (?, crypt(?, gen_salt('bf', 8)), ?, ?, ?) RETURNING lid|]+ (u_name user, p, u_email user, u_active user, toJSON $ u_more user)+ return $ Right userId+ _ ->+ return $ Left InvalidPassword+ updateUser conn userId updateFun =+ do mUser <- getUserById conn userId+ case mUser of+ Nothing ->+ return $ Left UserDoesntExit+ Just origUser ->+ runExceptT $+ do let newUser = updateFun origUser+ when (u_name newUser /= u_name origUser) $+ do [(Only counter)] <-+ liftIO $ query conn [sql|SELECT COUNT(lid) FROM login WHERE username = ?;|] (Only $ u_name newUser)+ when ((counter :: Int64) /= 0) $ throwError UsernameOrEmailAlreadyExists+ when (u_email newUser /= u_email origUser) $+ do [(Only counter)] <-+ liftIO $ query conn [sql|SELECT COUNT(lid) FROM login WHERE email = ?;|] (Only $ u_email newUser)+ when ((counter :: Int64) /= 0) $ throwError UsernameOrEmailAlreadyExists+ liftIO $+ do _ <-+ execute conn [sql|UPDATE login SET username = ?, email = ?, is_active = ?, more = ? WHERE lid = ?;|]+ (u_name newUser, u_email newUser, u_active newUser, toJSON $ u_more newUser, userId)+ case u_password newUser of+ PasswordPlain p ->+ do _ <-+ execute conn [sql|UPDATE login SET password = crypt(?, gen_salt('bf', 8)) WHERE lid = ?;|] (p, userId)+ return ()+ _ -> return ()+ return ()+ deleteUser conn userId =+ do _ <- execute conn [sql|DELETE FROM login WHERE lid = ?;|] (Only userId)+ return ()+ authUser conn username password sessionTtl =+ do resultSet <-+ query conn [sql|SELECT lid FROM login WHERE (username = ? OR email = ?) AND crypt(?, password) = password LIMIT 1;|] (username, username, password)+ case resultSet of+ ((Only userId) : _) ->+ do sessionToken <- createToken conn "session" userId sessionTtl+ return $ Just $ SessionId sessionToken+ _ -> return Nothing+ verifySession conn (SessionId sessionId) extendTime =+ do mUser <- getTokenOwner conn "session" sessionId+ case mUser of+ Nothing -> return Nothing+ Just userId ->+ do extendToken conn "session" sessionId extendTime+ return (Just userId)+ destroySession conn (SessionId sessionId) = deleteToken conn "session" sessionId+ requestPasswordReset conn userId timeToLive =+ do token <- createToken conn "password_reset" userId timeToLive+ return $ PasswordResetToken token+ requestActivationToken conn userId timeToLive =+ do token <- createToken conn "activation" userId timeToLive+ return $ ActivationToken token+ activateUser conn (ActivationToken token) =+ do mUser <- getTokenOwner conn "activation" token+ case mUser of+ Nothing ->+ return $ Left TokenInvalid+ Just userId ->+ do _ <-+ updateUser conn userId $ \(user :: User Value) -> user { u_active = True }+ deleteToken conn "activation" token+ return $ Right ()+ verifyPasswordResetToken conn (PasswordResetToken token) =+ do mUser <- getTokenOwner conn "password_reset" token+ case mUser of+ Nothing -> return Nothing+ Just userId -> getUserById conn userId+ applyNewPassword conn (PasswordResetToken token) password =+ do mUser <- getTokenOwner conn "password_reset" token+ case mUser of+ Nothing ->+ return $ Left TokenInvalid+ Just userId ->+ do _ <-+ updateUser conn userId $ \(user :: User Value) -> user { u_password = PasswordPlain password }+ deleteToken conn "password_reset" token+ return $ Right ()++convertTtl :: NominalDiffTime -> Int+convertTtl = round++createToken :: Connection -> String -> Int64 -> NominalDiffTime -> IO T.Text+createToken conn tokenType userId timeToLive =+ do [(Only sessionToken)] <-+ query conn [sql|INSERT INTO login_token (token, token_type, lid, valid_until)+ VALUES (uuid_generate_v4(), ?, ?, NOW() + '? seconds')+ RETURNING token;|]+ (tokenType, userId :: Int64, convertTtl timeToLive)+ return (T.pack $ UUID.toString sessionToken)++deleteToken :: Connection -> String -> T.Text -> IO ()+deleteToken conn tokenType token =+ case UUID.fromString (T.unpack token) of+ Nothing -> return ()+ Just uuid ->+ do _ <- execute conn [sql|DELETE FROM login_token WHERE token_type = ? AND token = ?;|] (tokenType, uuid)+ return ()++extendToken :: Connection -> String -> T.Text -> NominalDiffTime -> IO ()+extendToken conn tokenType token timeToLive =+ case UUID.fromString (T.unpack token) of+ Nothing -> return ()+ Just uuid ->+ do _ <-+ execute conn [sql|UPDATE login_token SET valid_until = valid_until + '? seconds' WHERE token_type = ? AND token = ?;|] (convertTtl timeToLive, tokenType, uuid)+ return ()++getTokenOwner :: Connection -> String -> T.Text -> IO (Maybe Int64)+getTokenOwner conn tokenType token =+ case UUID.fromString (T.unpack token) of+ Nothing -> return Nothing+ Just uuid ->+ do resultSet <- query conn [sql|SELECT lid FROM login_token WHERE token_type = ? AND token = ? AND valid_until > NOW() LIMIT 1;|] (tokenType, uuid)+ case resultSet of+ ((Only userId) : _) -> return $ Just userId+ _ -> return Nothing++convertUserTuple :: (FromJSON a, Monad m) => (T.Text, T.Text, Bool, Value) -> m (User a)+convertUserTuple (username, email, isActive, more) =+ case fromJSON more of+ Error e -> fail e+ Success val ->+ return $ User username email PasswordHidden isActive val
+ test/Spec.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Web.Users.TestSpec+import Web.Users.Postgresql ()++import Database.PostgreSQL.Simple+import Test.Hspec++main :: IO ()+main =+ do conn <- connectPostgreSQL ""+ hspec $ makeUsersSpec conn
+ users-postgresql-simple.cabal view
@@ -0,0 +1,59 @@+name: users-postgresql-simple+version: 0.1.0.0+synopsis: A PostgreSQL backend for the users package+description: This library is a backend driver using <http://hackage.haskell.org/package/postgresql-simple postgresql-simple> for+ <http://hackage.haskell.org/package/users the "users" library>.+ .+ It supports all postgres versions starting from 8.3 and requires the included extensions pgcrypto, uuid-ossp.+ .+ The package itself does not expose any bindings but provides an instance for 'UserStorageBackend'.+ .+ Usage:+ .+ > module Foo where+ > import Web.Users.Types+ > import Web.Users.Postgresql ()+ > -- code goes here+homepage: https://github.com/agrafix/users+bug-reports: https://github.com/agrafix/users/issues+license: MIT+license-file: LICENSE+author: Alexander Thiemann <mail@athiemann.net>+maintainer: Alexander Thiemann <mail@athiemann.net>+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.Postgresql+ build-depends:+ base >=4.6 && <5,+ users >=0.1,+ postgresql-simple >=0.4,+ aeson >=0.8,+ text >=1.2,+ mtl >=2.2,+ uuid >=1.3,+ bytestring >=0.10,+ time >=1.4+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -auto-all -Wall -fno-warn-orphans++test-suite users-postgresql-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends:+ base >=4.6 && <5,+ hspec >=2.1,+ postgresql-simple,+ users-postgresql-simple,+ users-test+ ghc-options: -auto-all -Wall -fno-warn-orphans+ default-language: Haskell2010