{-# LANGUAGE CPP                  #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Snap.Snaplet.Auth.Backends.JsonFile
  ( initJsonFileAuthManager
  , mkJsonAuthMgr
  ) where


import           Control.Applicative ((<|>))
import           Control.Monad (join)
import           Control.Monad.State
import           Control.Concurrent.STM
import           Data.Aeson
import qualified Data.Attoparsec.ByteString as Atto
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString as B
import qualified Data.Map as HM
import           Data.Map (Map)
import           Data.Maybe (fromJust, isJust, listToMaybe)
import           Data.Monoid (mempty)
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Time
import           Web.ClientSession
import           System.Directory

#if !MIN_VERSION_base(4,8,0)
import           Control.Applicative
#endif

import           Snap.Snaplet
import           Snap.Snaplet.Auth.Types
import           Snap.Snaplet.Auth.AuthManager
import           Snap.Snaplet.Session



------------------------------------------------------------------------------
-- | Initialize a JSON file backed 'AuthManager'
initJsonFileAuthManager :: AuthSettings
                            -- ^ Authentication settings for your app
                        -> SnapletLens b SessionManager
                            -- ^ Lens into a 'SessionManager' auth snaplet will
                           -- use
                        -> FilePath
                            -- ^ Where to store user data as JSON
                        -> SnapletInit b (AuthManager b)
initJsonFileAuthManager :: forall b.
AuthSettings
-> SnapletLens b SessionManager
-> [Char]
-> SnapletInit b (AuthManager b)
initJsonFileAuthManager AuthSettings
s SnapletLens b SessionManager
l [Char]
db = do
    forall b v.
Text
-> Text
-> Maybe (IO [Char])
-> Initializer b v v
-> SnapletInit b v
makeSnaplet
        Text
"JsonFileAuthManager"
        Text
"A snaplet providing user authentication using a JSON-file backend"
        forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
            RNG
rng <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO RNG
mkRNG
            Key
key <- [Char] -> IO Key
getKey (AuthSettings -> [Char]
asSiteKey AuthSettings
s)
            JsonFileAuthManager
jsonMgr <- [Char] -> IO JsonFileAuthManager
mkJsonAuthMgr [Char]
db
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! AuthManager {
                         backend :: JsonFileAuthManager
backend               = JsonFileAuthManager
jsonMgr
                       , session :: SnapletLens b SessionManager
session               = SnapletLens b SessionManager
l
                       , activeUser :: Maybe AuthUser
activeUser            = forall a. Maybe a
Nothing
                       , minPasswdLen :: Int
minPasswdLen          = AuthSettings -> Int
asMinPasswdLen AuthSettings
s
                       , rememberCookieName :: ByteString
rememberCookieName    = AuthSettings -> ByteString
asRememberCookieName AuthSettings
s
                       , rememberCookieDomain :: Maybe ByteString
rememberCookieDomain  = forall a. Maybe a
Nothing
                       , rememberPeriod :: Maybe Int
rememberPeriod        = AuthSettings -> Maybe Int
asRememberPeriod AuthSettings
s
                       , siteKey :: Key
siteKey               = Key
key
                       , lockout :: Maybe (Int, NominalDiffTime)
lockout               = AuthSettings -> Maybe (Int, NominalDiffTime)
asLockout AuthSettings
s
                       , randomNumberGenerator :: RNG
randomNumberGenerator = RNG
rng
                       }


------------------------------------------------------------------------------
-- | Load/create a datafile into memory cache and return the manager.
--
-- This data type can be used by itself for batch/non-handler processing.
mkJsonAuthMgr :: FilePath -> IO JsonFileAuthManager
mkJsonAuthMgr :: [Char] -> IO JsonFileAuthManager
mkJsonAuthMgr [Char]
fp = do
  Either [Char] UserCache
db <- [Char] -> IO (Either [Char] UserCache)
loadUserCache [Char]
fp
  let db' :: UserCache
db' = case Either [Char] UserCache
db of
              Left [Char]
e  -> forall a. HasCallStack => [Char] -> a
error [Char]
e
              Right UserCache
x -> UserCache
x
  TVar UserCache
cache <- forall a. a -> IO (TVar a)
newTVarIO UserCache
db'

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! JsonFileAuthManager {
      memcache :: TVar UserCache
memcache = TVar UserCache
cache
    , dbfile :: [Char]
dbfile   = [Char]
fp
  }


------------------------------------------------------------------------------
type UserIdCache = Map UserId AuthUser

#if !MIN_VERSION_aeson(1,0,0)
-- In aeson >= 1 these instances are not needed because we have
-- derived ToJSONKey/FromJSONKey instances for UserId.
instance ToJSON UserIdCache where
  toJSON m = toJSON $ HM.toList m

instance FromJSON UserIdCache where
  parseJSON = fmap HM.fromList . parseJSON
#endif

------------------------------------------------------------------------------
type LoginUserCache = Map Text UserId


------------------------------------------------------------------------------
type EmailUserCache = Map Text UserId


------------------------------------------------------------------------------
type RemTokenUserCache = Map Text UserId


------------------------------------------------------------------------------
-- | JSON user back-end stores the user data and indexes for login and token
-- based logins.
data UserCache = UserCache {
    UserCache -> UserIdCache
uidCache    :: UserIdCache          -- ^ the actual datastore
  , UserCache -> LoginUserCache
loginCache  :: LoginUserCache       -- ^ fast lookup for login field
  , UserCache -> LoginUserCache
emailCache  :: EmailUserCache       -- ^ fast lookup for email field
  , UserCache -> LoginUserCache
tokenCache  :: RemTokenUserCache    -- ^ fast lookup for remember tokens
  , UserCache -> Int
uidCounter  :: Int                  -- ^ user id counter
}


------------------------------------------------------------------------------
defUserCache :: UserCache
defUserCache :: UserCache
defUserCache = UserCache {
    uidCache :: UserIdCache
uidCache   = forall k a. Map k a
HM.empty
  , loginCache :: LoginUserCache
loginCache = forall k a. Map k a
HM.empty
  , emailCache :: LoginUserCache
emailCache = forall k a. Map k a
HM.empty
  , tokenCache :: LoginUserCache
tokenCache = forall k a. Map k a
HM.empty
  , uidCounter :: Int
uidCounter = Int
0
}


------------------------------------------------------------------------------
loadUserCache :: FilePath -> IO (Either String UserCache)
loadUserCache :: [Char] -> IO (Either [Char] UserCache)
loadUserCache [Char]
fp = do
  Bool
chk <- [Char] -> IO Bool
doesFileExist [Char]
fp
  case Bool
chk of
    Bool
True -> do
      ByteString
d <- [Char] -> IO ByteString
B.readFile [Char]
fp
      case forall a. Parser a -> ByteString -> Either [Char] a
Atto.parseOnly Parser Value
json ByteString
d of
        Left [Char]
e  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                       [Char]
"Can't open JSON auth backend. Error: " forall a. [a] -> [a] -> [a]
++ [Char]
e
        Right Value
v -> case forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
          Error [Char]
e    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                        [Char]
"Malformed JSON auth data store. Error: " forall a. [a] -> [a] -> [a]
++ [Char]
e
          Success UserCache
db -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. b -> Either a b
Right UserCache
db
    Bool
False -> do
      [Char] -> IO ()
putStrLn [Char]
"User JSON datafile not found. Creating a new one."
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right UserCache
defUserCache


------------------------------------------------------------------------------
data JsonFileAuthManager = JsonFileAuthManager {
    JsonFileAuthManager -> TVar UserCache
memcache :: TVar UserCache
  , JsonFileAuthManager -> [Char]
dbfile   :: FilePath
}


------------------------------------------------------------------------------
jsonFileSave :: JsonFileAuthManager
             -> AuthUser
             -> IO (Either AuthFailure AuthUser)
jsonFileSave :: JsonFileAuthManager -> AuthUser -> IO (Either AuthFailure AuthUser)
jsonFileSave JsonFileAuthManager
mgr AuthUser
u = do
    UTCTime
now        <- IO UTCTime
getCurrentTime
    Maybe AuthUser
oldByLogin <- forall r. IAuthBackend r => r -> Text -> IO (Maybe AuthUser)
lookupByLogin JsonFileAuthManager
mgr (AuthUser -> Text
userLogin AuthUser
u)
    Maybe AuthUser
oldById    <- case AuthUser -> Maybe UserId
userId AuthUser
u of
                    Maybe UserId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                    Just UserId
x  -> forall r. IAuthBackend r => r -> UserId -> IO (Maybe AuthUser)
lookupByUserId JsonFileAuthManager
mgr UserId
x

    Either AuthFailure (UserCache, AuthUser)
res <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
      UserCache
cache <- forall a. TVar a -> STM a
readTVar (JsonFileAuthManager -> TVar UserCache
memcache JsonFileAuthManager
mgr)
      Either AuthFailure (UserCache, AuthUser)
res   <- case AuthUser -> Maybe UserId
userId AuthUser
u of
                 Maybe UserId
Nothing -> UserCache
-> UTCTime
-> Maybe AuthUser
-> STM (Either AuthFailure (UserCache, AuthUser))
create UserCache
cache UTCTime
now Maybe AuthUser
oldByLogin
                 Just UserId
_  -> UserCache
-> UTCTime
-> Maybe AuthUser
-> STM (Either AuthFailure (UserCache, AuthUser))
update UserCache
cache UTCTime
now Maybe AuthUser
oldById
      case Either AuthFailure (UserCache, AuthUser)
res of
        Left AuthFailure
e             -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. a -> Either a b
Left AuthFailure
e
        Right (UserCache
cache', AuthUser
u') -> do
          forall a. TVar a -> a -> STM ()
writeTVar (JsonFileAuthManager -> TVar UserCache
memcache JsonFileAuthManager
mgr) UserCache
cache'
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! (UserCache
cache', AuthUser
u')

    case Either AuthFailure (UserCache, AuthUser)
res of
      Left AuthFailure
_             -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. a -> Either a b
Left AuthFailure
BackendError
      Right (UserCache
cache', AuthUser
u') -> do
        UserCache -> IO ()
dumpToDisk UserCache
cache'
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. b -> Either a b
Right AuthUser
u'

  where
    --------------------------------------------------------------------------
    create :: UserCache
           -> UTCTime
           -> (Maybe AuthUser)
           -> STM (Either AuthFailure (UserCache, AuthUser))
    create :: UserCache
-> UTCTime
-> Maybe AuthUser
-> STM (Either AuthFailure (UserCache, AuthUser))
create UserCache
cache UTCTime
now Maybe AuthUser
old = do
      case Maybe AuthUser
old of
        Just AuthUser
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. a -> Either a b
Left AuthFailure
DuplicateLogin
        Maybe AuthUser
Nothing -> do
          UserCache
new <- do
            let uid' :: UserId
uid' = Text -> UserId
UserId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text
showT forall a b. (a -> b) -> a -> b
$ UserCache -> Int
uidCounter UserCache
cache forall a. Num a => a -> a -> a
+ Int
1
            let u' :: AuthUser
u'   = AuthUser
u { userUpdatedAt :: Maybe UTCTime
userUpdatedAt = forall a. a -> Maybe a
Just UTCTime
now, userId :: Maybe UserId
userId = forall a. a -> Maybe a
Just UserId
uid' }
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! UserCache
cache {
              uidCache :: UserIdCache
uidCache   = forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert UserId
uid' AuthUser
u' forall a b. (a -> b) -> a -> b
$ UserCache -> UserIdCache
uidCache UserCache
cache
            , loginCache :: LoginUserCache
loginCache = forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert (AuthUser -> Text
userLogin AuthUser
u') UserId
uid' forall a b. (a -> b) -> a -> b
$ UserCache -> LoginUserCache
loginCache UserCache
cache
            , emailCache :: LoginUserCache
emailCache = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\Text
em -> forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert Text
em UserId
uid') (AuthUser -> Maybe Text
userEmail AuthUser
u) forall a b. (a -> b) -> a -> b
$
                           UserCache -> LoginUserCache
emailCache UserCache
cache
            , tokenCache :: LoginUserCache
tokenCache = case AuthUser -> Maybe Text
userRememberToken AuthUser
u' of
                             Maybe Text
Nothing -> UserCache -> LoginUserCache
tokenCache UserCache
cache
                             Just Text
x  -> forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert Text
x UserId
uid' forall a b. (a -> b) -> a -> b
$ UserCache -> LoginUserCache
tokenCache UserCache
cache
            , uidCounter :: Int
uidCounter = UserCache -> Int
uidCounter UserCache
cache forall a. Num a => a -> a -> a
+ Int
1
            }
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. b -> Either a b
Right (UserCache
new, UserCache -> AuthUser
getLastUser UserCache
new)

    --------------------------------------------------------------------------
    -- lookup old record, see what's changed and update indexes accordingly
    update :: UserCache
           -> UTCTime
           -> (Maybe AuthUser)
           -> STM (Either AuthFailure (UserCache, AuthUser))
    update :: UserCache
-> UTCTime
-> Maybe AuthUser
-> STM (Either AuthFailure (UserCache, AuthUser))
update UserCache
cache UTCTime
now Maybe AuthUser
old =
      case Maybe AuthUser
old of
        Maybe AuthUser
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. a -> Either a b
Left AuthFailure
UserNotFound
        Just AuthUser
x -> do
          let oldLogin :: Text
oldLogin = AuthUser -> Text
userLogin AuthUser
x
          let oldEmail :: Maybe Text
oldEmail = AuthUser -> Maybe Text
userEmail AuthUser
x
          let oldToken :: Maybe Text
oldToken = AuthUser -> Maybe Text
userRememberToken AuthUser
x
          let uid :: UserId
uid      = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe UserId
userId AuthUser
u
          let newLogin :: Text
newLogin = AuthUser -> Text
userLogin AuthUser
u
          let newEmail :: Maybe Text
newEmail = AuthUser -> Maybe Text
userEmail AuthUser
u
          let newToken :: Maybe Text
newToken = AuthUser -> Maybe Text
userRememberToken AuthUser
u

          let lc :: LoginUserCache
lc       = if Text
oldLogin forall a. Eq a => a -> a -> Bool
/= AuthUser -> Text
userLogin AuthUser
u
                           then forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert Text
newLogin UserId
uid forall a b. (a -> b) -> a -> b
$
                                forall k a. Ord k => k -> Map k a -> Map k a
HM.delete Text
oldLogin forall a b. (a -> b) -> a -> b
$
                                UserCache -> LoginUserCache
loginCache UserCache
cache
                           else UserCache -> LoginUserCache
loginCache UserCache
cache

          let ec :: LoginUserCache
ec       = if Maybe Text
oldEmail forall a. Eq a => a -> a -> Bool
/= Maybe Text
newEmail
                           then (case (Maybe Text
oldEmail, Maybe Text
newEmail) of
                                   (Maybe Text
Nothing, Maybe Text
Nothing) -> forall a. a -> a
id
                                   (Just Text
e,  Maybe Text
Nothing) -> forall k a. Ord k => k -> Map k a -> Map k a
HM.delete Text
e
                                   (Maybe Text
Nothing, Just Text
e ) -> forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert Text
e UserId
uid
                                   (Just Text
e,  Just Text
e') -> forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert Text
e' UserId
uid forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                                         forall k a. Ord k => k -> Map k a -> Map k a
HM.delete Text
e
                                ) (UserCache -> LoginUserCache
emailCache UserCache
cache)
                           else UserCache -> LoginUserCache
emailCache UserCache
cache

          let tc :: LoginUserCache
tc       = if Maybe Text
oldToken forall a. Eq a => a -> a -> Bool
/= Maybe Text
newToken Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe Text
oldToken
                           then forall k a. Ord k => k -> Map k a -> Map k a
HM.delete (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
oldToken) forall a b. (a -> b) -> a -> b
$ UserCache -> LoginUserCache
loginCache UserCache
cache
                           else UserCache -> LoginUserCache
tokenCache UserCache
cache

          let tc' :: LoginUserCache
tc'      = case Maybe Text
newToken of
                           Just Text
t  -> forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert Text
t UserId
uid LoginUserCache
tc
                           Maybe Text
Nothing -> LoginUserCache
tc

          let u' :: AuthUser
u'       = AuthUser
u { userUpdatedAt :: Maybe UTCTime
userUpdatedAt = forall a. a -> Maybe a
Just UTCTime
now }

          let new :: UserCache
new      = UserCache
cache {
                             uidCache :: UserIdCache
uidCache   = forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert UserId
uid AuthUser
u' forall a b. (a -> b) -> a -> b
$ UserCache -> UserIdCache
uidCache UserCache
cache
                           , loginCache :: LoginUserCache
loginCache = LoginUserCache
lc
                           , emailCache :: LoginUserCache
emailCache = LoginUserCache
ec
                           , tokenCache :: LoginUserCache
tokenCache = LoginUserCache
tc'
                         }

          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. b -> Either a b
Right (UserCache
new, AuthUser
u')

    --------------------------------------------------------------------------
    -- Sync user database to disk
    -- Need to implement a mutex here; simult syncs could screw things up
    dumpToDisk :: UserCache -> IO ()
dumpToDisk UserCache
c = [Char] -> ByteString -> IO ()
LB.writeFile (JsonFileAuthManager -> [Char]
dbfile JsonFileAuthManager
mgr) (forall a. ToJSON a => a -> ByteString
encode UserCache
c)

    --------------------------------------------------------------------------
    -- Gets the last added user
    getLastUser :: UserCache -> AuthUser
getLastUser UserCache
cache = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. a
e forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ UserCache -> UserId -> Maybe AuthUser
getUser UserCache
cache UserId
uid
      where
        uid :: UserId
uid = Text -> UserId
UserId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text
showT forall a b. (a -> b) -> a -> b
$ UserCache -> Int
uidCounter UserCache
cache
        e :: a
e   = forall a. HasCallStack => [Char] -> a
error [Char]
"getLastUser failed. This should not happen."


------------------------------------------------------------------------------
instance IAuthBackend JsonFileAuthManager where
  save :: JsonFileAuthManager -> AuthUser -> IO (Either AuthFailure AuthUser)
save = JsonFileAuthManager -> AuthUser -> IO (Either AuthFailure AuthUser)
jsonFileSave

  destroy :: JsonFileAuthManager -> AuthUser -> IO ()
destroy = forall a. HasCallStack => [Char] -> a
error [Char]
"JsonFile: destroy is not yet implemented"

  lookupByUserId :: JsonFileAuthManager -> UserId -> IO (Maybe AuthUser)
lookupByUserId JsonFileAuthManager
mgr UserId
uid = forall a. JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache JsonFileAuthManager
mgr UserCache -> Maybe AuthUser
f
    where
      f :: UserCache -> Maybe AuthUser
f UserCache
cache = UserCache -> UserId -> Maybe AuthUser
getUser UserCache
cache UserId
uid

  lookupByLogin :: JsonFileAuthManager -> Text -> IO (Maybe AuthUser)
lookupByLogin JsonFileAuthManager
mgr Text
login = forall a. JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache JsonFileAuthManager
mgr UserCache -> Maybe AuthUser
f
    where
      f :: UserCache -> Maybe AuthUser
f UserCache
cache = Maybe UserId
getUid forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UserCache -> UserId -> Maybe AuthUser
getUser UserCache
cache
        where getUid :: Maybe UserId
getUid = forall k a. Ord k => k -> Map k a -> Maybe a
HM.lookup Text
login (UserCache -> LoginUserCache
loginCache UserCache
cache)

  lookupByEmail :: JsonFileAuthManager -> Text -> IO (Maybe AuthUser)
lookupByEmail JsonFileAuthManager
mgr Text
email = forall a. JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache JsonFileAuthManager
mgr UserCache -> Maybe AuthUser
f
    where
      f :: UserCache -> Maybe AuthUser
f UserCache
cache = Maybe UserId
getEmail forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UserCache -> UserId -> Maybe AuthUser
getUser UserCache
cache
        where getEmail :: Maybe UserId
getEmail = case forall k a. Ord k => k -> Map k a -> Maybe a
HM.lookup Text
email (UserCache -> LoginUserCache
emailCache UserCache
cache) of
                      Just UserId
u  -> forall (m :: * -> *) a. Monad m => a -> m a
return UserId
u
                      Maybe UserId
Nothing -> (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AuthUser -> Maybe UserId
userId forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                  forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
HM.elems forall a b. (a -> b) -> a -> b
$
                                  forall a k. (a -> Bool) -> Map k a -> Map k a
HM.filter ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
email) forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthUser -> Maybe Text
userEmail)
                                  (UserCache -> UserIdCache
uidCache  UserCache
cache))

  lookupByRememberToken :: JsonFileAuthManager -> Text -> IO (Maybe AuthUser)
lookupByRememberToken JsonFileAuthManager
mgr Text
token = forall a. JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache JsonFileAuthManager
mgr UserCache -> Maybe AuthUser
f
    where
      f :: UserCache -> Maybe AuthUser
f UserCache
cache = Maybe UserId
getUid forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UserCache -> UserId -> Maybe AuthUser
getUser UserCache
cache
        where
          getUid :: Maybe UserId
getUid = forall k a. Ord k => k -> Map k a -> Maybe a
HM.lookup Text
token (UserCache -> LoginUserCache
tokenCache UserCache
cache)


------------------------------------------------------------------------------
withCache :: JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache :: forall a. JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache JsonFileAuthManager
mgr UserCache -> a
f = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
  UserCache
cache <- forall a. TVar a -> STM a
readTVar forall a b. (a -> b) -> a -> b
$ JsonFileAuthManager -> TVar UserCache
memcache JsonFileAuthManager
mgr
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! UserCache -> a
f UserCache
cache


------------------------------------------------------------------------------
getUser :: UserCache -> UserId -> Maybe AuthUser
getUser :: UserCache -> UserId -> Maybe AuthUser
getUser UserCache
cache UserId
uid = forall k a. Ord k => k -> Map k a -> Maybe a
HM.lookup UserId
uid (UserCache -> UserIdCache
uidCache UserCache
cache)


------------------------------------------------------------------------------
showT :: Int -> Text
showT :: Int -> Text
showT = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show


                             --------------------
                             -- JSON Instances --
                             --------------------

------------------------------------------------------------------------------
instance ToJSON UserCache where
  toJSON :: UserCache -> Value
toJSON UserCache
uc = [Pair] -> Value
object
    [ Key
"uidCache"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UserCache -> UserIdCache
uidCache   UserCache
uc
    , Key
"loginCache" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UserCache -> LoginUserCache
loginCache UserCache
uc
    , Key
"emailCache" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UserCache -> LoginUserCache
emailCache UserCache
uc
    , Key
"tokenCache" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UserCache -> LoginUserCache
tokenCache UserCache
uc
    , Key
"uidCounter" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UserCache -> Int
uidCounter UserCache
uc
    ]


------------------------------------------------------------------------------
instance FromJSON UserCache where
  parseJSON :: Value -> Parser UserCache
parseJSON (Object Object
v) =
    UserIdCache
-> LoginUserCache
-> LoginUserCache
-> LoginUserCache
-> Int
-> UserCache
UserCache
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"uidCache"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"loginCache"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"emailCache" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty) -- Old versions of users.json do
                                              -- not carry this field
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tokenCache"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"uidCounter"
  parseJSON Value
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected JSON input"