{-# LANGUAGE OverloadedStrings #-}

-- | \"Low-level\" user administration.
module Imageboard.Moderation.Users
  ( -- * Creating users
    createAdministrator
  , createUser
  , createAdministrator'
  , createUser'

  -- * Deactivating users
  , deactivateUser
  , reactivateUser

  -- * Querying users
  , findUserById
  , findUserByName

  -- * Authentication
  , getUserFromSession
  , logIn
  , logOut

  -- * Types
  , SessionId
  , LoginId
  , Username
  , EmailAddress
  , PlainPassword
  , User(..)
  , Password(..)
  , PasswordPlain(..)

  -- ** Errors
  , CreateUserError(..)
  , UpdateUserError(..)
  ) where

import Control.Monad.Trans.Reader (ask)
import Database.Esqueleto
import Web.Users.Persistent (Persistent(..))
import Web.Users.Types ( CreateUserError(..), UpdateUserError(..), User(..)
                       , Password(..), PasswordPlain(..), SessionId)
import qualified Web.Users.Types as U

import Imageboard.Database
import Imageboard.Moderation.Capabilities

-------------------------------------------------------------------------------
-- Creating users

type Username      = Text
type EmailAddress  = Text
type PlainPassword = Text

-- | Create a new user with no capability restrictions.
createAdministrator :: Username -> EmailAddress -> PlainPassword -> SqlPersistT IO (Either CreateUserError LoginId)
createAdministrator username email password = createAdministrator'
  User { u_name     = username
       , u_email    = email
       , u_password = U.makePassword (PasswordPlain password)
       , u_active   = True
       , u_more     = ()
       }

-- | Variant of 'createAdministrator' that takes a 'User'.
createAdministrator' :: User () -> SqlPersistT IO (Either CreateUserError LoginId)
createAdministrator' user = do
  persistent <- getPersistent
  create <- lift $ U.createUser persistent user
  case create of
    Right loginid -> traverse_ (grantCapability loginid loginid) adminCapabilities
    _ -> pure ()
  pure create

-- | Create a new user with the given set of capability restrictions.
createUser :: Foldable f => LoginId -> Username -> EmailAddress -> PlainPassword -> f Cap -> SqlPersistT IO (Either CreateUserError LoginId)
createUser actor username email password = createUser' actor
  User { u_name     = username
       , u_email    = email
       , u_password = U.makePassword (PasswordPlain password)
       , u_active   = True
       , u_more     = ()
       }

-- | Variant of 'createUser' that takes a 'User'.
createUser' :: Foldable f => LoginId -> User () -> f Cap -> SqlPersistT IO (Either CreateUserError LoginId)
createUser' actor user restrictions = do
  persistent <- getPersistent
  create <- lift $ U.createUser persistent user
  case create of
    Right loginid -> traverse_ (grantCapability actor loginid) restrictions
    _ -> pure ()
  pure create

-------------------------------------------------------------------------------
-- Deactivating users

-- | Deactivate a user. Note that 'authUser' will still
-- succeed after this, all it does is mark the user inactive. Make
-- sure to use 'withAuthUser' and check the active field.
deactivateUser :: LoginId -> SqlPersistT IO (Maybe UpdateUserError)
deactivateUser loginid = do
  persistent <- getPersistent
  lift $ either Just (const Nothing) <$> U.updateUser persistent loginid (\u -> (u :: User ()) { u_active = False })

-- | Reactivate a user.
reactivateUser :: LoginId -> SqlPersistT IO (Maybe UpdateUserError)
reactivateUser loginid = do
  persistent <- getPersistent
  lift $ either Just (const Nothing) <$> U.updateUser persistent loginid (\u -> (u :: User ()) { u_active = True })

-------------------------------------------------------------------------------
-- Querying users

-- | Attempt to find a user by ID.
findUserById :: LoginId -> SqlPersistT IO (Maybe (User ()))
findUserById loginid = do
  persistent <- getPersistent
  lift $ U.getUserById persistent loginid

-- | Attempt to find a user by name.
findUserByName :: Username -> SqlPersistT IO (Maybe LoginId)
findUserByName username = do
  persistent <- getPersistent
  lift $ U.getUserIdByName persistent username

-------------------------------------------------------------------------------
-- Authentication

-- | Check that a session is valid and that the user is not
-- deactivated. If valid, this will extend the sesison timeout to 24
-- hours from now.
getUserFromSession :: SessionId -> SqlPersistT IO (Maybe LoginId)
getUserFromSession sessid = do
  persistent <- getPersistent
  lift $ do
    verify <- U.verifySession persistent sessid (24 * 60 * 60)
    case verify of
      Just loginid -> do
        user <- U.getUserById persistent loginid
        pure $ case (user :: Maybe (User ())) of
          Just user'
            | u_active user' -> Just loginid
            | otherwise      -> Nothing
          Nothing -> Nothing
      Nothing -> pure Nothing

-- | Start a new session for a user, if the credentials are
-- correct.
logIn :: Username -> PlainPassword -> SqlPersistT IO (Maybe SessionId)
logIn username password = do
  persistent <- getPersistent
  lift $ U.housekeepBackend persistent
  sessid <- lift $ U.authUser persistent username (PasswordPlain password) 60

  -- If the log in was successful, add to the staff log.
  case sessid of
    Just sessionid -> do
      now <- getCurrentTime
      user <- lift $ U.verifySession persistent sessionid 60
      case user of
        Just loginid -> void $ insert (StaffLog now loginid "logged in")
        Nothing -> pure ()
    Nothing -> pure ()

  pure sessid

-- | Terminate a session, even if it is still valid.
logOut :: SessionId -> SqlPersistT IO ()
logOut sessid = do
  persistent <- getPersistent
  lift $ U.housekeepBackend persistent
  lift $ U.destroySession persistent sessid

-------------------------------------------------------------------------------
-- Utilities

-- | Handle to the user backend.
getPersistent :: SqlPersistT IO Persistent
getPersistent = do
  conn <- ask
  pure $ Persistent (`runSqlConn` conn)
