snaplet-hasql 0.0.2 → 1.0.0
raw patch · 5 files changed
+325/−13 lines, 5 filesdep +aesondep +bytestringdep +clientsessiondep ~basedep ~hasqldep ~hasql-backend
Dependencies added: aeson, bytestring, clientsession, configurator, hasql-postgres, text, time
Dependency ranges changed: base, hasql, hasql-backend, lens, mtl, snap
Files
- resources/auth/devel.cfg +18/−0
- resources/devel.cfg +6/−0
- snaplet-hasql.cabal +27/−8
- src/Snap/Snaplet/Auth/Backends/Hasql.hs +247/−0
- src/Snap/Snaplet/Hasql.hs +27/−5
+ 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/devel.cfg view
@@ -0,0 +1,6 @@+# Max number of database connections; this should be set manually to best fit+# your use and environment.+maxConnections = 20++# Seconds to keep connections alive for when unused+connectionTimeout = 15
snaplet-hasql.cabal view
@@ -1,5 +1,5 @@ name: snaplet-hasql-version: 0.0.2+version: 1.0.0 synopsis: A Hasql snaplet license: MIT license-file: LICENSE@@ -8,14 +8,33 @@ category: Web build-type: Simple cabal-version: >=1.10+description: A hasql snaplet, including an auth backend.+homepage: https://github.com/mikeplus64/snaplet-hasql +data-files:+ resources/devel.cfg+ resources/auth/devel.cfg++source-repository head+ type: git+ location: https://github.com/mikeplus64/snaplet-hasql.git+ library- exposed-modules: Snap.Snaplet.Hasql- build-depends: base >=4.7 && <4.8, - lens >=4.7 && <5.0, - mtl >=2.2 && <2.3, - hasql >=0.7 && <0.8, - hasql-backend >=0.4 && <0.5, - snap >=0.13 && <0.15+ exposed-modules: Snap.Snaplet.Hasql,+ Snap.Snaplet.Auth.Backends.Hasql+ other-modules: Paths_snaplet_hasql+ build-depends: base >=4.7 && <5.0, + lens, + mtl >=2.2, + hasql >=0.7,+ hasql-backend >= 0.4,+ hasql-postgres >= 0.11,+ clientsession >= 0.9,+ configurator >= 0.3,+ time >= 1.5,+ text >= 1.0,+ snap >=0.13,+ bytestring >=0.10,+ aeson >= 0.8 hs-source-dirs: src default-language: Haskell2010
+ src/Snap/Snaplet/Auth/Backends/Hasql.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-|+Adapted from "snaplet-postgresql-simple"\'s auth module.++This module allows you to use the auth snaplet with your user database stored+in a Hasql database. When you run your application with this snaplet, a+config file will be copied into the the @snaplets/hasql-auth@ directory.+This file contains all of the configurable options for the snaplet and allows+you to change them without recompiling your application.++To use this snaplet in your application enable the session, postgres, and auth+snaplets as follows:++> data App = App+> { ... -- your own application state here+> , _sess :: Snaplet SessionManager+> , _db :: Snaplet (Pool s)+> , _auth :: Snaplet (AuthManager App)+> }++Then in your initializer you'll have something like this:++> d <- nestSnaplet "db" db $ hasqlInit+> a <- nestSnaplet "auth" auth $ initHasqlAuth sess d++A database table @snap_auth_users@ for users is created on initialisation.++-}+module Snap.Snaplet.Auth.Backends.Hasql where+------------------------------------------------------------------------------+import Control.Applicative+import Control.Lens+import Control.Monad+import Control.Monad.Trans+import Data.Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Foldable (fold)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Read as T+import Data.Time+import GHC.Generics+import Hasql+import Hasql.Backend (CxError, CxTx, CxValue, TxError)+import Paths_snaplet_hasql+import Prelude+import Snap+import Snap.Snaplet.Auth+import Snap.Snaplet.Session+import Web.ClientSession+------------------------------------------------------------------------------++newtype HasqlAuthManager s = HasqlAuthManager { pool :: Pool s }++------------------------------------------------------------------------------+-- | Initializer for the postgres backend to the auth snaplet.+--+initHasqlAuth+ :: (CxTx s, Show (CxError s), Show (TxError s), CxAuthUser s)+ => SnapletLens b SessionManager -- ^ Lens to the session snaplet+ -> Snaplet (Pool s) -- ^ The hasql snaplet+ -> SnapletInit b (AuthManager b)+initHasqlAuth sess db = makeSnaplet "hasql-auth" desc datadir $ do+ config <- getSnapletUserConfig+ authSettings <- authSettingsFromConfig+ liftIO (do+ key <- getKey (asSiteKey authSettings)+ let pool = db^#snapletValue+ manager = HasqlAuthManager pool+ Hasql.session pool (tx writeMode (unitEx defAuthTable))+ rng <- mkRNG+ return AuthManager+ { backend = manager+ , session = sess+ , activeUser = Nothing+ , minPasswdLen = asMinPasswdLen authSettings+ , rememberCookieName = asRememberCookieName authSettings+ , rememberPeriod = asRememberPeriod authSettings+ , siteKey = key+ , lockout = asLockout authSettings+ , randomNumberGenerator = rng+ })+ where+ desc = "A Hasql backend for user authentication"+ datadir = Just (fmap (++"/resources/auth") getDataDir)++-- | Default authentication table layout+defAuthTable :: Stmt c+defAuthTable =+ [stmt|CREATE TABLE IF NOT EXISTS snap_auth_user+ ( uid SERIAL PRIMARY KEY+ , login text UNIQUE NOT NULL+ , email text+ , password text+ , activated_at timestamptz+ , suspended_at timestamptz+ , remember_token text+ , login_count integer NOT NULL+ , failed_login_count integer NOT NULL+ , locked_out_until timestamptz+ , current_login_at timestamptz+ , last_login_at timestamptz+ , current_login_ip text+ , last_login_ip text+ , created_at timestamptz+ , updated_at timestamptz+ , reset_token text+ , reset_requested_at timestamptz+ , user_meta json NOT NULL+ )+ |]++type CxAuthUser c = ( CxValue c Text+ , CxValue c (Maybe Text)+ , CxValue c (Maybe UTCTime)+ , CxValue c Int+ , CxValue c ByteString+ , CxValue c (Maybe ByteString)+ , CxValue c Value)++userFromTuple+ ( Just . UserId . T.pack . (show :: Int -> String) -> userId, userLogin+ , userEmail, Just . Encrypted -> userPassword, userActivatedAt+ , userSuspendedAt, userRememberToken, userLoginCount, userFailedLoginCount+ , userLockedOutUntil, userCurrentLoginAt, userLastLoginAt+ , userCurrentLoginIp, userLastLoginIp, userCreatedAt, userUpdatedAt+ , userResetToken, userResetRequestedAt, Object userMeta) =+ AuthUser{userRoles = [], ..}++saveQuery :: CxAuthUser c => AuthUser -> Tx c s AuthUser+saveQuery u@AuthUser{..} =+ userFromTuple <$> singleEx (maybe insertQuery updateQuery userId)+ where+ -- YIKES+ passwordToText :: Password -> Text+ passwordToText (Encrypted bs) = T.decodeUtf8 bs+ passwordToText (ClearText bs) = error "Cannot save a ClearText password!"++ fromPassword :: ByteString -> Password+ fromPassword = Encrypted++ -- no userRoles - should there be?++ insertQuery =+ [stmt|INSERT INTO snap_auth_user+ VALUES(default,?,?,?,?, ?,?,?,?, ?,?,?, ?,?,?,?, ?,?,?)+ RETURNING snap_auth_user.* |]++ userLogin userEmail (fmap passwordToText userPassword)+ userActivatedAt userSuspendedAt userRememberToken userLoginCount+ userFailedLoginCount userLockedOutUntil userCurrentLoginAt+ userLastLoginAt userCurrentLoginIp userLastLoginIp userCreatedAt+ userUpdatedAt userResetToken userResetRequestedAt (Object userMeta)++ updateQuery uid =+ [stmt|UPDATE snap_auth_user+ SET login = ?+ , email = ?+ , password = ?+ , activated_at = ?+ , suspended_at = ?+ , remember_token = ?+ , login_count = ?+ , failed_login_count = ?+ , locked_out_until = ?+ , current_login_at = ?+ , last_login_at = ?+ , current_login_ip = ?+ , last_login_ip = ?+ , created_at = ?+ , updated_at = ?+ , reset_token = ?+ , reset_requested_at = ?+ , user_meta = ?+ WHERE uid = ?+ RETURNING snap_auth_user.* |]+ userLogin userEmail (fmap passwordToText userPassword)+ userActivatedAt userSuspendedAt userRememberToken userLoginCount+ userFailedLoginCount userLockedOutUntil userCurrentLoginAt+ userLastLoginAt userCurrentLoginIp userLastLoginIp userCreatedAt+ userUpdatedAt userResetToken userResetRequestedAt (Object userMeta)+ (text2int (unUid uid))++-- there ought to be a way to not have to "hide" the error like this... or at+-- least a way to log an error from here+hideError :: (Show (TxError c), Show (CxError c))+ => Either (SessionError c) a -> IO (Either AuthFailure a)+hideError = either+ (\e -> print e >> pure (Left BackendError))+ (pure . Right)++instance (CxTx s, Show (CxError s), Show (TxError s), CxAuthUser s) =>+ IAuthBackend (HasqlAuthManager s) where+ save HasqlAuthManager{..} u =+ hideError =<< Hasql.session pool (tx writeMode (saveQuery u))++ lookupByUserId HasqlAuthManager{..} (UserId uid) =+ either (const Nothing) (fmap userFromTuple) <$>+ Hasql.session pool (tx readMode (maybeEx query))+ where+ query = [stmt|SELECT * FROM snap_auth_user WHERE snap_auth_user.uid = ?|]+ (text2int uid)++ lookupByLogin HasqlAuthManager{..} login =+ either (const Nothing) (fmap userFromTuple) <$>+ Hasql.session pool (tx readMode (maybeEx query))+ where+ query = [stmt|SELECT * FROM snap_auth_user WHERE snap_auth_user.login = ?|]+ login++ lookupByRememberToken HasqlAuthManager{..} rt =+ either (const Nothing) (fmap userFromTuple) <$>+ Hasql.session pool (tx readMode (maybeEx query))+ where+ query = [stmt|SELECT * FROM snap_auth_user+ WHERE snap_auth_user.remember_token = ?|] rt++ destroy HasqlAuthManager{..}+ AuthUser{userId = Just (UserId (text2int -> uid))} =+ void (Hasql.session pool+ (tx writeMode+ (unitEx ([stmt|DELETE FROM snap_auth_user WHERE uid = ?|] uid))))++readMode :: TxMode+readMode = Just (Serializable, Nothing)++writeMode :: TxMode+writeMode = Just (Serializable, Just True)++text2int :: Text -> Int+text2int t =+ either (\a -> error ("text2int: Can't parse " ++ show t)) fst+ (T.decimal t)+
src/Snap/Snaplet/Hasql.hs view
@@ -6,16 +6,19 @@ {-# LANGUAGE OverloadedStrings #-} module Snap.Snaplet.Hasql ( HasPool(..)- , hasqlInit+ , initHasql+ , initHasql' , session , session' , module H ) where import Control.Lens import Control.Monad.Reader+import qualified Data.Configurator as C import Hasql as H hiding (session) import qualified Hasql import Hasql.Backend hiding (Tx)+import Paths_snaplet_hasql import Snap class (Show (CxError db), Show (TxError db), CxTx db, Cx db) =>@@ -26,13 +29,32 @@ HasPool (Pool db) db where poolLens = id -hasqlInit+dataDir :: Maybe (IO FilePath)+dataDir = Just (fmap (++ "/resources") getDataDir)++initHasql :: HasPool c db => CxSettings db- -> PoolSettings -> SnapletInit c (Pool db)-hasqlInit cx p =- makeSnaplet "hasql" "" Nothing $ do+initHasql cx =+ makeSnaplet "hasql" "" dataDir $ do+ ps <- getPoolSettings =<< getSnapletUserConfig+ pool <- liftIO (acquirePool cx ps)+ onUnload (releasePool pool)+ return pool++getPoolSettings cfg = (\(Just a) -> a) <$> liftIO (poolSettings+ <$> C.require cfg "maxConnections"+ <*> C.require cfg "connectionTimeout")++initHasql'+ :: HasPool c db+ => CxSettings db+ -> Maybe PoolSettings+ -> SnapletInit c (Pool db)+initHasql' cx Nothing = error "initHasql: Incorrect poolSettings parameters."+initHasql' cx (Just p) =+ makeSnaplet "hasql" "" dataDir $ do pool <- liftIO (acquirePool cx p) onUnload (releasePool pool) return pool