users-persistent 0.4.0.0 → 0.5.0.0
raw patch · 4 files changed
+50/−43 lines, 4 filesdep −aesondep ~users
Dependencies removed: aeson
Dependency ranges changed: users
Files
- LICENSE +1/−1
- src/Web/Users/Persistent.hs +46/−36
- src/Web/Users/Persistent/Definitions.hs +0/−2
- users-persistent.cabal +3/−4
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2015 Alexander Thiemann <mail@athiemann.net>+Copyright (c) 2015 - 2016 Alexander Thiemann <mail@athiemann.net> Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the
src/Web/Users/Persistent.hs view
@@ -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 ()
src/Web/Users/Persistent/Definitions.hs view
@@ -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
users-persistent.cabal view
@@ -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 <http://hackage.haskell.org/package/persistent persistent> for <http://hackage.haskell.org/package/users the "users" library>.@@ -17,7 +17,7 @@ license-file: LICENSE author: Alexander Thiemann <mail@athiemann.net> maintainer: Alexander Thiemann <mail@athiemann.net>-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,