diff --git a/snap.cabal b/snap.cabal --- a/snap.cabal +++ b/snap.cabal @@ -1,5 +1,5 @@ name: snap -version: 1.0.0.2 +version: 1.1.0.0 synopsis: Top-level package for the Snap Web Framework description: This is the top-level package for the official Snap Framework libraries. @@ -103,7 +103,7 @@ Snap.Snaplet.Session.SecureCookie build-depends: - aeson >= 0.6 && < 1.2, + aeson >= 0.6 && < 1.3, attoparsec >= 0.10 && < 0.14, base >= 4 && < 4.11, bytestring >= 0.9.1 && < 0.11, @@ -131,7 +131,7 @@ snap-server >= 1.0 && < 1.1, stm >= 2.2 && < 2.5, text >= 0.11 && < 1.3, - time >= 1.1 && < 1.7, + time >= 1.1 && < 1.9, transformers >= 0.2 && < 0.6, transformers-base >= 0.4 && < 0.5, unordered-containers >= 0.1.4 && < 0.3, @@ -233,7 +233,6 @@ directory-tree, dlist, filepath, - Glob >= 0.7.5 && < 0.9, hashable, heist, http-streams >= 0.7.1.1 && < 0.9, @@ -245,7 +244,7 @@ mtl, mwc-random, pwstore-fast, - QuickCheck >= 2.4.2 && < 2.10, + QuickCheck >= 2.4.2 && < 2.11, smallcheck >= 1.1.1 && < 1.2, snap-core, snap-server, diff --git a/src/Snap/Snaplet/Auth.hs b/src/Snap/Snaplet/Auth.hs --- a/src/Snap/Snaplet/Auth.hs +++ b/src/Snap/Snaplet/Auth.hs @@ -46,7 +46,7 @@ , Role(..) -- * Other Utilities - , authSettingsFromConfig + , authSettingsFromConfig , withBackend , encryptPassword , checkPassword diff --git a/src/Snap/Snaplet/Auth/AuthManager.hs b/src/Snap/Snaplet/Auth/AuthManager.hs --- a/src/Snap/Snaplet/Auth/AuthManager.hs +++ b/src/Snap/Snaplet/Auth/AuthManager.hs @@ -59,6 +59,7 @@ save :: r -> AuthUser -> IO (Either AuthFailure AuthUser) lookupByUserId :: r -> UserId -> IO (Maybe AuthUser) lookupByLogin :: r -> Text -> IO (Maybe AuthUser) + lookupByEmail :: r -> Text -> IO (Maybe AuthUser) lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser) destroy :: r -> AuthUser -> IO () @@ -101,6 +102,6 @@ save AuthManager{..} u = save backend u lookupByUserId AuthManager{..} u = lookupByUserId backend u lookupByLogin AuthManager{..} u = lookupByLogin backend u + lookupByEmail AuthManager{..} u = lookupByEmail backend u lookupByRememberToken AuthManager{..} u = lookupByRememberToken backend u destroy AuthManager{..} u = destroy backend u - diff --git a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs --- a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs +++ b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs @@ -10,6 +10,7 @@ ) where +import Control.Applicative ((<|>)) import Control.Monad.State import Control.Concurrent.STM import Data.Aeson @@ -18,7 +19,8 @@ import qualified Data.ByteString as B import qualified Data.Map as HM import Data.Map (Map) -import Data.Maybe (fromJust, isJust) +import Data.Maybe (fromJust, isJust, listToMaybe) +import Data.Monoid (mempty) import Data.Text (Text) import qualified Data.Text as T import Data.Time @@ -104,6 +106,10 @@ ------------------------------------------------------------------------------ +type EmailUserCache = Map Text UserId + + +------------------------------------------------------------------------------ type RemTokenUserCache = Map Text UserId @@ -113,6 +119,7 @@ data UserCache = UserCache { uidCache :: UserIdCache -- ^ the actual datastore , loginCache :: LoginUserCache -- ^ fast lookup for login field + , emailCache :: EmailUserCache -- ^ fast lookup for email field , tokenCache :: RemTokenUserCache -- ^ fast lookup for remember tokens , uidCounter :: Int -- ^ user id counter } @@ -123,6 +130,7 @@ defUserCache = UserCache { uidCache = HM.empty , loginCache = HM.empty + , emailCache = HM.empty , tokenCache = HM.empty , uidCounter = 0 } @@ -198,6 +206,8 @@ return $! cache { uidCache = HM.insert uid' u' $ uidCache cache , loginCache = HM.insert (userLogin u') uid' $ loginCache cache + , emailCache = maybe id (\em -> HM.insert em uid') (userEmail u) $ + emailCache cache , tokenCache = case userRememberToken u' of Nothing -> tokenCache cache Just x -> HM.insert x uid' $ tokenCache cache @@ -216,9 +226,11 @@ Nothing -> return $! Left UserNotFound Just x -> do let oldLogin = userLogin x + let oldEmail = userEmail x let oldToken = userRememberToken x let uid = fromJust $ userId u let newLogin = userLogin u + let newEmail = userEmail u let newToken = userRememberToken u let lc = if oldLogin /= userLogin u @@ -227,6 +239,16 @@ loginCache cache else loginCache cache + let ec = if oldEmail /= newEmail + then (case (oldEmail, newEmail) of + (Nothing, Nothing) -> id + (Just e, Nothing) -> HM.delete e + (Nothing, Just e ) -> HM.insert e uid + (Just e, Just e') -> HM.insert e' uid . + HM.delete e + ) (emailCache cache) + else emailCache cache + let tc = if oldToken /= newToken && isJust oldToken then HM.delete (fromJust oldToken) $ loginCache cache else tokenCache cache @@ -240,6 +262,7 @@ let new = cache { uidCache = HM.insert uid u' $ uidCache cache , loginCache = lc + , emailCache = ec , tokenCache = tc' } @@ -273,6 +296,16 @@ f cache = getUid >>= getUser cache where getUid = HM.lookup login (loginCache cache) + lookupByEmail mgr email = withCache mgr f + where + f cache = getEmail >>= getUser cache + where getEmail = case HM.lookup email (emailCache cache) of + Just u -> return u + Nothing -> (join . fmap userId . + listToMaybe . HM.elems $ + HM.filter ((== Just email) . userEmail) + (uidCache cache)) + lookupByRememberToken mgr token = withCache mgr f where f cache = getUid >>= getUser cache @@ -306,6 +339,7 @@ toJSON uc = object [ "uidCache" .= uidCache uc , "loginCache" .= loginCache uc + , "emailCache" .= emailCache uc , "tokenCache" .= tokenCache uc , "uidCounter" .= uidCounter uc ] @@ -317,6 +351,8 @@ UserCache <$> v .: "uidCache" <*> v .: "loginCache" + <*> (v .: "emailCache" <|> pure mempty) -- Old versions of users.json do + -- not carry this field <*> v .: "tokenCache" <*> v .: "uidCounter" parseJSON _ = error "Unexpected JSON input"