users-persistent 0.3.0.0 → 0.4.0.0
raw patch · 3 files changed
+76/−55 lines, 3 filesdep +transformersdep ~users
Dependencies added: transformers
Dependency ranges changed: users
Files
- src/Web/Users/Persistent.hs +24/−53
- src/Web/Users/Persistent/Definitions.hs +48/−0
- users-persistent.cabal +4/−2
src/Web/Users/Persistent.hs view
@@ -1,25 +1,18 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-} module Web.Users.Persistent (LoginId, Persistent(..)) where import Web.Users.Types+import Web.Users.Persistent.Definitions -import Control.Applicative ((<$>), (<|>))+import Control.Applicative ((<|>)) import Control.Monad+import Control.Monad.Trans.Maybe import Control.Monad.Reader #if MIN_VERSION_mtl(2,2,0) import Control.Monad.Except@@ -31,38 +24,11 @@ import Data.Time.Clock import Database.Persist import Database.Persist.Sql-import Database.Persist.TH-import qualified Data.ByteString.Char8 as BSC 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 -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|-Login- createdAt UTCTime- username T.Text- email T.Text- password T.Text- active Bool- more BSC.ByteString- UniqueUsername username- UniqueEmail email- deriving Show- deriving Eq- deriving Typeable-LoginToken- token T.Text- tokenType T.Text- createdAt UTCTime- validUntil UTCTime- owner LoginId- UniqueToken token- UniqueTypedToken token tokenType- deriving Show- deriving Eq- deriving Typeable-|] #if MIN_VERSION_base(4,7,0) deriving instance Typeable Key@@ -162,24 +128,27 @@ do now <- getCurrentTime let usr = mkUser now runPersistent conn $- do mFst <- selectFirst ([LoginUsername ==. loginUsername usr] ||. [LoginEmail ==. loginEmail usr]) []- case mFst of- Just _ -> return $ Left UsernameOrEmailAlreadyTaken- Nothing -> Right <$> insert usr+ do mUsername <- selectFirst [LoginUsername ==. loginUsername usr] []+ mEmailAddress <- selectFirst [LoginEmail ==. loginEmail usr] []+ case (mUsername, mEmailAddress) of+ (Just _, Just _) -> return $ Left UsernameAndEmailAlreadyTaken+ (Just _, _) -> return $ Left UsernameAlreadyTaken+ (Nothing, Just _) -> return $ Left EmailAlreadyTaken+ (Nothing, Nothing) -> Right <$> insert usr updateUser conn userId updateFun = do mUser <- getUserById conn userId case mUser of Nothing ->- return $ Left UserDoesntExit+ return $ Left UserDoesntExist Just origUser -> runErrorT $ do let newUser = updateFun origUser when (u_name newUser /= u_name origUser) $ do counter <- liftIO $ runPersistent conn $ count [LoginUsername ==. u_name newUser]- when (counter /= 0) $ throwError UsernameOrEmailAlreadyExists+ when (counter /= 0) $ throwError UsernameAlreadyExists when (u_email newUser /= u_email origUser) $ do counter <- liftIO $ runPersistent conn $ count [LoginEmail ==. u_email newUser]- when (counter /= 0) $ throwError UsernameOrEmailAlreadyExists+ 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) ]@@ -189,15 +158,12 @@ deleteUser conn userId = runPersistent conn $ delete userId withAuthUser conn userOrEmail authFn action =- runPersistent conn $- do mFst <- selectFirst ([LoginUsername ==. userOrEmail] ||. [LoginEmail ==. userOrEmail]) []- case mFst of- Nothing -> return Nothing- Just login ->- do user <- unpackLogin' (entityVal login)- if authFn user- then liftIO $ Just <$> action (entityKey login)- else return Nothing+ runMaybeT $+ do login <- MaybeT . liftIO . runPersistent conn+ $ selectFirst ([LoginUsername ==. userOrEmail] ||. [LoginEmail ==. userOrEmail]) []+ 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 -> SessionId <$> createToken conn "session" userId sessionTtl@@ -208,6 +174,11 @@ Just userId -> do extendToken conn "session" sessionId extendTime return (Just userId)+ createSession conn userId sessionTtl =+ do mUser <- getUserById conn userId+ case (mUser :: Maybe (User Value)) of+ Nothing -> return Nothing+ Just _ -> Just . SessionId <$> createToken conn "session" userId sessionTtl destroySession conn (SessionId sessionId) = deleteToken conn "session" sessionId requestPasswordReset conn userId timeToLive = do token <- createToken conn "password_reset" userId timeToLive
+ src/Web/Users/Persistent/Definitions.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Web.Users.Persistent.Definitions where++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|+Login+ createdAt UTCTime+ username T.Text+ email T.Text+ password T.Text+ active Bool+ more BSC.ByteString+ UniqueUsername username+ UniqueEmail email+ deriving Show+ deriving Eq+ deriving Typeable+LoginToken+ token T.Text+ tokenType T.Text+ createdAt UTCTime+ validUntil UTCTime+ owner LoginId+ UniqueToken token+ UniqueTypedToken token tokenType+ deriving Show+ deriving Eq+ deriving Typeable+|]
users-persistent.cabal view
@@ -1,5 +1,5 @@ name: users-persistent-version: 0.3.0.0+version: 0.4.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>.@@ -28,10 +28,12 @@ library exposed-modules: Web.Users.Persistent+ Web.Users.Persistent.Definitions build-depends: base >=4.6 && <5, persistent >=2.0, persistent-template >=2.1,- users >=0.3,+ users >=0.4,+ transformers >=0.4, mtl >=2.1, aeson >=0.7, time >=1.4,