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/Persistent.hs b/src/Web/Users/Persistent.hs --- a/src/Web/Users/Persistent.hs +++ b/src/Web/Users/Persistent.hs @@ -19,12 +19,10 @@ #else import Control.Monad.Error #endif -import Data.Aeson import Data.Typeable import Data.Time.Clock import Database.Persist import Database.Persist.Sql -import qualified Data.ByteString.Lazy as BSL import qualified Data.Text as T import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID @@ -47,7 +45,7 @@ strMsg = error "Calling fail not supported" #endif -packLogin :: (Monad m, ToJSON a) => User a -> m (UTCTime -> Login) +packLogin :: Monad m => User -> m (UTCTime -> Login) packLogin usr = do p <- case u_password usr of @@ -59,35 +57,36 @@ , loginEmail = u_email usr , loginPassword = p , loginActive = u_active usr - , loginMore = BSL.toStrict $ encode (u_more usr) , loginCreatedAt = t } -unpackLogin :: (FromJSON a, Monad m) => Login -> m (User a) +unpackLogin :: Login -> User unpackLogin l = - do up <- unpackLogin' l - return $ up { u_password = PasswordHidden } + (unpackLogin' l) { u_password = PasswordHidden } -unpackLogin' :: (FromJSON a, Monad m) => Login -> m (User a) +unpackLogin' :: Login -> User unpackLogin' l = - do more <- - case eitherDecodeStrict' (loginMore l) of - Left err -> fail err - Right val -> return val - return $ - User - { u_name = loginUsername l - , u_email = loginEmail l - , u_password = PasswordHash (loginPassword l) - , u_active = loginActive l - , u_more = more - } + User + { u_name = loginUsername l + , u_email = loginEmail l + , u_password = PasswordHash (loginPassword l) + , u_active = loginActive l + } -mkTuple :: (FromJSON a, Monad m) => Entity Login -> m (LoginId, User a) +mkTuple :: Entity Login -> (LoginId, User) mkTuple entity = - do user <- unpackLogin (entityVal entity) - return (entityKey entity, user) + let user = unpackLogin (entityVal entity) + in (entityKey entity, user) +compileField :: UserField -> (forall t. EntityField Login t -> a) -> a +compileField fld f = + case fld of + UserFieldId -> f LoginId + UserFieldActive -> f LoginActive + UserFieldEmail -> f LoginEmail + UserFieldName -> f LoginUsername + UserFieldPassword -> f LoginPassword + newtype Persistent = Persistent { runPersistent :: forall a. SqlPersistT IO a -> IO a } instance UserStorageBackend Persistent where @@ -110,14 +109,23 @@ getUserById conn loginId = runPersistent conn $ do mUser <- get loginId - return $ join $ fmap unpackLogin mUser - listUsers conn mLimit = + return $ fmap unpackLogin mUser + listUsers conn mLimit sorter = runPersistent conn $ - do xs <- + do let orderOpts = + case sorter of + SortAsc t -> compileField t Asc + SortDesc t -> compileField t Desc + xs <- case mLimit of - Nothing -> selectList [] [] - Just (start, lim) -> selectList [] [OffsetBy (fromIntegral start), LimitTo (fromIntegral lim)] - mapM mkTuple xs + Nothing -> selectList [] [orderOpts] + Just (start, lim) -> + selectList [] + [ orderOpts + , OffsetBy (fromIntegral start) + , LimitTo (fromIntegral lim) + ] + return $ map mkTuple xs countUsers conn = liftM fromIntegral $ runPersistent conn $ count ([] :: [Filter Login]) @@ -150,8 +158,10 @@ do counter <- liftIO $ runPersistent conn $ count [LoginEmail ==. u_email newUser] when (counter /= 0) $ throwError EmailAlreadyExists liftIO $ runPersistent conn $ - do update userId [ LoginUsername =. u_name newUser, LoginEmail =. u_email newUser, LoginActive =. u_active newUser - , LoginMore =. (BSL.toStrict $ encode $ u_more newUser) ] + do update userId [ LoginUsername =. u_name newUser + , LoginEmail =. u_email newUser + , LoginActive =. u_active newUser + ] case u_password newUser of PasswordHash p -> update userId [ LoginPassword =. p ] _ -> return () @@ -161,11 +171,11 @@ runMaybeT $ do login <- MaybeT . liftIO . runPersistent conn $ selectFirst ([LoginUsername ==. userOrEmail] ||. [LoginEmail ==. userOrEmail]) [] - user <- unpackLogin' $ entityVal login + let user = unpackLogin' $ entityVal login guard $ authFn user liftIO . action . entityKey $ login authUser conn userOrEmail pwd sessionTtl = - withAuthUser conn userOrEmail (\(user :: User Value) -> verifyPassword pwd $ u_password user) $ \userId -> + withAuthUser conn userOrEmail (\user -> verifyPassword pwd $ u_password user) $ \userId -> SessionId <$> createToken conn "session" userId sessionTtl verifySession conn (SessionId sessionId) extendTime = do mUser <- getTokenOwner conn "session" sessionId @@ -176,7 +186,7 @@ return (Just userId) 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 destroySession conn (SessionId sessionId) = deleteToken conn "session" sessionId @@ -193,7 +203,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) = @@ -208,7 +218,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 () diff --git a/src/Web/Users/Persistent/Definitions.hs b/src/Web/Users/Persistent/Definitions.hs --- a/src/Web/Users/Persistent/Definitions.hs +++ b/src/Web/Users/Persistent/Definitions.hs @@ -18,7 +18,6 @@ import Database.Persist.TH import Data.Time.Clock import Data.Typeable -import qualified Data.ByteString.Char8 as BSC import qualified Data.Text as T share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| @@ -28,7 +27,6 @@ email T.Text password T.Text active Bool - more BSC.ByteString UniqueUsername username UniqueEmail email deriving Show diff --git a/users-persistent.cabal b/users-persistent.cabal --- a/users-persistent.cabal +++ b/users-persistent.cabal @@ -1,5 +1,5 @@ name: users-persistent -version: 0.4.0.0 +version: 0.5.0.0 synopsis: A persistent backend for the users package description: This library is a backend driver using for . @@ -17,7 +17,7 @@ license-file: LICENSE author: Alexander Thiemann maintainer: Alexander Thiemann -copyright: (c) 2015 Alexander Thiemann +copyright: (c) 2015 - 2016 Alexander Thiemann category: Data build-type: Simple cabal-version: >=1.10 @@ -32,10 +32,9 @@ build-depends: base >=4.6 && <5, persistent >=2.0, persistent-template >=2.1, - users >=0.4, + users >=0.5, transformers >=0.4, mtl >=2.1, - aeson >=0.7, time >=1.4, bytestring >=0.10, text >=1.2,