snaplet-persistent (empty) → 0.2
raw patch · 9 files changed
+601/−0 lines, 9 filesdep +MonadCatchIO-transformersdep +basedep +bytestringsetup-changed
Dependencies added: MonadCatchIO-transformers, base, bytestring, clientsession, configurator, errors, heist, lens, monad-logger, mtl, persistent, persistent-postgresql, persistent-template, readable, resource-pool-catchio, resourcet, safe, snap, text, time, transformers, unordered-containers
Files
- LICENSE +26/−0
- Setup.hs +3/−0
- resources/auth/devel.cfg +18/−0
- resources/db/devel.cfg +3/−0
- schema.txt +20/−0
- snaplet-persistent.cabal +64/−0
- src/Snap/Snaplet/Auth/Backends/Persistent.hs +255/−0
- src/Snap/Snaplet/Auth/Backends/Persistent/Types.hs +23/−0
- src/Snap/Snaplet/Persistent.hs +189/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2012, Soostone Inc++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++Redistributions of source code must retain the above copyright notice, this+list of conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright notice, this+list of conditions and the following disclaimer in the documentation and/or+other materials provided with the distribution.++Neither the name of the authors nor the names of its contributors may be used+to endorse or promote products derived from this software without specific+prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ resources/auth/devel.cfg view
@@ -0,0 +1,18 @@+# Currently this option is not enforced. See current auth documentation for+# more information.+minPasswordLen = 8++# Name of the cookie to use for remembering the logged in user.+rememberCookie = "_remember"++# Number of seconds of inactivity before the user is logged out. If ommitted,+# the user will remain logged in until the end of the session.+rememberPeriod = 1209600 # 2 weeks++# Lockout strategy. The first value is the max number of invalid login+# attempts before lockout. The second value is how long the locked lasts. If+# ommitted, then incorrect passwords will never result in lockout.+# lockout = [5, 86400]++# File where the auth encryption key is stored.+siteKey = "site_key.txt"
+ resources/db/devel.cfg view
@@ -0,0 +1,3 @@+postgre-con-str = "host='localhost' dbname='snap-test' user='guest' password='password1'"+postgre-pool-size = 3+
+ schema.txt view
@@ -0,0 +1,20 @@+SnapAuthUser+ login Text + email Text default=''+ password Text+ activatedAt UTCTime Maybe default=now()+ suspendedAt UTCTime Maybe default=now()+ rememberToken Text Maybe+ loginCount Int+ failedLoginCount Int+ lockedOutUntil UTCTime Maybe default=now()+ currentLoginAt UTCTime Maybe default=now()+ lastLoginAt UTCTime Maybe default=now()+ currentIp Text Maybe+ lastIp Text Maybe + createdAt UTCTime default=now()+ updatedAt UTCTime default=now()+ resetToken Text Maybe+ resetRequestedAt UTCTime Maybe+ roles String+ meta String
+ snaplet-persistent.cabal view
@@ -0,0 +1,64 @@+name: snaplet-persistent+version: 0.2+synopsis: persistent snaplet for the Snap Framework+description: Snaplet support for using the Postgresql database+ with a Snap Framework application via the persistent+ package. It also includes an authentication backend.+license: BSD3+license-file: LICENSE+author: Soostone Inc. Ozgun Ataman, Doug Beardsley+maintainer: ozataman@gmail.com, mightybyte@gmail.com+build-type: Simple+cabal-version: >= 1.6+homepage: https://github.com/mightybyte/snaplet-persistent+category: Web, Snap++extra-source-files: LICENSE++data-files:+ schema.txt+ resources/db/devel.cfg+ resources/auth/devel.cfg++source-repository head+ type: git+ location: https://github.com/mightybyte/snaplet-persistent.git++Library+ hs-source-dirs: src++ exposed-modules:+ Snap.Snaplet.Persistent+ Snap.Snaplet.Auth.Backends.Persistent++ other-modules:+ Snap.Snaplet.Auth.Backends.Persistent.Types + Paths_snaplet_persistent++ build-depends:+ base >= 4 && < 5,+ bytestring >= 0.9.1 && < 0.11,+ clientsession >= 0.7.2 && < 0.10,+ configurator >= 0.2 && < 0.3,+ heist >= 0.12 && < 0.13,+ lens >= 3.7.0.1 && < 3.10,+ errors >= 1.4 && < 1.5,+ MonadCatchIO-transformers >= 0.3 && < 0.4,+ monad-logger >= 0.2.4 && < 0.4,+ mtl >= 2 && < 3,+ persistent >= 1.2 && < 1.3,+ persistent-postgresql >= 1.2 && < 1.3,+ persistent-template >= 1.2 && < 1.3,+ readable >= 0.1 && < 0.2,+ resource-pool-catchio >= 0.2 && < 0.3,+ resourcet >= 0.4 && < 0.5,+ safe >= 0.3 && < 0.4,+ snap >= 0.11 && < 0.13,+ text >= 0.11 && < 0.12,+ time >= 1.1 && < 1.5,+ transformers >= 0.2 && < 0.4,+ unordered-containers >= 0.2 && < 0.3+++ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields+ -fno-warn-orphans -fno-warn-unused-do-bind
+ src/Snap/Snaplet/Auth/Backends/Persistent.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+++module Snap.Snaplet.Auth.Backends.Persistent+-- ( module Snap.Snaplet.Auth.Backends.Persistent+ ( PersistAuthManager+ , initPersistAuthManager+ , initPersistAuthManager'+ , authEntityDefs++ -- * Persistent Auth Data Types+ -- $datatypes+ , module Snap.Snaplet.Auth.Backends.Persistent.Types+-- , SnapAuthUserGeneric(..)+-- , SnapAuthUser+-- , SnapAuthUserId+ , db2au+ , dbUserSplices+ , userDBKey+ , textPassword+ ) where++------------------------------------------------------------------------------+import Control.Monad+import Control.Monad.Trans+import qualified Data.HashMap.Strict as HM+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time+import Database.Persist+import Database.Persist.Postgresql+import Database.Persist.Quasi+import Database.Persist.TH hiding (derivePersistField)+import Heist.Compiled+import Paths_snaplet_persistent+import Safe+import Snap.Snaplet+import Snap.Snaplet.Auth+import Snap.Snaplet.Persistent+import Snap.Snaplet.Session+import Web.ClientSession (getKey)+------------------------------------------------------------------------------+import Snap.Snaplet.Auth.Backends.Persistent.Types +++------------------------------------------------------------------------------+-- | The list of entity definitions this snaplet exposes. You need+-- them so that you can append to your application's list of+-- entity definitions and perform the migration in one block.+--+-- See how this example combined an app's own entity definitions and+-- the auth snaplet's in one migration block:+--+-- > share [mkMigrate "migrateAll"] $+-- > authEntityDefs +++-- > $(persistFileWith lowerCaseSettings "schema.txt")+authEntityDefs :: [EntityDef SqlType]+authEntityDefs = $(persistFileWith lowerCaseSettings "schema.txt")+++-- $datatypes+--+-- Persistent creates its own data types mirroring the database schema, so we+-- have to export this extra layer of types and conversion to 'AuthUser'.+++------------------------------------------------------------------------------+-- | Function to convert a 'SnapAuthUser' entity into the auth snaplet's+-- 'AuthUser'.+db2au :: Entity SnapAuthUser -> AuthUser+db2au (Entity (Key k) SnapAuthUser{..}) = AuthUser+ { userId = Just . UserId . fromPersistValue' $ k+ , userLogin = snapAuthUserLogin+ , userEmail = Just snapAuthUserEmail+ , userPassword = Just . Encrypted . T.encodeUtf8+ $ snapAuthUserPassword+ , userActivatedAt = snapAuthUserActivatedAt+ , userSuspendedAt = snapAuthUserSuspendedAt+ , userRememberToken = snapAuthUserRememberToken+ , userLoginCount = snapAuthUserLoginCount+ , userFailedLoginCount = snapAuthUserFailedLoginCount+ , userLockedOutUntil = snapAuthUserLockedOutUntil+ , userCurrentLoginAt = snapAuthUserCurrentLoginAt+ , userLastLoginAt = snapAuthUserLastLoginAt+ , userCurrentLoginIp = T.encodeUtf8 `fmap` snapAuthUserCurrentIp+ , userLastLoginIp = T.encodeUtf8 `fmap` snapAuthUserLastIp+ , userCreatedAt = Just snapAuthUserCreatedAt+ , userUpdatedAt = Just snapAuthUserUpdatedAt+ , userResetToken = snapAuthUserResetToken+ , userResetRequestedAt = snapAuthUserResetRequestedAt+ , userRoles = []+ , userMeta = HM.empty+ }+++------------------------------------------------------------------------------+-- | Splices for 'SnapAuthUser' that are equivalent to the ones for+-- 'AuthUser'.+dbUserSplices :: Monad n+ => [(Text, Promise (Entity SnapAuthUser) -> Splice n)]+dbUserSplices = repromise (return . db2au) userCSplices+++data PersistAuthManager = PAM {+ pamPool :: ConnectionPool+ }+++------------------------------------------------------------------------------+-- | Initializer that gets AuthSettings from a config file.+initPersistAuthManager :: SnapletLens b SessionManager+ -> ConnectionPool+ -> SnapletInit b (AuthManager b)+initPersistAuthManager l pool = make $ do+ aus <- authSettingsFromConfig+ initHelper aus l pool++++------------------------------------------------------------------------------+-- | Initializer that lets you specify AuthSettings.+initPersistAuthManager' :: AuthSettings+ -> SnapletLens b SessionManager+ -> ConnectionPool+ -> SnapletInit b (AuthManager b)+initPersistAuthManager' aus l pool = make $ initHelper aus l pool+++make :: Initializer b v v -> SnapletInit b v+make = makeSnaplet "persist-auth" description datadir+ where+ description =+ "A snaplet providing user authentication support using Persist"+ datadir = Just $ liftM (++"/resources/auth") getDataDir+++initHelper :: AuthSettings+ -> SnapletLens b SessionManager+ -> ConnectionPool+ -> Initializer b (AuthManager b) (AuthManager b)+initHelper aus l pool = liftIO $ do+ key <- getKey (asSiteKey aus)+ rng <- liftIO mkRNG+ return $ AuthManager {+ backend = PAM pool+ , session = l+ , activeUser = Nothing+ , minPasswdLen = asMinPasswdLen aus+ , rememberCookieName = asRememberCookieName aus+ , rememberPeriod = asRememberPeriod aus+ , siteKey = key+ , lockout = asLockout aus+ , randomNumberGenerator = rng }++++readT :: Text -> Int+readT = readNote "Can't read text" . T.unpack+++------------------------------------------------------------------------------+-- | Get the db key from an 'AuthUser'+userDBKey :: AuthUser -> Maybe SnapAuthUserId+userDBKey au = case userId au of+ Nothing -> Nothing+ Just (UserId k) -> Just . mkKey $ (readT k :: Int)+++------------------------------------------------------------------------------+textPassword :: Password -> Text+textPassword (Encrypted bs) = T.decodeUtf8 bs+textPassword (ClearText bs) = T.decodeUtf8 bs+++------------------------------------------------------------------------------+-- |+instance IAuthBackend PersistAuthManager where+ save PAM{..} au@AuthUser{..} = do+ now <- liftIO getCurrentTime+ pw <- encryptPassword $ fromMaybe (ClearText "") userPassword+ withPool pamPool $ do+ case userId of+ Nothing -> do+ insert $ SnapAuthUser+ userLogin+ (fromMaybe "" userEmail)+ (textPassword pw)+ userActivatedAt+ userSuspendedAt+ userRememberToken+ userLoginCount+ userFailedLoginCount+ userLockedOutUntil+ userCurrentLoginAt+ userLastLoginAt+ (fmap T.decodeUtf8 userCurrentLoginIp)+ (fmap T.decodeUtf8 userLastLoginIp)+ now+ now+ Nothing+ Nothing+ ""+ ""+ return $ Right $ au {userUpdatedAt = Just now}+ Just (UserId t) -> do+ let k = (mkKey (readT t :: Int))+ update k $ catMaybes+ [ Just $ SnapAuthUserLogin =. userLogin+ , Just $ SnapAuthUserEmail =. fromMaybe "" userEmail+ , fmap (\ (Encrypted p) -> SnapAuthUserPassword =. T.decodeUtf8 p)+ userPassword+ , Just $ SnapAuthUserActivatedAt =. userActivatedAt+ , Just $ SnapAuthUserSuspendedAt =. userSuspendedAt+ , Just $ SnapAuthUserRememberToken =. userRememberToken+ , Just $ SnapAuthUserLoginCount =. userLoginCount+ , Just $ SnapAuthUserFailedLoginCount =. userFailedLoginCount+ , Just $ (SnapAuthUserLockedOutUntil =.) userLockedOutUntil+ , Just $ (SnapAuthUserCurrentLoginAt =.) userCurrentLoginAt+ , Just $ (SnapAuthUserLastLoginAt =.) userLastLoginAt+ , Just $ SnapAuthUserCurrentIp =. (T.decodeUtf8 `fmap` userCurrentLoginIp)+ , Just $ (SnapAuthUserLastIp =.) (T.decodeUtf8 `fmap` userLastLoginIp)+ , fmap (SnapAuthUserCreatedAt =.) userCreatedAt+ , Just $ SnapAuthUserUpdatedAt =. now+ , Just $ SnapAuthUserResetToken =. userResetToken+ , Just $ SnapAuthUserResetRequestedAt =. userResetRequestedAt+ , Just $ SnapAuthUserRoles =. show userRoles+ ]+ return $ Right $ au {userUpdatedAt = Just now}+++ destroy = fail "We don't allow destroying users."++ lookupByUserId PAM{..} (UserId t) = withPool pamPool $ do+ let k = (mkKey (readT t :: Int))+ u <- get k+ case u of+ Nothing -> return Nothing+ Just u' -> return . Just $ db2au $ Entity k u'++ lookupByLogin PAM{..} login = withPool pamPool $ do+ res <- selectFirst [SnapAuthUserLogin ==. login] []+ return $ fmap db2au res++ lookupByRememberToken PAM{..} token = withPool pamPool $ do+ res <- selectFirst [SnapAuthUserRememberToken ==. Just token] []+ return $ fmap db2au res+
+ src/Snap/Snaplet/Auth/Backends/Persistent/Types.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+++module Snap.Snaplet.Auth.Backends.Persistent.Types where++------------------------------------------------------------------------------+import Data.Text (Text)+import Data.Time+import Database.Persist+import Database.Persist.Quasi+import Database.Persist.TH hiding (derivePersistField)+------------------------------------------------------------------------------+++share [mkPersist sqlSettings, mkMigrate "migrateAuth"]+ $(persistFileWith lowerCaseSettings "schema.txt")+
+ src/Snap/Snaplet/Persistent.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Snap.Snaplet.Persistent+ ( initPersist+ , PersistState(..)+ , HasPersistPool(..)+ , mkPgPool+ , mkSnapletPgPool+ , runPersist+ , withPool++ -- * Utility Functions+ , mkKey+ , mkKeyBS+ , mkKeyT+ , showKey+ , showKeyBS+ , mkInt+ , mkWord64+ , followForeignKey+ , fromPersistValue'+ ) where++-------------------------------------------------------------------------------+import Control.Monad.Logger+import Control.Monad.State+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Resource+import Data.ByteString (ByteString)+import Data.Configurator+import Data.Configurator.Types+import Data.Maybe+import Data.Readable+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Word+import Database.Persist+import Database.Persist.Postgresql hiding (get)+import qualified Database.Persist.Postgresql as DB+import Paths_snaplet_persistent+import Snap.Snaplet+-------------------------------------------------------------------------------+++-------------------------------------------------------------------------------+newtype PersistState = PersistState { persistPool :: ConnectionPool }+++-------------------------------------------------------------------------------+-- | Implement this type class to have any monad work with snaplet-persistent.+-- A default instance is provided for (Handler b PersistState).+class MonadIO m => HasPersistPool m where+ getPersistPool :: m ConnectionPool+++instance HasPersistPool m => HasPersistPool (NoLoggingT m) where+ getPersistPool = runNoLoggingT getPersistPool++instance HasPersistPool (Handler b PersistState) where+ getPersistPool = gets persistPool++instance MonadIO m => HasPersistPool (ReaderT ConnectionPool m) where+ getPersistPool = ask+++-------------------------------------------------------------------------------+-- | Initialize Persistent with an initial SQL function called right+-- after the connection pool has been created. This is most useful for+-- calling migrations upfront right after initialization.+--+-- Example:+--+-- > initPersist (runMigrationUnsafe migrateAll)+--+-- where migrateAll is the migration function that was auto-generated+-- by the QQ statement in your persistent schema definition in the+-- call to 'mkMigrate'.+initPersist :: SqlPersistT (NoLoggingT IO) a -> SnapletInit b PersistState+initPersist migration = makeSnaplet "persist" description datadir $ do+ p <- mkSnapletPgPool+ liftIO . runNoLoggingT $ runSqlPool migration p+ return $ PersistState p+ where+ description = "Snaplet for persistent DB library"+ datadir = Just $ liftM (++"/resources/db") getDataDir+++-------------------------------------------------------------------------------+-- | Constructs a connection pool from Config.+mkPgPool :: MonadIO m => Config -> m ConnectionPool+mkPgPool conf = do+ pgConStr <- liftIO $ require conf "postgre-con-str"+ cons <- liftIO $ require conf "postgre-pool-size"+ createPostgresqlPool pgConStr cons+++-------------------------------------------------------------------------------+-- | Conscruts a connection pool in a snaplet context.+mkSnapletPgPool :: (MonadIO (m b v), MonadSnaplet m) => m b v ConnectionPool+mkSnapletPgPool = do+ conf <- getSnapletUserConfig+ mkPgPool conf+++-------------------------------------------------------------------------------+-- | Runs a SqlPersist action in any monad with a HasPersistPool instance.+runPersist :: (HasPersistPool m)+ => SqlPersistT (ResourceT (NoLoggingT IO)) b+ -- ^ Run given Persistent action in the defined monad.+ -> m b+runPersist action = do+ pool <- getPersistPool+ withPool pool action+++------------------------------------------------------------------------------+-- | Run a database action+withPool :: MonadIO m+ => ConnectionPool+ -> SqlPersist (ResourceT (NoLoggingT IO)) a -> m a+withPool cp f = liftIO . runNoLoggingT . runResourceT $ runSqlPool f cp+++-------------------------------------------------------------------------------+-- | Make a Key from an Int.+mkKey :: Int -> Key entity+mkKey = Key . toPersistValue+++-------------------------------------------------------------------------------+-- | Makes a Key from a ByteString. Calls error on failure.+mkKeyBS :: ByteString -> Key entity+mkKeyBS = mkKey . fromMaybe (error "Can't ByteString value") . fromBS+++-------------------------------------------------------------------------------+-- | Makes a Key from Text. Calls error on failure.+mkKeyT :: Text -> Key entity+mkKeyT = mkKey . fromMaybe (error "Can't Text value") . fromText+++-------------------------------------------------------------------------------+-- | Makes a Text representation of a Key.+showKey :: Key e -> Text+showKey = T.pack . show . mkInt+++-------------------------------------------------------------------------------+-- | Makes a ByteString representation of a Key.+showKeyBS :: Key e -> ByteString+showKeyBS = T.encodeUtf8 . showKey+++-------------------------------------------------------------------------------+-- | Converts a Key to Int. Fails with error if the conversion fails.+mkInt :: Key a -> Int+mkInt = fromPersistValue' . unKey+++-------------------------------------------------------------------------------+-- | Converts a Key to Word64. Fails with error if the conversion fails.+mkWord64 :: Key a -> Word64+mkWord64 = fromPersistValue' . unKey+++-------------------------------------------------------------------------------+-- Converts a PersistValue to a more concrete type. Calls error if the+-- conversion fails.+fromPersistValue' :: PersistField c => PersistValue -> c+fromPersistValue' = either (const $ error "Persist conversion failed") id+ . fromPersistValue+++------------------------------------------------------------------------------+-- | Follows a foreign key field in one entity and retrieves the corresponding+-- entity from the database.+followForeignKey :: (PersistEntity a, HasPersistPool m,+ PersistEntityBackend a ~ SqlBackend)+ => (t -> Key a) -> Entity t -> m (Maybe (Entity a))+followForeignKey toKey (Entity _ val) = do+ let key' = toKey val+ mval <- runPersist $ DB.get key'+ return $ fmap (Entity key') mval++