summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikeLedger <>2015-06-25 16:12:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-06-25 16:12:00 (GMT)
commitd01e06fce949bcf60debc970d3bc9c83fac14577 (patch)
treecb10e80ea962a4d8a2b0f5ed72d6461270603c8f
parent08fb8b292d6914e6e9c8ce63a7c6d5eff99d3e4b (diff)
version 1.0.01.0.0
-rw-r--r--resources/auth/devel.cfg18
-rw-r--r--resources/devel.cfg6
-rw-r--r--snaplet-hasql.cabal35
-rw-r--r--src/Snap/Snaplet/Auth/Backends/Hasql.hs247
-rw-r--r--src/Snap/Snaplet/Hasql.hs32
5 files changed, 325 insertions, 13 deletions
diff --git a/resources/auth/devel.cfg b/resources/auth/devel.cfg
new file mode 100644
index 0000000..76565b8
--- /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
index 0000000..1dca018
--- /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
index 21a64ad..60292a4 100644
--- 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 @@ maintainer: eleventynine@gmail.com
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
index 0000000..e16bfda
--- /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
index 4b37793..27b86b7 100644
--- 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 @@ instance (Cx db, CxTx db, Show (CxError db), Show (TxError db)) =>
HasPool (Pool db) db where
poolLens = id
-hasqlInit
+dataDir :: Maybe (IO FilePath)
+dataDir = Just (fmap (++ "/resources") getDataDir)
+
+initHasql
+ :: HasPool c db
+ => CxSettings db
+ -> SnapletInit c (Pool db)
+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
- -> PoolSettings
+ -> Maybe PoolSettings
-> SnapletInit c (Pool db)
-hasqlInit cx p =
- makeSnaplet "hasql" "" Nothing $ do
+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