snaplet-auth-acid (empty) → 0.0.1
raw patch · 4 files changed
+345/−0 lines, 4 filesdep +MonadCatchIO-transformersdep +acid-statedep +aesonsetup-changed
Dependencies added: MonadCatchIO-transformers, acid-state, aeson, attoparsec, base, cereal, clientsession, directory, errors, filepath, hashable, lens, mtl, safecopy, snap, snap-core, text, time, unordered-containers, vector
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Snap/Snaplet/Auth/Backends/Acid.hs +274/−0
- snaplet-auth-acid.cabal +39/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, David Johnson++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of David Johnson nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Snap/Snaplet/Auth/Backends/Acid.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++module Snap.Snaplet.Auth.Backends.Acid where++import Control.Error+import Control.Exception hiding (Handler)+import Control.Monad.CatchIO (throw)+import Control.Monad.Reader (ask)+import Data.Acid+import Data.Aeson (Value, encode, decode)+import Data.Attoparsec.Number (Number)+import Control.Lens+import qualified Data.HashMap.Strict as H+import Data.Hashable (Hashable)+import Data.Maybe+import Data.SafeCopy+import qualified Data.Serialize as S (get, put)+import Data.Text (Text, pack)+import Data.Time+import Data.Typeable (Typeable)+import qualified Data.Vector as V (Vector, toList, fromList)+import Snap+import Snap.Snaplet.Auth+import Snap.Snaplet.Session+import System.Directory+import System.IO.Error hiding (catch)+import Web.ClientSession+import Snap.Util.FileServe+import System.FilePath ((</>))++------------------------------------------------------------------------------+type UserLogin = Text+type RToken = Text+++------------------------------------------------------------------------------+data UserStore = UserStore+ { _users :: H.HashMap UserId AuthUser+ , _loginIndex :: H.HashMap UserLogin UserId+ , _tokenIndex :: H.HashMap RToken UserId+ , _nextUserId :: Int+ } deriving (Typeable)++makeLenses ''UserStore+++------------------------------------------------------------------------------+instance (SafeCopy a, SafeCopy b, Eq a, Hashable a) =>+ SafeCopy (H.HashMap a b) where+ getCopy = contain $ fmap H.fromList safeGet+ putCopy = contain . safePut . H.toList+++------------------------------------------------------------------------------+instance (SafeCopy a) => SafeCopy (V.Vector a) where+ getCopy = contain $ fmap V.fromList safeGet+ putCopy = contain . safePut . V.toList+++------------------------------------------------------------------------------+deriving instance Typeable AuthUser+++------------------------------------------------------------------------------+$(deriveSafeCopy 0 'base ''Number)+$(deriveSafeCopy 0 'base ''Value)+$(deriveSafeCopy 0 'base ''Password)+$(deriveSafeCopy 0 'base ''Role)+$(deriveSafeCopy 0 'base ''AuthFailure)+$(deriveSafeCopy 0 'base ''AuthUser)+$(deriveSafeCopy 0 'base ''UserId)+$(deriveSafeCopy 0 'base ''UserStore)+++------------------------------------------------------------------------------+emptyUS :: UserStore+emptyUS = UserStore H.empty H.empty H.empty 0+++------------------------------------------------------------------------------+saveAuthUser :: AuthUser+ -> UTCTime+ -> Update UserStore (Either AuthFailure AuthUser)+saveAuthUser user utcTime = do+ let authUserId = userId user+ case authUserId of+ Just id -> saveExistingUser user id utcTime+ Nothing -> saveNewUser user utcTime+++------------------------------------------------------------------------------+saveNewUser :: AuthUser+ -> UTCTime+ -> Update UserStore (Either AuthFailure AuthUser)+saveNewUser user currentTime = do+ loginCache <- use loginIndex+ if isJust $ H.lookup (userLogin user) loginCache+ then return $ Left DuplicateLogin+ else do+ uid <- liftM (UserId . pack . show) $ use nextUserId+ nextUserId += 1+ let user' = user { userUpdatedAt = Just currentTime, userId = Just uid }+ updateUserCache user' uid+ updateLoginCache (userLogin user') uid+ updateTokenCache (userRememberToken user) uid+ return $ Right user'+++------------------------------------------------------------------------------+saveExistingUser :: AuthUser+ -> UserId+ -> UTCTime+ -> Update UserStore (Either AuthFailure AuthUser)+saveExistingUser user userId currentTime = do+ loginCache <- use loginIndex+ if Just userId /= H.lookup (userLogin user) loginCache+ then return $ Left DuplicateLogin+ else do+ userCache <- use users++ let oldUser = fromMaybe user $ H.lookup userId userCache+ loginIndex %= H.delete (userLogin oldUser)+ tokenIndex %= deleteIfJust (userRememberToken oldUser)++ let user' = user { userUpdatedAt = Just currentTime }+ updateUserCache user' userId+ updateLoginCache (userLogin user') userId+ updateTokenCache (userRememberToken user) userId++ return $ Right user+++------------------------------------------------------------------------------+deleteIfJust :: (Hashable a, Eq a) => Maybe a -> H.HashMap a b -> H.HashMap a b+deleteIfJust (Just val) hash = H.delete val hash+deleteIfJust Nothing hash = hash++------------------------------------------------------------------------------+updateUserCache :: (MonadState UserStore m) => AuthUser -> UserId -> m ()+updateUserCache user uid = users %= H.insert uid user+++------------------------------------------------------------------------------+updateLoginCache :: (MonadState UserStore m) => Text-> UserId -> m ()+updateLoginCache login uid = loginIndex %= H.insert login uid+++------------------------------------------------------------------------------+updateTokenCache :: (MonadState UserStore m) => Maybe Text -> UserId -> m ()+updateTokenCache (Just token) uid = tokenIndex %= H.insert token uid+updateTokenCache Nothing _ = return ()+++------------------------------------------------------------------------------+byUserId :: UserId -> Query UserStore (Maybe AuthUser)+byUserId uid = do+ UserStore us _ _ _ <- ask+ return $ H.lookup uid us+++------------------------------------------------------------------------------+byLogin :: UserLogin -> Query UserStore (Maybe AuthUser)+byLogin l = do+ UserStore _ li _ _ <- ask+ maybe (return Nothing) byUserId $ H.lookup l li+++------------------------------------------------------------------------------+byRememberToken :: RToken -> Query UserStore (Maybe AuthUser)+byRememberToken tok = do+ UserStore _ _ ti _<- ask+ maybe (return Nothing) byUserId $ H.lookup tok ti+++------------------------------------------------------------------------------+destroyU :: AuthUser -> Update UserStore ()+destroyU au =+ case userId au of+ Nothing -> return ()+ Just uid -> do+ UserStore us li ti n <- get+ storedUser <- liftQuery $ byUserId uid+ let li' = fromMaybe li $+ H.delete . userLogin <$> storedUser <*> pure li+ ti' = fromMaybe ti $+ H.delete <$> (userRememberToken =<< storedUser) <*> pure ti+ put $ UserStore (H.delete uid us) li' ti' n+++------------------------------------------------------------------------------+allLogins :: Query UserStore [UserLogin]+allLogins = do+ UserStore _ li _ _ <- ask+ return $ H.keys li+++------------------------------------------------------------------------------+$(makeAcidic ''UserStore [ 'saveAuthUser+ , 'byUserId+ , 'byLogin+ , 'byRememberToken+ , 'destroyU+ , 'allLogins+ ] )+++------------------------------------------------------------------------------+instance IAuthBackend (AcidState UserStore) where+ save = acidSave+ lookupByUserId acid uid = query acid $ ByUserId uid+ lookupByLogin acid l = query acid $ ByLogin l+ lookupByRememberToken acid tok = query acid $ ByRememberToken tok+ destroy acid au = update acid $ DestroyU au+++------------------------------------------------------------------------------+acidSave :: AcidState UserStore -> AuthUser -> IO (Either AuthFailure AuthUser)+acidSave acid user = do+ now <- getCurrentTime+ update acid $ SaveAuthUser user now+++------------------------------------------------------------------------------+initAcidAuthManager :: AuthSettings+ -> SnapletLens b SessionManager+ -> SnapletInit b (AuthManager b)+initAcidAuthManager s lns =+ makeSnaplet+ "AcidStateAuthManager"+ "A snaplet providing user authentication using an Acid State backend"+ Nothing $ do+ removeResourceLockOnUnload+ rng <- liftIO mkRNG+ key <- liftIO $ getKey (asSiteKey s)+ dir <- getSnapletFilePath+ acid <- liftIO $ openLocalStateFrom dir emptyUS+ return AuthManager+ { backend = acid+ , session = lns+ , activeUser = Nothing+ , minPasswdLen = asMinPasswdLen s+ , rememberCookieName = asRememberCookieName s+ , rememberPeriod = asRememberPeriod s+ , siteKey = key+ , lockout = asLockout s+ , randomNumberGenerator = rng+ }+++------------------------------------------------------------------------------+removeResourceLockOnUnload :: Initializer b v ()+removeResourceLockOnUnload = do+ path <- getSnapletFilePath+ let resourceLockPath = path </> "open.lock"+ onUnload $ removeIfExists resourceLockPath+++------------------------------------------------------------------------------+removeIfExists :: FilePath -> IO ()+removeIfExists fileName = removeFile fileName `catch` handleExists+ where handleExists e+ | isDoesNotExistError e = return ()+ | otherwise = throwIO e+++------------------------------------------------------------------------------+getAllLogins :: AcidState UserStore -> Handler b (AuthManager v) [Text]+getAllLogins acid = liftIO $ query acid AllLogins
+ snaplet-auth-acid.cabal view
@@ -0,0 +1,39 @@+Name: snaplet-auth-acid+Version: 0.0.1+Synopsis: Provides an Acid-State backend for the Auth Snaplet+Description: Project Description Here+License: BSD3+license-file: LICENSE+Author: Ben Doyle+Maintainer: djohnson.m@gmail.com+Stability: Experimental+Category: Web, Snap+Build-type: Simple+Cabal-version: >=1.8++Library+ exposed-modules: Snap.Snaplet.Auth.Backends.Acid+ Build-depends:+ base >= 4 && < 5,+ acid-state >= 0.12.1,+ MonadCatchIO-transformers >= 0.2 && < 0.4,+ aeson >= 0.6 && < 0.7,+ attoparsec >= 0.10 && < 0.11,+ cereal >= 0.3 && < 0.5,+ clientsession >= 0.8 && < 0.10,+ errors >= 1.4 && < 1.5,+ hashable (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3),+ mtl > 2.1 && < 3,+ filepath >= 1.1 && < 1.4,+ directory >= 1.0 && < 1.3,+ lens >= 3.7.6 && < 3.10,+ snap-core >= 0.9 && < 0.11,+ safecopy >= 0.8.2,+ snap >= 0.13.0.3,+ text >= 0.11 && < 0.12,+ time >= 1.1 && < 1.5,+ unordered-containers >= 0.1.4 && < 0.3,+ vector >= 0.7.1 && < 0.11+source-repository head+ type: git+ location: https://github.com/dmjio/snaplet-auth-acid.git