users-persistent (empty) → 0.3.0.0
raw patch · 5 files changed
+379/−0 lines, 5 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, hspec, monad-logger, mtl, persistent, persistent-sqlite, persistent-template, temporary, text, time, users, users-persistent, users-test, uuid
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- src/Web/Users/Persistent.hs +279/−0
- test/Spec.hs +19/−0
- users-persistent.cabal +59/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 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+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Web/Users/Persistent.hs view
@@ -0,0 +1,279 @@+{-# 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 Control.Applicative ((<$>), (<|>))+import Control.Monad+import Control.Monad.Reader+#if MIN_VERSION_mtl(2,2,0)+import Control.Monad.Except+#else+import Control.Monad.Error+#endif+import Data.Aeson+import Data.Typeable+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+#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+-- a hack... :-(+instance Error UpdateUserError where+ noMsg = error "Calling fail not supported"+ strMsg = error "Calling fail not supported"+#endif++packLogin :: (Monad m, ToJSON a) => User a -> 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+ , loginMore = BSL.toStrict $ encode (u_more usr)+ , loginCreatedAt = t+ }++unpackLogin :: (FromJSON a, Monad m) => Login -> m (User a)+unpackLogin l =+ do up <- unpackLogin' l+ return $ up { u_password = PasswordHidden }++unpackLogin' :: (FromJSON a, Monad m) => Login -> m (User a)+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+ }++mkTuple :: (FromJSON a, Monad m) => Entity Login -> m (LoginId, User a)+mkTuple entity =+ do user <- unpackLogin (entityVal entity)+ return (entityKey entity, user)++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 $ join $ fmap unpackLogin mUser+ listUsers conn mLimit =+ runPersistent conn $+ do xs <-+ case mLimit of+ Nothing -> selectList [] []+ Just (start, lim) -> selectList [] [OffsetBy (fromIntegral start), LimitTo (fromIntegral lim)]+ mapM 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 mFst <- selectFirst ([LoginUsername ==. loginUsername usr] ||. [LoginEmail ==. loginEmail usr]) []+ case mFst of+ Just _ -> return $ Left UsernameOrEmailAlreadyTaken+ Nothing -> Right <$> insert usr+ updateUser conn userId updateFun =+ do mUser <- getUserById conn userId+ case mUser of+ Nothing ->+ return $ Left UserDoesntExit+ 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 (u_email newUser /= u_email origUser) $+ do counter <- liftIO $ runPersistent conn $ count [LoginEmail ==. u_email newUser]+ when (counter /= 0) $ throwError UsernameOrEmailAlreadyExists+ 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) ]+ case u_password newUser of+ PasswordHash p -> update userId [ LoginPassword =. p ]+ _ -> return ()+ 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+ authUser conn userOrEmail pwd sessionTtl =+ withAuthUser conn userOrEmail (\(user :: User Value) -> 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)+ 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 Value) -> 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 Value) -> user { u_password = password }+ deleteToken conn "password_reset" token+ return $ Right ()++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 now <- liftIO $ getCurrentTime+ updateWhere [LoginTokenToken ==. token, LoginTokenTokenType ==. (T.pack tokenType)] [LoginTokenValidUntil =. (timeToLive `addUTCTime` now)]+ 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
+ test/Spec.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Web.Users.TestSpec+import Web.Users.Persistent++import System.IO.Temp+import System.IO+import Control.Monad.Logger+import Database.Persist.Sqlite+import Test.Hspec+import qualified Data.Text as T++main :: IO ()+main =+ withSystemTempFile "tempBaseXXX.db" $ \fp hdl ->+ do hClose hdl+ pool <- runNoLoggingT $ createSqlitePool (T.pack fp) 5+ hspec $ makeUsersSpec (Persistent $ flip runSqlPool pool)
+ users-persistent.cabal view
@@ -0,0 +1,59 @@+name: users-persistent+version: 0.3.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>.+ .+ The package itself does not expose any bindings but provides an instance for 'UserStorageBackend'.+ .+ Usage:+ .+ > module Foo where+ > import Web.Users.Types+ > import Web.Users.Persistent+ > -- code goes here+homepage: https://github.com/agrafix/users+license: MIT+license-file: LICENSE+author: Alexander Thiemann <mail@athiemann.net>+maintainer: Alexander Thiemann <mail@athiemann.net>+copyright: (c) 2015 Alexander Thiemann+category: Data+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/agrafix/users.git++library+ exposed-modules: Web.Users.Persistent+ build-depends: base >=4.6 && <5,+ persistent >=2.0,+ persistent-template >=2.1,+ users >=0.3,+ mtl >=2.1,+ aeson >=0.7,+ time >=1.4,+ bytestring >=0.10,+ text >=1.2,+ uuid >=1.3+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -auto-all -Wall -fno-warn-orphans++test-suite users-persistent-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends:+ base >=4.6 && <5,+ hspec >=2.1,+ persistent-sqlite >=2.1,+ monad-logger >=0.3,+ temporary >=1.0,+ text,+ users-persistent,+ users-test+ ghc-options: -auto-all -Wall -fno-warn-orphans+ default-language: Haskell2010