module Web.Users.Persistent (LoginId, Persistent(..)) where
import Web.Users.Types
import Web.Users.Persistent.Definitions
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
#else
import Control.Monad.Error
#endif
import Data.Typeable
import Data.Time.Clock
import Database.Persist
import Database.Persist.Sql
import qualified Database.Esqueleto as E
import qualified Data.Text as T
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
#if MIN_VERSION_base(4,7,0)
deriving instance Typeable Key
#else
deriving instance Typeable1 Key
#endif
#if MIN_VERSION_mtl(2,2,0)
type ErrorT = ExceptT
runErrorT :: ErrorT e m a -> m (Either e a)
runErrorT = runExceptT
#else
instance Error UpdateUserError where
noMsg = error "Calling fail not supported"
strMsg = error "Calling fail not supported"
#endif
packLogin :: Monad m => User -> m (UTCTime -> Login)
packLogin usr =
do p <-
case u_password usr of
PasswordHash p -> return p
_ -> fail "Invalid password! Not hashed!"
return $ \t ->
Login
{ loginUsername = u_name usr
, loginEmail = u_email usr
, loginPassword = p
, loginActive = u_active usr
, loginCreatedAt = t
}
unpackLogin :: Login -> User
unpackLogin l =
(unpackLogin' l) { u_password = PasswordHidden }
unpackLogin' :: Login -> User
unpackLogin' l =
User
{ u_name = loginUsername l
, u_email = loginEmail l
, u_password = PasswordHash (loginPassword l)
, u_active = loginActive l
}
mkTuple :: Entity Login -> (LoginId, User)
mkTuple entity =
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
type UserId Persistent = LoginId
initUserBackend conn =
runPersistent conn $ runMigration migrateAll
destroyUserBackend conn =
runPersistent conn $
do _ <- rawExecute "DROP TABLE IF EXISTS \"login\";" []
_ <- rawExecute "DROP TABLE IF EXISTS \"login_token\";" []
return ()
housekeepBackend conn =
do now <- getCurrentTime
runPersistent conn $ deleteWhere [LoginTokenValidUntil <=. now]
getUserIdByName conn userOrEmail =
runPersistent conn $
do mUserA <- getBy (UniqueUsername userOrEmail)
mUserB <- getBy (UniqueEmail userOrEmail)
return $ fmap entityKey (mUserA <|> mUserB)
getUserById conn loginId =
runPersistent conn $
do mUser <- get loginId
return $ fmap unpackLogin mUser
listUsers conn mLimit sorter =
runPersistent conn $
do let orderOpts =
case sorter of
SortAsc t -> compileField t Asc
SortDesc t -> compileField t Desc
xs <-
case mLimit of
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])
createUser conn l =
case packLogin l of
Nothing -> return $ Left InvalidPassword
Just mkUser ->
do now <- getCurrentTime
let usr = mkUser now
runPersistent conn $
do mUsername <- selectFirst [LoginUsername ==. loginUsername usr] []
email <- emailInUse (loginEmail usr)
case (mUsername, email) of
(Just _, True) -> return $ Left UsernameAndEmailAlreadyTaken
(Just _, _) -> return $ Left UsernameAlreadyTaken
(Nothing, True) -> return $ Left EmailAlreadyTaken
(Nothing, False) -> Right <$> insert usr
updateUser conn userId updateFun =
do mUser <- getUserById conn userId
case mUser of
Nothing ->
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 UsernameAlreadyExists
when (u_email newUser /= u_email origUser) $
do emailUsed <- liftIO $ runPersistent conn $ emailInUse (u_email newUser)
when emailUsed $ throwError EmailAlreadyExists
liftIO $ runPersistent conn $
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 ()
deleteUser conn userId =
runPersistent conn $ delete userId
withAuthUser conn userOrEmail authFn action =
runMaybeT $
do login <- MaybeT . liftIO . runPersistent conn
$ selectFirst ([LoginUsername ==. userOrEmail] ||. [LoginEmail ==. userOrEmail]) []
let user = unpackLogin' $ entityVal login
guard $ authFn user
liftIO . action . entityKey $ login
authUser conn userOrEmail pwd sessionTtl =
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
case mUser of
Nothing -> return Nothing
Just userId ->
do extendToken conn "session" sessionId extendTime
return (Just userId)
createSession conn userId sessionTtl =
do mUser <- getUserById conn userId
case (mUser :: Maybe User) 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
return $ PasswordResetToken token
requestActivationToken conn userId timeToLive =
do token <- createToken conn "activation" userId timeToLive
return $ ActivationToken token
activateUser conn (ActivationToken token) =
do mUser <- getTokenOwner conn "activation" token
case mUser of
Nothing ->
return $ Left TokenInvalid
Just userId ->
do _ <-
updateUser conn userId $ \user -> user { u_active = True }
deleteToken conn "activation" token
return $ Right ()
verifyPasswordResetToken conn (PasswordResetToken token) =
do mUser <- getTokenOwner conn "password_reset" token
case mUser of
Nothing -> return Nothing
Just userId -> getUserById conn userId
applyNewPassword conn (PasswordResetToken token) password =
do mUser <- getTokenOwner conn "password_reset" token
case mUser of
Nothing ->
return $ Left TokenInvalid
Just userId ->
do _ <-
updateUser conn userId $ \user -> user { u_password = password }
deleteToken conn "password_reset" token
return $ Right ()
emailInUse :: MonadIO m => T.Text -> ReaderT SqlBackend m Bool
emailInUse email =
do emailMatches <-
E.select $
E.from $ \login ->
do E.where_ $ E.lower_ (login E.^. LoginEmail)
E.==. E.lower_ (E.val email)
E.limit 1
return login
return (not $ null emailMatches)
createToken :: Persistent -> String -> LoginId -> NominalDiffTime -> IO T.Text
createToken conn tokenType userId timeToLive =
runPersistent conn $
do tok <- liftM (T.pack . UUID.toString) $ liftIO $ UUID.nextRandom
now <- liftIO getCurrentTime
_ <- insert $ LoginToken tok (T.pack tokenType) now (timeToLive `addUTCTime` now) userId
return tok
deleteToken :: Persistent -> String -> T.Text -> IO ()
deleteToken conn tokenType token =
runPersistent conn $
case UUID.fromString (T.unpack token) of
Nothing -> return ()
Just _ ->
do deleteBy (UniqueTypedToken token (T.pack tokenType))
return ()
extendToken :: Persistent -> String -> T.Text -> NominalDiffTime -> IO ()
extendToken conn tokenType token timeToLive =
runPersistent conn $
case UUID.fromString (T.unpack token) of
Nothing -> return ()
Just _ ->
do let selC = [LoginTokenTokenType ==. T.pack tokenType, LoginTokenToken ==. token]
m <-
selectFirst selC [Desc LoginTokenValidUntil]
case m of
Nothing -> return ()
Just t ->
do let validUntil =
loginTokenValidUntil (entityVal t)
now <- liftIO getCurrentTime
let extendedValid = timeToLive `addUTCTime` now
when (extendedValid > validUntil) $
updateWhere selC [LoginTokenValidUntil =. extendedValid]
return ()
getTokenOwner :: Persistent -> String -> T.Text -> IO (Maybe LoginId)
getTokenOwner conn tokenType token =
runPersistent conn $
case UUID.fromString (T.unpack token) of
Nothing -> return Nothing
Just _ ->
do now <- liftIO $ getCurrentTime
m <- selectFirst [LoginTokenTokenType ==. T.pack tokenType, LoginTokenToken ==. token, LoginTokenValidUntil >. now] []
return $ fmap (loginTokenOwner . entityVal) m