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/Postgresql.hs b/src/Web/Users/Postgresql.hs new file mode 100644 --- /dev/null +++ b/src/Web/Users/Postgresql.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 diff --git a/users-postgresql-simple.cabal b/users-postgresql-simple.cabal new file mode 100644 --- /dev/null +++ b/users-postgresql-simple.cabal @@ -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 for + . + . + 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 +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.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