users-postgresql-simple 0.4.0.0 → 0.5.0.0
raw patch · 3 files changed
+47/−35 lines, 3 filesdep −aesondep ~users
Dependencies removed: aeson
Dependency ranges changed: users
Files
- LICENSE +1/−1
- src/Web/Users/Postgresql.hs +43/−30
- users-postgresql-simple.cabal +3/−4
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2015 Alexander Thiemann+Copyright (c) 2015 - 2016 Alexander Thiemann Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the
src/Web/Users/Postgresql.hs view
@@ -14,7 +14,6 @@ #else import Control.Monad.Error #endif-import Data.Aeson import Data.Int import Data.Maybe import Data.Monoid@@ -36,8 +35,8 @@ 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));+ CONSTRAINT "l_pk" PRIMARY KEY (lid)+ ); |] createUserTokenTable :: Query@@ -82,6 +81,22 @@ strMsg = error "Calling fail not supported" #endif +getSqlField :: UserField -> BSC.ByteString+getSqlField userField =+ case userField of+ UserFieldId -> "lid"+ UserFieldActive -> "is_active"+ UserFieldEmail -> "email"+ UserFieldName -> "username"+ UserFieldPassword -> "password"++getOrderBy :: SortBy UserField -> BSC.ByteString+getOrderBy sb =+ "ORDER BY " <>+ case sb of+ SortAsc t -> getSqlField t <> " ASC"+ SortDesc t -> getSqlField t <> " DESC"+ instance UserStorageBackend Connection where type UserId Connection = Int64 initUserBackend conn =@@ -113,26 +128,27 @@ listToMaybe <$> map fromOnly <$> query conn [sql|SELECT lid FROM login WHERE (username = ? OR email = ?) LIMIT 1;|] (username, username) getUserById conn userId = do resultSet <-- query conn [sql|SELECT username, email, is_active, more FROM login WHERE lid = ? LIMIT 1;|] (Only userId)+ query conn [sql|SELECT username, email, is_active FROM login WHERE lid = ? LIMIT 1;|] (Only userId) case resultSet of- ((username, email, is_active, more) : _) ->- return $ convertUserTuple (username, PasswordHidden, email, is_active, more)+ ((username, email, is_active) : _) ->+ return $ Just $ convertUserTuple (username, PasswordHidden, email, is_active) _ -> return Nothing- listUsers conn mLimit =+ listUsers conn mLimit sortField = do let limitPart = case mLimit of Nothing -> "" Just (start, count) -> (Query $ BSC.pack $ " LIMIT " ++ show start ++ ", " ++ show count)+ sortPart =+ Query $ " " <> getOrderBy sortField <> " " baseQuery =- [sql|SELECT lid, username, email, is_active, more FROM login|]- fullQuery = baseQuery <> limitPart- convertUser (lid, username, email, isActive, more) =- do user <- convertUserTuple (username, PasswordHidden, email, isActive, more)- return (lid, user)+ [sql|SELECT lid, username, email, is_active FROM login|]+ fullQuery = baseQuery <> sortPart <> limitPart+ convertUser (lid, username, email, isActive) =+ (lid, convertUserTuple (username, PasswordHidden, email, isActive)) resultSet <- query_ conn fullQuery- return $ catMaybes $ map convertUser resultSet+ return $ map convertUser resultSet countUsers conn = do [(Only count)] <-@@ -152,8 +168,8 @@ (False, True) -> return $ Left UsernameAlreadyTaken (False, False) -> do [(Only userId)] <-- query conn [sql|INSERT INTO login (username, password, email, is_active, more) VALUES (?, ?, ?, ?, ?) RETURNING lid|]- (u_name user, p, u_email user, u_active user, toJSON $ u_more user)+ query conn [sql|INSERT INTO login (username, password, email, is_active) VALUES (?, ?, ?, ?) RETURNING lid|]+ (u_name user, p, u_email user, u_active user) return $ Right userId _ -> return $ Left InvalidPassword@@ -175,8 +191,8 @@ when ((counter :: Int64) /= 0) $ throwError EmailAlreadyExists 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)+ execute conn [sql|UPDATE login SET username = ?, email = ?, is_active = ? WHERE lid = ?;|]+ (u_name newUser, u_email newUser, u_active newUser, userId) case u_password newUser of PasswordHash p -> do _ <-@@ -188,18 +204,18 @@ do _ <- execute conn [sql|DELETE FROM login WHERE lid = ?;|] (Only userId) return () authUser conn username password sessionTtl =- withAuthUser conn username (\(user :: User Value) -> verifyPassword password $ u_password user) $ \userId ->+ withAuthUser conn username (\user -> verifyPassword password $ u_password user) $ \userId -> SessionId <$> createToken conn "session" userId sessionTtl createSession conn userId sessionTtl = do mUser <- getUserById conn userId- case (mUser :: Maybe (User Value)) of+ case (mUser :: Maybe User) of Nothing -> return Nothing Just _ -> Just . SessionId <$> createToken conn "session" userId sessionTtl withAuthUser conn username authFn action =- do resultSet <- query conn [sql|SELECT lid, username, password, email, is_active, more FROM login WHERE (username = ? OR email = ?) LIMIT 1;|] (username, username)+ do resultSet <- query conn [sql|SELECT lid, username, password, email, is_active FROM login WHERE (username = ? OR email = ?) LIMIT 1;|] (username, username) case resultSet of- ((userId, name, password, email, is_active, more) : _)- -> do user <- convertUserTuple (name, PasswordHash password, email, is_active, more)+ ((userId, name, password, email, is_active) : _)+ -> do let user = convertUserTuple (name, PasswordHash password, email, is_active) if authFn user then Just <$> action userId else return Nothing@@ -225,7 +241,7 @@ return $ Left TokenInvalid Just userId -> do _ <-- updateUser conn userId $ \(user :: User Value) -> user { u_active = True }+ updateUser conn userId $ \user -> user { u_active = True } deleteToken conn "activation" token return $ Right () verifyPasswordResetToken conn (PasswordResetToken token) =@@ -240,7 +256,7 @@ return $ Left TokenInvalid Just userId -> do _ <-- updateUser conn userId $ \(user :: User Value) -> user { u_password = password }+ updateUser conn userId $ \user -> user { u_password = password } deleteToken conn "password_reset" token return $ Right () @@ -283,9 +299,6 @@ ((Only userId) : _) -> return $ Just userId _ -> return Nothing -convertUserTuple :: (FromJSON a, Monad m) => (T.Text, Password, T.Text, Bool, Value) -> m (User a)-convertUserTuple (username, password, email, isActive, more) =- case fromJSON more of- Error e -> fail e- Success val ->- return $ User username email password isActive val+convertUserTuple :: (T.Text, Password, T.Text, Bool) -> User+convertUserTuple (username, password, email, isActive) =+ User username email password isActive
users-postgresql-simple.cabal view
@@ -1,10 +1,10 @@ name: users-postgresql-simple-version: 0.4.0.0+version: 0.5.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.+ It supports all postgres versions starting from 8.3 and requires the included extensions uuid-ossp. . The package itself does not expose any bindings but provides an instance for 'UserStorageBackend'. .@@ -33,9 +33,8 @@ exposed-modules: Web.Users.Postgresql build-depends: base >=4.6 && <5,- users >=0.4.0.0,+ users >=0.5.0.0, postgresql-simple >=0.4,- aeson >=0.7, text >=1.2, mtl >=2.1, uuid >=1.3,