Anonymous avatar Anonymous committed 7d8240c

Added MongoDB backend for Snap.Snaplet.Auth

Comments (0)

Files changed (2)

snaplet-mongoDB.cabal

                   , Snap.Snaplet.MongoDB.MongoEntity
                   , Snap.Snaplet.MongoDB.MongoValue
                   , Snap.Snaplet.MongoDB.Parse
+                  , Snap.Snaplet.Auth.Backends.MongoDB
   
   -- Packages needed in order to build this package.
   Build-depends:
     parsec == 3.1.1,
     haskell-src-exts == 1.11.1,
     template-haskell,
-    MonadCatchIO-transformers == 0.2.2.2
+    MonadCatchIO-transformers == 0.2.2.2,
+    clientsession == 0.7.3.6,
+    data-lens == 2.0.2,
+    data-lens-template == 2.1.2,
+    unordered-containers == 0.1.4.3,
+    aeson == 0.4.0.0,
+    attoparsec == 0.10.0.3,
+    vector == 0.9
   
   -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
   -- Build-tools:    

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'
+  -> SnapletInit b (AuthManager b)
+initMongoDBAuthManager settings session_lens mongo =
+  makeSnaplet "MongoDBAuthManager"
+      "A snaplet providing user authentication using a MongoDB backend"
+      Nothing $ do
+        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)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.