    {-# 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"