diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Snap/Snaplet/Auth/Backends/Acid.hs b/Snap/Snaplet/Auth/Backends/Acid.hs new file mode 100644 --- /dev/null +++ b/Snap/Snaplet/Auth/Backends/Acid.hs @@ -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 diff --git a/snaplet-auth-acid.cabal b/snaplet-auth-acid.cabal new file mode 100644 --- /dev/null +++ b/snaplet-auth-acid.cabal @@ -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