{-# 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.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 :: AuthSettings
-> SnapletLens b SessionManager
-> FilePath
-> SnapletInit b (AuthManager b)
initJsonFileAuthManager s :: AuthSettings
s l :: SnapletLens b SessionManager
l db :: FilePath
db = do
Text
-> Text
-> Maybe (IO FilePath)
-> Initializer b (AuthManager b) (AuthManager b)
-> SnapletInit b (AuthManager b)
forall b v.
Text
-> Text
-> Maybe (IO FilePath)
-> Initializer b v v
-> SnapletInit b v
makeSnaplet
"JsonFileAuthManager"
"A snaplet providing user authentication using a JSON-file backend"
Maybe (IO FilePath)
forall a. Maybe a
Nothing (Initializer b (AuthManager b) (AuthManager b)
-> SnapletInit b (AuthManager b))
-> Initializer b (AuthManager b) (AuthManager b)
-> SnapletInit b (AuthManager b)
forall a b. (a -> b) -> a -> b
$ IO (AuthManager b) -> Initializer b (AuthManager b) (AuthManager b)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (AuthManager b)
-> Initializer b (AuthManager b) (AuthManager b))
-> IO (AuthManager b)
-> Initializer b (AuthManager b) (AuthManager b)
forall a b. (a -> b) -> a -> b
$ do
RNG
rng <- IO RNG -> IO RNG
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO RNG
mkRNG
Key
key <- FilePath -> IO Key
getKey (AuthSettings -> FilePath
asSiteKey AuthSettings
s)
JsonFileAuthManager
jsonMgr <- FilePath -> IO JsonFileAuthManager
mkJsonAuthMgr FilePath
db
AuthManager b -> IO (AuthManager b)
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthManager b -> IO (AuthManager b))
-> AuthManager b -> IO (AuthManager b)
forall a b. (a -> b) -> a -> b
$! AuthManager :: forall b r.
IAuthBackend r =>
r
-> SnapletLens b SessionManager
-> Maybe AuthUser
-> Int
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> Key
-> Maybe (Int, NominalDiffTime)
-> RNG
-> AuthManager b
AuthManager {
backend :: JsonFileAuthManager
backend = JsonFileAuthManager
jsonMgr
, session :: SnapletLens b SessionManager
session = SnapletLens b SessionManager
l
, activeUser :: Maybe AuthUser
activeUser = Maybe AuthUser
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 = Maybe ByteString
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 :: FilePath -> IO JsonFileAuthManager
mkJsonAuthMgr fp :: FilePath
fp = do
Either FilePath UserCache
db <- FilePath -> IO (Either FilePath UserCache)
loadUserCache FilePath
fp
let db' :: UserCache
db' = case Either FilePath UserCache
db of
Left e :: FilePath
e -> FilePath -> UserCache
forall a. HasCallStack => FilePath -> a
error FilePath
e
Right x :: UserCache
x -> UserCache
x
TVar UserCache
cache <- UserCache -> IO (TVar UserCache)
forall a. a -> IO (TVar a)
newTVarIO UserCache
db'
JsonFileAuthManager -> IO JsonFileAuthManager
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonFileAuthManager -> IO JsonFileAuthManager)
-> JsonFileAuthManager -> IO JsonFileAuthManager
forall a b. (a -> b) -> a -> b
$! JsonFileAuthManager :: TVar UserCache -> FilePath -> JsonFileAuthManager
JsonFileAuthManager {
memcache :: TVar UserCache
memcache = TVar UserCache
cache
, dbfile :: FilePath
dbfile = FilePath
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 :: UserIdCache
-> LoginUserCache
-> LoginUserCache
-> LoginUserCache
-> Int
-> UserCache
UserCache {
uidCache :: UserIdCache
uidCache = UserIdCache
forall k a. Map k a
HM.empty
, loginCache :: LoginUserCache
loginCache = LoginUserCache
forall k a. Map k a
HM.empty
, emailCache :: LoginUserCache
emailCache = LoginUserCache
forall k a. Map k a
HM.empty
, tokenCache :: LoginUserCache
tokenCache = LoginUserCache
forall k a. Map k a
HM.empty
, uidCounter :: Int
uidCounter = 0
}
loadUserCache :: FilePath -> IO (Either String UserCache)
loadUserCache :: FilePath -> IO (Either FilePath UserCache)
loadUserCache fp :: FilePath
fp = do
Bool
chk <- FilePath -> IO Bool
doesFileExist FilePath
fp
case Bool
chk of
True -> do
ByteString
d <- FilePath -> IO ByteString
B.readFile FilePath
fp
case Parser Value -> ByteString -> Either FilePath Value
forall a. Parser a -> ByteString -> Either FilePath a
Atto.parseOnly Parser Value
json ByteString
d of
Left e :: FilePath
e -> Either FilePath UserCache -> IO (Either FilePath UserCache)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath UserCache -> IO (Either FilePath UserCache))
-> Either FilePath UserCache -> IO (Either FilePath UserCache)
forall a b. (a -> b) -> a -> b
$! FilePath -> Either FilePath UserCache
forall a b. a -> Either a b
Left (FilePath -> Either FilePath UserCache)
-> FilePath -> Either FilePath UserCache
forall a b. (a -> b) -> a -> b
$
"Can't open JSON auth backend. Error: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
e
Right v :: Value
v -> case Value -> Result UserCache
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
Error e :: FilePath
e -> Either FilePath UserCache -> IO (Either FilePath UserCache)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath UserCache -> IO (Either FilePath UserCache))
-> Either FilePath UserCache -> IO (Either FilePath UserCache)
forall a b. (a -> b) -> a -> b
$! FilePath -> Either FilePath UserCache
forall a b. a -> Either a b
Left (FilePath -> Either FilePath UserCache)
-> FilePath -> Either FilePath UserCache
forall a b. (a -> b) -> a -> b
$
"Malformed JSON auth data store. Error: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
e
Success db :: UserCache
db -> Either FilePath UserCache -> IO (Either FilePath UserCache)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath UserCache -> IO (Either FilePath UserCache))
-> Either FilePath UserCache -> IO (Either FilePath UserCache)
forall a b. (a -> b) -> a -> b
$! UserCache -> Either FilePath UserCache
forall a b. b -> Either a b
Right UserCache
db
False -> do
FilePath -> IO ()
putStrLn "User JSON datafile not found. Creating a new one."
Either FilePath UserCache -> IO (Either FilePath UserCache)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath UserCache -> IO (Either FilePath UserCache))
-> Either FilePath UserCache -> IO (Either FilePath UserCache)
forall a b. (a -> b) -> a -> b
$ UserCache -> Either FilePath UserCache
forall a b. b -> Either a b
Right UserCache
defUserCache
data JsonFileAuthManager = JsonFileAuthManager {
JsonFileAuthManager -> TVar UserCache
memcache :: TVar UserCache
, JsonFileAuthManager -> FilePath
dbfile :: FilePath
}
jsonFileSave :: JsonFileAuthManager
-> AuthUser
-> IO (Either AuthFailure AuthUser)
jsonFileSave :: JsonFileAuthManager -> AuthUser -> IO (Either AuthFailure AuthUser)
jsonFileSave mgr :: JsonFileAuthManager
mgr u :: AuthUser
u = do
UTCTime
now <- IO UTCTime
getCurrentTime
Maybe AuthUser
oldByLogin <- JsonFileAuthManager -> Text -> IO (Maybe AuthUser)
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
Nothing -> Maybe AuthUser -> IO (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
forall a. Maybe a
Nothing
Just x :: UserId
x -> JsonFileAuthManager -> UserId -> IO (Maybe AuthUser)
forall r. IAuthBackend r => r -> UserId -> IO (Maybe AuthUser)
lookupByUserId JsonFileAuthManager
mgr UserId
x
Either AuthFailure (UserCache, AuthUser)
res <- STM (Either AuthFailure (UserCache, AuthUser))
-> IO (Either AuthFailure (UserCache, AuthUser))
forall a. STM a -> IO a
atomically (STM (Either AuthFailure (UserCache, AuthUser))
-> IO (Either AuthFailure (UserCache, AuthUser)))
-> STM (Either AuthFailure (UserCache, AuthUser))
-> IO (Either AuthFailure (UserCache, AuthUser))
forall a b. (a -> b) -> a -> b
$ do
UserCache
cache <- TVar UserCache -> STM UserCache
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
Nothing -> UserCache
-> UTCTime
-> Maybe AuthUser
-> STM (Either AuthFailure (UserCache, AuthUser))
create UserCache
cache UTCTime
now Maybe AuthUser
oldByLogin
Just _ -> 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 e :: AuthFailure
e -> Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser)))
-> Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall a b. (a -> b) -> a -> b
$! AuthFailure -> Either AuthFailure (UserCache, AuthUser)
forall a b. a -> Either a b
Left AuthFailure
e
Right (cache' :: UserCache
cache', u' :: AuthUser
u') -> do
TVar UserCache -> UserCache -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (JsonFileAuthManager -> TVar UserCache
memcache JsonFileAuthManager
mgr) UserCache
cache'
Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser)))
-> Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall a b. (a -> b) -> a -> b
$! (UserCache, AuthUser) -> Either AuthFailure (UserCache, AuthUser)
forall a b. b -> Either a b
Right ((UserCache, AuthUser) -> Either AuthFailure (UserCache, AuthUser))
-> (UserCache, AuthUser)
-> Either AuthFailure (UserCache, AuthUser)
forall a b. (a -> b) -> a -> b
$! (UserCache
cache', AuthUser
u')
case Either AuthFailure (UserCache, AuthUser)
res of
Left _ -> Either AuthFailure AuthUser -> IO (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser -> IO (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser -> IO (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$! AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
BackendError
Right (cache' :: UserCache
cache', u' :: AuthUser
u') -> do
UserCache -> IO ()
dumpToDisk UserCache
cache'
Either AuthFailure AuthUser -> IO (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser -> IO (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser -> IO (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$! AuthUser -> Either AuthFailure AuthUser
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 cache :: UserCache
cache now :: UTCTime
now old :: Maybe AuthUser
old = do
case Maybe AuthUser
old of
Just _ -> Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser)))
-> Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall a b. (a -> b) -> a -> b
$! AuthFailure -> Either AuthFailure (UserCache, AuthUser)
forall a b. a -> Either a b
Left AuthFailure
DuplicateLogin
Nothing -> do
UserCache
new <- do
let uid' :: UserId
uid' = Text -> UserId
UserId (Text -> UserId) -> (Int -> Text) -> Int -> UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text
showT (Int -> UserId) -> Int -> UserId
forall a b. (a -> b) -> a -> b
$ UserCache -> Int
uidCounter UserCache
cache Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
let u' :: AuthUser
u' = AuthUser
u { userUpdatedAt :: Maybe UTCTime
userUpdatedAt = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
now, userId :: Maybe UserId
userId = UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
uid' }
UserCache -> STM UserCache
forall (m :: * -> *) a. Monad m => a -> m a
return (UserCache -> STM UserCache) -> UserCache -> STM UserCache
forall a b. (a -> b) -> a -> b
$! UserCache
cache {
uidCache :: UserIdCache
uidCache = UserId -> AuthUser -> UserIdCache -> UserIdCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert UserId
uid' AuthUser
u' (UserIdCache -> UserIdCache) -> UserIdCache -> UserIdCache
forall a b. (a -> b) -> a -> b
$ UserCache -> UserIdCache
uidCache UserCache
cache
, loginCache :: LoginUserCache
loginCache = Text -> UserId -> LoginUserCache -> LoginUserCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert (AuthUser -> Text
userLogin AuthUser
u') UserId
uid' (LoginUserCache -> LoginUserCache)
-> LoginUserCache -> LoginUserCache
forall a b. (a -> b) -> a -> b
$ UserCache -> LoginUserCache
loginCache UserCache
cache
, emailCache :: LoginUserCache
emailCache = (LoginUserCache -> LoginUserCache)
-> (Text -> LoginUserCache -> LoginUserCache)
-> Maybe Text
-> LoginUserCache
-> LoginUserCache
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LoginUserCache -> LoginUserCache
forall a. a -> a
id (\em :: Text
em -> Text -> UserId -> LoginUserCache -> LoginUserCache
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) (LoginUserCache -> LoginUserCache)
-> LoginUserCache -> LoginUserCache
forall a b. (a -> b) -> a -> b
$
UserCache -> LoginUserCache
emailCache UserCache
cache
, tokenCache :: LoginUserCache
tokenCache = case AuthUser -> Maybe Text
userRememberToken AuthUser
u' of
Nothing -> UserCache -> LoginUserCache
tokenCache UserCache
cache
Just x :: Text
x -> Text -> UserId -> LoginUserCache -> LoginUserCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert Text
x UserId
uid' (LoginUserCache -> LoginUserCache)
-> LoginUserCache -> LoginUserCache
forall a b. (a -> b) -> a -> b
$ UserCache -> LoginUserCache
tokenCache UserCache
cache
, uidCounter :: Int
uidCounter = UserCache -> Int
uidCounter UserCache
cache Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
}
Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser)))
-> Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall a b. (a -> b) -> a -> b
$! (UserCache, AuthUser) -> Either AuthFailure (UserCache, AuthUser)
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 cache :: UserCache
cache now :: UTCTime
now old :: Maybe AuthUser
old =
case Maybe AuthUser
old of
Nothing -> Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser)))
-> Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall a b. (a -> b) -> a -> b
$! AuthFailure -> Either AuthFailure (UserCache, AuthUser)
forall a b. a -> Either a b
Left AuthFailure
UserNotFound
Just x :: 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 = Maybe UserId -> UserId
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe UserId -> UserId) -> Maybe UserId -> UserId
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= AuthUser -> Text
userLogin AuthUser
u
then Text -> UserId -> LoginUserCache -> LoginUserCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert Text
newLogin UserId
uid (LoginUserCache -> LoginUserCache)
-> LoginUserCache -> LoginUserCache
forall a b. (a -> b) -> a -> b
$
Text -> LoginUserCache -> LoginUserCache
forall k a. Ord k => k -> Map k a -> Map k a
HM.delete Text
oldLogin (LoginUserCache -> LoginUserCache)
-> LoginUserCache -> LoginUserCache
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 Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Text
newEmail
then (case (Maybe Text
oldEmail, Maybe Text
newEmail) of
(Nothing, Nothing) -> LoginUserCache -> LoginUserCache
forall a. a -> a
id
(Just e :: Text
e, Nothing) -> Text -> LoginUserCache -> LoginUserCache
forall k a. Ord k => k -> Map k a -> Map k a
HM.delete Text
e
(Nothing, Just e :: Text
e ) -> Text -> UserId -> LoginUserCache -> LoginUserCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert Text
e UserId
uid
(Just e :: Text
e, Just e' :: Text
e') -> Text -> UserId -> LoginUserCache -> LoginUserCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert Text
e' UserId
uid (LoginUserCache -> LoginUserCache)
-> (LoginUserCache -> LoginUserCache)
-> LoginUserCache
-> LoginUserCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Text -> LoginUserCache -> LoginUserCache
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 Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Text
newToken Bool -> Bool -> Bool
&& Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
oldToken
then Text -> LoginUserCache -> LoginUserCache
forall k a. Ord k => k -> Map k a -> Map k a
HM.delete (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
oldToken) (LoginUserCache -> LoginUserCache)
-> LoginUserCache -> LoginUserCache
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 t :: Text
t -> Text -> UserId -> LoginUserCache -> LoginUserCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert Text
t UserId
uid LoginUserCache
tc
Nothing -> LoginUserCache
tc
let u' :: AuthUser
u' = AuthUser
u { userUpdatedAt :: Maybe UTCTime
userUpdatedAt = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
now }
let new :: UserCache
new = UserCache
cache {
uidCache :: UserIdCache
uidCache = UserId -> AuthUser -> UserIdCache -> UserIdCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
HM.insert UserId
uid AuthUser
u' (UserIdCache -> UserIdCache) -> UserIdCache -> UserIdCache
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'
}
Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser)))
-> Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall a b. (a -> b) -> a -> b
$! (UserCache, AuthUser) -> Either AuthFailure (UserCache, AuthUser)
forall a b. b -> Either a b
Right (UserCache
new, AuthUser
u')
dumpToDisk :: UserCache -> IO ()
dumpToDisk c :: UserCache
c = FilePath -> ByteString -> IO ()
LB.writeFile (JsonFileAuthManager -> FilePath
dbfile JsonFileAuthManager
mgr) (UserCache -> ByteString
forall a. ToJSON a => a -> ByteString
encode UserCache
c)
getLastUser :: UserCache -> AuthUser
getLastUser cache :: UserCache
cache = AuthUser -> (AuthUser -> AuthUser) -> Maybe AuthUser -> AuthUser
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AuthUser
forall a. a
e AuthUser -> AuthUser
forall a. a -> a
id (Maybe AuthUser -> AuthUser) -> Maybe AuthUser -> AuthUser
forall a b. (a -> b) -> a -> b
$ UserCache -> UserId -> Maybe AuthUser
getUser UserCache
cache UserId
uid
where
uid :: UserId
uid = Text -> UserId
UserId (Text -> UserId) -> (Int -> Text) -> Int -> UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text
showT (Int -> UserId) -> Int -> UserId
forall a b. (a -> b) -> a -> b
$ UserCache -> Int
uidCounter UserCache
cache
e :: a
e = FilePath -> a
forall a. HasCallStack => FilePath -> a
error "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 = FilePath -> JsonFileAuthManager -> AuthUser -> IO ()
forall a. HasCallStack => FilePath -> a
error "JsonFile: destroy is not yet implemented"
lookupByUserId :: JsonFileAuthManager -> UserId -> IO (Maybe AuthUser)
lookupByUserId mgr :: JsonFileAuthManager
mgr uid :: UserId
uid = JsonFileAuthManager
-> (UserCache -> Maybe AuthUser) -> IO (Maybe AuthUser)
forall a. JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache JsonFileAuthManager
mgr UserCache -> Maybe AuthUser
f
where
f :: UserCache -> Maybe AuthUser
f cache :: UserCache
cache = UserCache -> UserId -> Maybe AuthUser
getUser UserCache
cache UserId
uid
lookupByLogin :: JsonFileAuthManager -> Text -> IO (Maybe AuthUser)
lookupByLogin mgr :: JsonFileAuthManager
mgr login :: Text
login = JsonFileAuthManager
-> (UserCache -> Maybe AuthUser) -> IO (Maybe AuthUser)
forall a. JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache JsonFileAuthManager
mgr UserCache -> Maybe AuthUser
f
where
f :: UserCache -> Maybe AuthUser
f cache :: UserCache
cache = Maybe UserId
getUid Maybe UserId -> (UserId -> Maybe AuthUser) -> Maybe AuthUser
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 = Text -> LoginUserCache -> Maybe UserId
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 mgr :: JsonFileAuthManager
mgr email :: Text
email = JsonFileAuthManager
-> (UserCache -> Maybe AuthUser) -> IO (Maybe AuthUser)
forall a. JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache JsonFileAuthManager
mgr UserCache -> Maybe AuthUser
f
where
f :: UserCache -> Maybe AuthUser
f cache :: UserCache
cache = Maybe UserId
getEmail Maybe UserId -> (UserId -> Maybe AuthUser) -> Maybe AuthUser
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 Text -> LoginUserCache -> Maybe UserId
forall k a. Ord k => k -> Map k a -> Maybe a
HM.lookup Text
email (UserCache -> LoginUserCache
emailCache UserCache
cache) of
Just u :: UserId
u -> UserId -> Maybe UserId
forall (m :: * -> *) a. Monad m => a -> m a
return UserId
u
Nothing -> (Maybe (Maybe UserId) -> Maybe UserId
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe UserId) -> Maybe UserId)
-> (UserIdCache -> Maybe (Maybe UserId))
-> UserIdCache
-> Maybe UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AuthUser -> Maybe UserId)
-> Maybe AuthUser -> Maybe (Maybe UserId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AuthUser -> Maybe UserId
userId (Maybe AuthUser -> Maybe (Maybe UserId))
-> (UserIdCache -> Maybe AuthUser)
-> UserIdCache
-> Maybe (Maybe UserId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
[AuthUser] -> Maybe AuthUser
forall a. [a] -> Maybe a
listToMaybe ([AuthUser] -> Maybe AuthUser)
-> (UserIdCache -> [AuthUser]) -> UserIdCache -> Maybe AuthUser
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserIdCache -> [AuthUser]
forall k a. Map k a -> [a]
HM.elems (UserIdCache -> Maybe UserId) -> UserIdCache -> Maybe UserId
forall a b. (a -> b) -> a -> b
$
(AuthUser -> Bool) -> UserIdCache -> UserIdCache
forall a k. (a -> Bool) -> Map k a -> Map k a
HM.filter ((Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
email) (Maybe Text -> Bool)
-> (AuthUser -> Maybe Text) -> AuthUser -> Bool
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 mgr :: JsonFileAuthManager
mgr token :: Text
token = JsonFileAuthManager
-> (UserCache -> Maybe AuthUser) -> IO (Maybe AuthUser)
forall a. JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache JsonFileAuthManager
mgr UserCache -> Maybe AuthUser
f
where
f :: UserCache -> Maybe AuthUser
f cache :: UserCache
cache = Maybe UserId
getUid Maybe UserId -> (UserId -> Maybe AuthUser) -> Maybe AuthUser
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 = Text -> LoginUserCache -> Maybe UserId
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 :: JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache mgr :: JsonFileAuthManager
mgr f :: UserCache -> a
f = STM a -> IO a
forall a. STM a -> IO a
atomically (STM a -> IO a) -> STM a -> IO a
forall a b. (a -> b) -> a -> b
$ do
UserCache
cache <- TVar UserCache -> STM UserCache
forall a. TVar a -> STM a
readTVar (TVar UserCache -> STM UserCache)
-> TVar UserCache -> STM UserCache
forall a b. (a -> b) -> a -> b
$ JsonFileAuthManager -> TVar UserCache
memcache JsonFileAuthManager
mgr
a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> STM a) -> a -> STM a
forall a b. (a -> b) -> a -> b
$! UserCache -> a
f UserCache
cache
getUser :: UserCache -> UserId -> Maybe AuthUser
getUser :: UserCache -> UserId -> Maybe AuthUser
getUser cache :: UserCache
cache uid :: UserId
uid = UserId -> UserIdCache -> Maybe AuthUser
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 = FilePath -> Text
T.pack (FilePath -> Text) -> (Int -> FilePath) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath
forall a. Show a => a -> FilePath
show
instance ToJSON UserCache where
toJSON :: UserCache -> Value
toJSON uc :: UserCache
uc = [Pair] -> Value
object
[ "uidCache" Text -> UserIdCache -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= UserCache -> UserIdCache
uidCache UserCache
uc
, "loginCache" Text -> LoginUserCache -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= UserCache -> LoginUserCache
loginCache UserCache
uc
, "emailCache" Text -> LoginUserCache -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= UserCache -> LoginUserCache
emailCache UserCache
uc
, "tokenCache" Text -> LoginUserCache -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= UserCache -> LoginUserCache
tokenCache UserCache
uc
, "uidCounter" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= UserCache -> Int
uidCounter UserCache
uc
]
instance FromJSON UserCache where
parseJSON :: Value -> Parser UserCache
parseJSON (Object v :: Object
v) =
UserIdCache
-> LoginUserCache
-> LoginUserCache
-> LoginUserCache
-> Int
-> UserCache
UserCache
(UserIdCache
-> LoginUserCache
-> LoginUserCache
-> LoginUserCache
-> Int
-> UserCache)
-> Parser UserIdCache
-> Parser
(LoginUserCache
-> LoginUserCache -> LoginUserCache -> Int -> UserCache)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser UserIdCache
forall a. FromJSON a => Object -> Text -> Parser a
.: "uidCache"
Parser
(LoginUserCache
-> LoginUserCache -> LoginUserCache -> Int -> UserCache)
-> Parser LoginUserCache
-> Parser (LoginUserCache -> LoginUserCache -> Int -> UserCache)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser LoginUserCache
forall a. FromJSON a => Object -> Text -> Parser a
.: "loginCache"
Parser (LoginUserCache -> LoginUserCache -> Int -> UserCache)
-> Parser LoginUserCache
-> Parser (LoginUserCache -> Int -> UserCache)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
v Object -> Text -> Parser LoginUserCache
forall a. FromJSON a => Object -> Text -> Parser a
.: "emailCache" Parser LoginUserCache
-> Parser LoginUserCache -> Parser LoginUserCache
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LoginUserCache -> Parser LoginUserCache
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoginUserCache
forall a. Monoid a => a
mempty)
Parser (LoginUserCache -> Int -> UserCache)
-> Parser LoginUserCache -> Parser (Int -> UserCache)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser LoginUserCache
forall a. FromJSON a => Object -> Text -> Parser a
.: "tokenCache"
Parser (Int -> UserCache) -> Parser Int -> Parser UserCache
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: "uidCounter"
parseJSON _ = FilePath -> Parser UserCache
forall a. HasCallStack => FilePath -> a
error "Unexpected JSON input"