diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/src/Web/Users/Postgresql.hs b/src/Web/Users/Postgresql.hs --- a/src/Web/Users/Postgresql.hs +++ b/src/Web/Users/Postgresql.hs @@ -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 diff --git a/users-postgresql-simple.cabal b/users-postgresql-simple.cabal --- a/users-postgresql-simple.cabal +++ b/users-postgresql-simple.cabal @@ -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 for . . - 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,