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 }
initHasqlAuth
:: (CxTx s, Show (CxError s), Show (TxError s), CxAuthUser s)
=> SnapletLens b SessionManager
-> Snaplet (Pool s)
-> 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)
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
passwordToText :: Password -> Text
passwordToText (Encrypted bs) = T.decodeUtf8 bs
passwordToText (ClearText bs) = error "Cannot save a ClearText password!"
fromPassword :: ByteString -> Password
fromPassword = Encrypted
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))
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)