{-# 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           Data.Aeson.Parser (json)
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
    Text
-> Text
-> Maybe (IO [Char])
-> Initializer b (AuthManager b) (AuthManager b)
-> SnapletInit b (AuthManager b)
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"
        Maybe (IO [Char])
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 a. IO a -> Initializer b (AuthManager b) a
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 a. IO a -> IO a
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
            AuthManager b -> IO (AuthManager b)
forall a. a -> IO a
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 {
                         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
                       }


------------------------------------------------------------------------------
-- | 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  -> [Char] -> UserCache
forall a. HasCallStack => [Char] -> a
error [Char]
e
              Right UserCache
x -> UserCache
x
  TVar UserCache
cache <- UserCache -> IO (TVar UserCache)
forall a. a -> IO (TVar a)
newTVarIO UserCache
db'

  JsonFileAuthManager -> IO JsonFileAuthManager
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonFileAuthManager -> IO JsonFileAuthManager)
-> JsonFileAuthManager -> IO JsonFileAuthManager
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   = 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 = 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 Parser Value -> ByteString -> Either [Char] Value
forall a. Parser a -> ByteString -> Either [Char] a
Atto.parseOnly Parser Value
json ByteString
d of
        Left [Char]
e  -> Either [Char] UserCache -> IO (Either [Char] UserCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] UserCache -> IO (Either [Char] UserCache))
-> Either [Char] UserCache -> IO (Either [Char] UserCache)
forall a b. (a -> b) -> a -> b
$! [Char] -> Either [Char] UserCache
forall a b. a -> Either a b
Left ([Char] -> Either [Char] UserCache)
-> [Char] -> Either [Char] UserCache
forall a b. (a -> b) -> a -> b
$
                       [Char]
"Can't open JSON auth backend. Error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
e
        Right Value
v -> case Value -> Result UserCache
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
          Error [Char]
e    -> Either [Char] UserCache -> IO (Either [Char] UserCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] UserCache -> IO (Either [Char] UserCache))
-> Either [Char] UserCache -> IO (Either [Char] UserCache)
forall a b. (a -> b) -> a -> b
$! [Char] -> Either [Char] UserCache
forall a b. a -> Either a b
Left ([Char] -> Either [Char] UserCache)
-> [Char] -> Either [Char] UserCache
forall a b. (a -> b) -> a -> b
$
                        [Char]
"Malformed JSON auth data store. Error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
e
          Success UserCache
db -> Either [Char] UserCache -> IO (Either [Char] UserCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] UserCache -> IO (Either [Char] UserCache))
-> Either [Char] UserCache -> IO (Either [Char] UserCache)
forall a b. (a -> b) -> a -> b
$! UserCache -> Either [Char] UserCache
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."
      Either [Char] UserCache -> IO (Either [Char] UserCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] UserCache -> IO (Either [Char] UserCache))
-> Either [Char] UserCache -> IO (Either [Char] UserCache)
forall a b. (a -> b) -> a -> b
$ UserCache -> Either [Char] UserCache
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 <- 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
                    Maybe UserId
Nothing -> Maybe AuthUser -> IO (Maybe AuthUser)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
forall a. Maybe a
Nothing
                    Just 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
                 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             -> Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall a. a -> STM a
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 (UserCache
cache', 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 a. a -> STM a
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 AuthFailure
_             -> Either AuthFailure AuthUser -> IO (Either AuthFailure AuthUser)
forall a. a -> IO a
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 (UserCache
cache', AuthUser
u') -> do
        UserCache -> IO ()
dumpToDisk UserCache
cache'
        Either AuthFailure AuthUser -> IO (Either AuthFailure AuthUser)
forall a. a -> IO a
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 UserCache
cache UTCTime
now Maybe AuthUser
old = do
      case Maybe AuthUser
old of
        Just AuthUser
_  -> Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall a. a -> STM a
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
        Maybe AuthUser
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
+ Int
1
            let u' :: AuthUser
u'   = AuthUser
u { userUpdatedAt = Just now, userId = Just uid' }
            UserCache -> STM UserCache
forall a. a -> STM a
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   = HM.insert uid' u' $ uidCache cache
            , loginCache = HM.insert (userLogin u') uid' $ loginCache cache
            , emailCache = maybe id (\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') (userEmail u) $
                           emailCache cache
            , tokenCache = case userRememberToken u' of
                             Maybe Text
Nothing -> UserCache -> LoginUserCache
tokenCache UserCache
cache
                             Just 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 = uidCounter cache + 1
            }
          Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall a. a -> STM a
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)

    --------------------------------------------------------------------------
    -- 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 -> Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall a. a -> STM a
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 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
                                   (Maybe Text
Nothing, Maybe Text
Nothing) -> LoginUserCache -> LoginUserCache
forall a. a -> a
id
                                   (Just Text
e,  Maybe Text
Nothing) -> Text -> LoginUserCache -> LoginUserCache
forall k a. Ord k => k -> Map k a -> Map k a
HM.delete Text
e
                                   (Maybe Text
Nothing, Just 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 Text
e,  Just 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 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
                           Maybe Text
Nothing -> LoginUserCache
tc

          let u' :: AuthUser
u'       = AuthUser
u { userUpdatedAt = Just now }

          let new :: UserCache
new      = UserCache
cache {
                             uidCache   = HM.insert uid u' $ uidCache cache
                           , loginCache = lc
                           , emailCache = ec
                           , tokenCache = tc'
                         }

          Either AuthFailure (UserCache, AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
forall a. a -> STM a
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')

    --------------------------------------------------------------------------
    -- 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) (UserCache -> ByteString
forall a. ToJSON a => a -> ByteString
encode UserCache
c)

    --------------------------------------------------------------------------
    -- Gets the last added user
    getLastUser :: UserCache -> AuthUser
getLastUser 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   = [Char] -> a
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 = [Char] -> JsonFileAuthManager -> AuthUser -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"JsonFile: destroy is not yet implemented"

  lookupByUserId :: JsonFileAuthManager -> UserId -> IO (Maybe AuthUser)
lookupByUserId JsonFileAuthManager
mgr 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 UserCache
cache = UserCache -> UserId -> Maybe AuthUser
getUser UserCache
cache UserId
uid

  lookupByLogin :: JsonFileAuthManager -> Text -> IO (Maybe AuthUser)
lookupByLogin JsonFileAuthManager
mgr 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 UserCache
cache = Maybe UserId
getUid Maybe UserId -> (UserId -> Maybe AuthUser) -> Maybe AuthUser
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 JsonFileAuthManager
mgr 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 UserCache
cache = Maybe UserId
getEmail Maybe UserId -> (UserId -> Maybe AuthUser) -> Maybe AuthUser
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 UserId
u  -> UserId -> Maybe UserId
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return UserId
u
                      Maybe UserId
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 a b. (a -> b) -> Maybe a -> Maybe b
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 JsonFileAuthManager
mgr 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 UserCache
cache = Maybe UserId
getUid Maybe UserId -> (UserId -> Maybe AuthUser) -> Maybe AuthUser
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 :: forall a. JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache JsonFileAuthManager
mgr 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 a. 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 UserCache
cache 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 = [Char] -> Text
T.pack ([Char] -> Text) -> (Int -> [Char]) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show


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

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


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