diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/resources/auth/devel.cfg b/resources/auth/devel.cfg new file mode 100644 --- /dev/null +++ b/resources/auth/devel.cfg @@ -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" diff --git a/resources/db/devel.cfg b/resources/db/devel.cfg new file mode 100644 --- /dev/null +++ b/resources/db/devel.cfg @@ -0,0 +1,3 @@ +postgre-con-str = "host='localhost' dbname='snap-test' user='guest' password='password1'" +postgre-pool-size = 3 + diff --git a/schema.txt b/schema.txt new file mode 100644 --- /dev/null +++ b/schema.txt @@ -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 diff --git a/snaplet-persistent.cabal b/snaplet-persistent.cabal new file mode 100644 --- /dev/null +++ b/snaplet-persistent.cabal @@ -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 diff --git a/src/Snap/Snaplet/Auth/Backends/Persistent.hs b/src/Snap/Snaplet/Auth/Backends/Persistent.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/Backends/Persistent.hs @@ -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 + diff --git a/src/Snap/Snaplet/Auth/Backends/Persistent/Types.hs b/src/Snap/Snaplet/Auth/Backends/Persistent/Types.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/Backends/Persistent/Types.hs @@ -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") + diff --git a/src/Snap/Snaplet/Persistent.hs b/src/Snap/Snaplet/Persistent.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Persistent.hs @@ -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 + +