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/devel.cfg b/resources/devel.cfg new file mode 100644 --- /dev/null +++ b/resources/devel.cfg @@ -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 diff --git a/snaplet-hasql.cabal b/snaplet-hasql.cabal --- a/snaplet-hasql.cabal +++ b/snaplet-hasql.cabal @@ -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 diff --git a/src/Snap/Snaplet/Auth/Backends/Hasql.hs b/src/Snap/Snaplet/Auth/Backends/Hasql.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/Backends/Hasql.hs @@ -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) + diff --git a/src/Snap/Snaplet/Hasql.hs b/src/Snap/Snaplet/Hasql.hs --- a/src/Snap/Snaplet/Hasql.hs +++ b/src/Snap/Snaplet/Hasql.hs @@ -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