/src/Snap/Snaplet/Auth/Backends/MongoDB.hs

{-# LANGUAGE TemplateHaskell, TypeFamilies, QuasiQuotes #-}

-- | This module containes MongoDB backend implementation
--   for Snap.Snaplet.Auth
module Snap.Snaplet.Auth.Backends.MongoDB where

import           Control.Monad.Reader
import           Control.Monad.Error

import           Data.Lens.Lazy hiding (access)
import           Data.Lens.Template
import           Data.Time
import           Web.ClientSession

import           Snap
import           Snap.Snaplet
import           Snap.Snaplet.Auth hiding (UserId)
import qualified Snap.Snaplet.Auth as Auth (UserId)
import           Snap.Snaplet.Session
import           Snap.Snaplet.MongoDB hiding (get)
import           Snap.Snaplet.MongoDB.MongoValue

import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as Hash (toList, fromList)
import qualified Data.Bson as Bson
import qualified Data.Text as T
import qualified Data.Aeson as A
import           Data.UString (u)
import qualified Data.Attoparsec.Number as AN
import qualified Data.Vector as V

import qualified Database.MongoDB.Connection as MongoDB
import qualified System.IO.Pool as MPool
import           Database.MongoDB.Query (Action, Failure(..), Database, master, access, AccessMode(..))

----------------------------------------------------------------------
-- | Initialize a MongoDB backed 'AuthManager'
initMongoDBAuthManager
  :: AuthSettings
  -- ^ Authentication settings for your app
  -> Lens b (Snaplet SessionManager)
  -- ^ Lens into a 'SessionManager' auth snaplet will use
  -> Snaplet MongoDBSnaplet
  -- ^ Lens into a 'MongoDBSnaplet'
  -> Initializer b (AuthManager b) ()
  -- ^ Custom action to run with normal snaplet init
  -> SnapletInit b (AuthManager b)
initMongoDBAuthManager settings session_lens mongo action =
  makeSnaplet "MongoDBAuthManager"
      "A snaplet providing user authentication using a MongoDB backend"
      Nothing $ do
        action
        key  <- liftIO $ getKey (asSiteKey settings)
        return $ AuthManager {
            backend = MongoDBAuthManager mongo
          , session = session_lens
          , activeUser = Nothing
          , minPasswdLen = asMinPasswdLen settings
          , rememberCookieName = asRememberCookieName settings
          , rememberPeriod = asRememberPeriod settings
          , siteKey = key
          , lockout = asLockout settings
        }
----------------------------------------------------------------------
data MongoDBAuthManager = MongoDBAuthManager {
  _mongoDB :: Snaplet MongoDBSnaplet
}
----------------------------------------------------------------------
withMgr 
  :: MongoDBAuthManager 
  -> ReaderT MongoDBAuthManager IO a 
  -> IO a
withMgr mgr action = runReaderT action mgr
----------------------------------------------------------------------
makeLens ''MongoDBAuthManager
----------------------------------------------------------------------
instance MonadMongoDB (ReaderT MongoDBAuthManager IO) where
  withDB run = do
    (MongoDBAuthManager mongo) <- ask
    let mongoDB = getL snapletValue mongo
    let pool = connPoll mongoDB
    let db = appDatabase mongoDB
    epipe <- liftIO $ runErrorT $ MPool.aResource pool
    case epipe of
      Left err -> return $ Left $ ConnectionFailure err
      Right pipe -> do
        liftIO (access pipe master db run)

  withDBUnsafe run = undefined
----------------------------------------------------------------------
asMongoEntity ''AuthUser useDefaults
asMongoValue  ''Auth.UserId useDefaults
asMongoValue  ''Role useDefaults
asMongoValue  ''Password useDefaults
asMongoValue  ''A.Value useDefaults
asMongoValue  ''AN.Number useDefaults
----------------------------------------------------------------------
instance MongoValue A.Array where
  toValue a = toValue $ V.toList a
  fromValue v = return . V.fromList =<< fromValue v
----------------------------------------------------------------------
instance MongoValue (HashMap T.Text A.Value) where
  toValue m   = Bson.Array $ map toObj $ Hash.toList m
    where
      toObj :: (T.Text, A.Value) -> Bson.Value
      toObj (k, v) = Bson.Doc [(u "key") := (toValue k), (u "value") := (toValue v)]

  fromValue (Bson.Array a) = do
    el <- mapM toKV a
    return $ Hash.fromList el
    where
      toKV :: (Applicative m, Monad m) => Bson.Value -> ErrorT String m (T.Text, A.Value)
      toKV (Bson.Doc d) = do
        key <- fromValue =<< Bson.look (u "key") d
        value <- fromValue =<< Bson.look (u "value") d
        return (key, value)
      toKV v = expected "document" v
  fromValue v = expected "array" v
----------------------------------------------------------------------
instance IAuthBackend MongoDBAuthManager where

  --save :: MongoDBAuthManager -> AuthUser -> IO AuthUser
  save mgr u = withMgr mgr $ do
    muser <- withDB' $ selectOne [mongo| { userId: #{userId u} } |] []
    case muser of
      Nothing          -> (withDB' $ insert   u) >> return u
      Just (_id, user) -> (withDB' $ Snap.Snaplet.MongoDB.save _id u) >> return user

  --lookupByUserId :: MongoDBAuthManager -> UserId -> IO (Maybe AuthUser)
  lookupByUserId mgr uid = withMgr mgr $ do
    mret <- withDB' $ selectOne [mongo| { userId: #{uid} } |] []
    case mret of
      Nothing -> return Nothing
      Just (_, ret) -> return $ Just ret

  --lookupByLogin ::MongoDBAuthManager -> Text -> IO (Maybe AuthUser)
  lookupByLogin mgr login = withMgr mgr $ do
    mret <- withDB' $ selectOne [mongo| { userLogin: #{login} } |] []
    case mret of
      Nothing -> return Nothing
      Just (_, ret) -> return $ Just ret

  --lookupByRememberToken :: MongoDBAuthManager -> Text -> IO (Maybe AuthUser)
  lookupByRememberToken mgr token =  withMgr mgr $ do
    mret <- withDB' $ selectOne [mongo| { userRememberToken: #{token} } |] []
    case mret of
      Nothing -> return Nothing
      Just (_, ret) -> return $ Just ret

  --destroy :: MongoDBAuthManager -> AuthUser -> IO ()
  destroy mgr u = withMgr mgr $ do
    withDB' $ deleteWhere ([mongo| { userId: #{userId u}, userLogin: #{userLogin u}, userRememberToken: #{userRememberToken u} } |] :: Document AuthUser)