{-# 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
initJsonFileAuthManager :: AuthSettings
-> SnapletLens b SessionManager
-> FilePath
-> 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
}
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)
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
data UserCache = UserCache {
UserCache -> UserIdCache
uidCache :: UserIdCache
, UserCache -> LoginUserCache
loginCache :: LoginUserCache
, UserCache -> LoginUserCache
emailCache :: EmailUserCache
, UserCache -> LoginUserCache
tokenCache :: RemTokenUserCache
, UserCache -> Int
uidCounter :: Int
}
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)
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')
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)
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
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)
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"