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



------------------------------------------------------------------------------
-- | 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 s l db = do
    makeSnaplet
        "JsonFileAuthManager"
        "A snaplet providing user authentication using a JSON-file backend"
        Nothing $ liftIO $ do
            rng <- liftIO mkRNG
            key <- getKey (asSiteKey s)
            jsonMgr <- mkJsonAuthMgr db
            return $! AuthManager {
                         backend               = jsonMgr
                       , session               = l
                       , activeUser            = Nothing
                       , minPasswdLen          = asMinPasswdLen s
                       , rememberCookieName    = asRememberCookieName s
                       , rememberCookieDomain  = Nothing
                       , rememberPeriod        = asRememberPeriod s
                       , siteKey               = key
                       , lockout               = asLockout s
                       , randomNumberGenerator = 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 fp = do
  db <- loadUserCache fp
  let db' = case db of
              Left e  -> error e
              Right x -> x
  cache <- newTVarIO db'

  return $! JsonFileAuthManager {
      memcache = cache
    , dbfile   = 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 {
    uidCache    :: UserIdCache          -- ^ the actual datastore
  , loginCache  :: LoginUserCache       -- ^ fast lookup for login field
  , emailCache  :: EmailUserCache       -- ^ fast lookup for email field
  , tokenCache  :: RemTokenUserCache    -- ^ fast lookup for remember tokens
  , uidCounter  :: Int                  -- ^ user id counter
}


------------------------------------------------------------------------------
defUserCache :: UserCache
defUserCache = UserCache {
    uidCache   = HM.empty
  , loginCache = HM.empty
  , emailCache = HM.empty
  , tokenCache = HM.empty
  , uidCounter = 0
}


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


------------------------------------------------------------------------------
data JsonFileAuthManager = JsonFileAuthManager {
    memcache :: TVar UserCache
  , dbfile   :: FilePath
}


------------------------------------------------------------------------------
jsonFileSave :: JsonFileAuthManager
             -> AuthUser
             -> IO (Either AuthFailure AuthUser)
jsonFileSave mgr u = do
    now        <- getCurrentTime
    oldByLogin <- lookupByLogin mgr (userLogin u)
    oldById    <- case userId u of
                    Nothing -> return Nothing
                    Just x  -> lookupByUserId mgr x

    res <- atomically $ do
      cache <- readTVar (memcache mgr)
      res   <- case userId u of
                 Nothing -> create cache now oldByLogin
                 Just _  -> update cache now oldById
      case res of
        Left e             -> return $! Left e
        Right (cache', u') -> do
          writeTVar (memcache mgr) cache'
          return $! Right $! (cache', u')

    case res of
      Left _             -> return $! Left BackendError
      Right (cache', u') -> do
        dumpToDisk cache'
        return $! Right u'

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

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

          let lc       = if oldLogin /= userLogin u
                           then HM.insert newLogin uid $
                                HM.delete oldLogin $
                                loginCache cache
                           else loginCache cache

          let ec       = if oldEmail /= newEmail
                           then (case (oldEmail, newEmail) of
                                   (Nothing, Nothing) -> id
                                   (Just e,  Nothing) -> HM.delete e
                                   (Nothing, Just e ) -> HM.insert e uid
                                   (Just e,  Just e') -> HM.insert e' uid .
                                                         HM.delete e
                                ) (emailCache cache)
                           else emailCache cache

          let tc       = if oldToken /= newToken && isJust oldToken
                           then HM.delete (fromJust oldToken) $ loginCache cache
                           else tokenCache cache

          let tc'      = case newToken of
                           Just t  -> HM.insert t uid tc
                           Nothing -> tc

          let u'       = u { userUpdatedAt = Just now }

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

          return $! Right (new, u')

    --------------------------------------------------------------------------
    -- Sync user database to disk
    -- Need to implement a mutex here; simult syncs could screw things up
    dumpToDisk c = LB.writeFile (dbfile mgr) (encode c)

    --------------------------------------------------------------------------
    -- Gets the last added user
    getLastUser cache = maybe e id $ getUser cache uid
      where
        uid = UserId . showT $ uidCounter cache
        e   = error "getLastUser failed. This should not happen."


------------------------------------------------------------------------------
instance IAuthBackend JsonFileAuthManager where
  save = jsonFileSave

  destroy = error "JsonFile: destroy is not yet implemented"

  lookupByUserId mgr uid = withCache mgr f
    where
      f cache = getUser cache uid

  lookupByLogin mgr login = withCache mgr f
    where
      f cache = getUid >>= getUser cache
        where getUid = HM.lookup login (loginCache cache)

  lookupByEmail mgr email = withCache mgr f
    where
      f cache = getEmail >>= getUser cache
        where getEmail = case HM.lookup email (emailCache cache) of
                      Just u  -> return u
                      Nothing -> (join . fmap userId .
                                  listToMaybe . HM.elems $
                                  HM.filter ((== Just email) . userEmail)
                                  (uidCache  cache))

  lookupByRememberToken mgr token = withCache mgr f
    where
      f cache = getUid >>= getUser cache
        where
          getUid = HM.lookup token (tokenCache cache)


------------------------------------------------------------------------------
withCache :: JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache mgr f = atomically $ do
  cache <- readTVar $ memcache mgr
  return $! f cache


------------------------------------------------------------------------------
getUser :: UserCache -> UserId -> Maybe AuthUser
getUser cache uid = HM.lookup uid (uidCache cache)


------------------------------------------------------------------------------
showT :: Int -> Text
showT = T.pack . show


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

------------------------------------------------------------------------------
instance ToJSON UserCache where
  toJSON uc = object
    [ "uidCache"   .= uidCache   uc
    , "loginCache" .= loginCache uc
    , "emailCache" .= emailCache uc
    , "tokenCache" .= tokenCache uc
    , "uidCounter" .= uidCounter uc
    ]


------------------------------------------------------------------------------
instance FromJSON UserCache where
  parseJSON (Object v) =
    UserCache
      <$> v .: "uidCache"
      <*> v .: "loginCache"
      <*> (v .: "emailCache" <|> pure mempty) -- Old versions of users.json do
                                              -- not carry this field
      <*> v .: "tokenCache"
      <*> v .: "uidCounter"
  parseJSON _ = error "Unexpected JSON input"