{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- | The web server.
module Imageboard.Web (runServer) where

import Data.HVect (ListContains, HVect(..), singleton)
import Heist ((##))
import Heist.Interpreted (bindSplices)
import Network.Wai.Middleware.Static
import Web.Spock

import Imageboard.Configuration
import Imageboard.Database
import Imageboard.Moderation.Users
import Imageboard.Web.Template
import Imageboard.Web.Utils
import qualified Imageboard.Web.Mod  as Mod
import qualified Imageboard.Web.User as User

-- | Run the web server with an initialised database connection pool.
runServer :: Configuration -> ConnectionPool -> IO ()
runServer config pool = do
  let spockCfg = defaultSpockCfg Nothing (PCPool pool) config
  templates <- loadAllTemplates config
  case templates of
    Right heist ->
      let heistWithConfigSplices = bindSplices (additionalSplices config) heist
      in runSpock (httpPort config) (spock spockCfg $ app heistWithConfigSplices)
    Left  errs -> do
      putStrLn "Could not load templates: "
      for_ errs $ \err -> putStrLn ("   " <> stringToText err)

-- | The website
app :: BoardHeist -> BoardApp ctx ()
app heist = do
  -- Middleware for static files
  cacheContainer <- liftIO (initCaching PublicStaticCaching)
  middleware $ staticPolicy' cacheContainer (addBase "static")

  -- Routes
  prehook (postAuth >> addSplices heist) $ do
    get root User.siteIndex

    -- Boards
    get var User.boardListingOrPage
    get (var <//> "catalogue") User.boardCatalogue
    get (var <//> "archive") (`User.boardArchive` 1)
    get (var <//> "archive" <//> var) User.boardArchive
    get (var <//> var) User.boardListing

    post var (`User.submitPost` Nothing)

    -- Threads
    get (var <//> "res" <//> var) User.threadListing

    post (var <//> "res" <//> var) (\b -> User.submitPost b . Just)
    post (var <//> "res" <//> var <//> "report") User.reportPost
    post (var <//> "res" <//> var <//> "delete") User.deletePost

    -- Attachments
    get (var <//> "thumb" <//> var) User.thumbnail
    get (var <//> "src"   <//> var) User.attachment

    -- 404
    traverse_ (\m -> hookAny m $ const User.error404) [minBound..maxBound]

    -- Mod zone:
    subcomponent "mod" . prehook requireAuth $ do
      getpost root Mod.modIndex

      -- Log out
      get "logout" Mod.logoutPage

      -- Manage boards
      getpost  "board" Mod.boards
      getpost ("board" <//> var) Mod.editBoard

      -- Edit, delete, purge, move.
      post ("thread" <//> var) Mod.editThread

      -- Edit, delete, purge, add note.
      getpost ("post" <//> var) Mod.editPost

      -- Ban/unban, delete posts by ip in board, add note.
      getpost ("ip" <//> var) Mod.editIp

      -- Manage capcodes
      getpost  "capcode" Mod.capcodes
      getpost ("capcode" <//> var) Mod.editCapcode

      -- Manage news
      getpost  "news" Mod.news
      getpost ("news" <//> var) Mod.editNews

      -- Manage users
      getpost  "users" Mod.users
      getpost ("users" <//> var) Mod.editUser

      -- Logs: see who did things, when they were done, and undo them.
      getpost "bans"    Mod.banList
      getpost "reports" Mod.reportList
      get     "log"     Mod.staffLog

-------------------------------------------------------------------------------
-- Hooks

-- | Check if the user has submitted credentials, and authenticate
-- their session if so.
postAuth :: ActionCtxT ctx BoardWebM ()
postAuth = void checkPostCredentials

-- | Add allowed (user and/or mod) splices to the context.
addSplices :: BoardHeist -> ActionCtxT ctx BoardWebM (HVect '[BoardHeist])
addSplices heist = do
  loginmay <- getSessionLogin
  case loginmay of
    Just login -> do
      configuration <- getState
      let authedHeist = bindSplices (authenticatedSplices login <> additionalModSplices configuration login) heist
      pure (singleton authedHeist)
    Nothing -> pure (singleton heist)

-- | Require the user to be authenticated to proceed, display a log-in
-- page if not.
requireAuth :: ListContains n BoardHeist xs => ActionCtxT (HVect xs) BoardWebM (HVect (LoginId ': xs))
requireAuth = do
  loginmay <- getSessionLogin
  case loginmay of
    Just login -> setCtx login
    Nothing -> either loginPage setCtx =<< checkPostCredentials

  where
    setCtx login = do
      oldCtx <- getContext
      pure (login :&: oldCtx)

-- | Check the POST parameters, create a new session if good, and
-- return an error message if incorrect or missing.
checkPostCredentials :: BoardAction ctx (Either Text LoginId)
checkPostCredentials = do
  usernamemay <- param "username"
  passwordmay <- param "password"
  case (,) <$> usernamemay <*> passwordmay of
    Just (username, password) -> do
      newsess <- runSQL (logIn username password)
      writeSession newsess
      case newsess of
        Just sessionid -> do
          loginmay <- runSQL (getUserFromSession sessionid)
          pure $ case loginmay of
            Just loginid -> Right loginid
            Nothing -> Left "An error occurred while logging in."
        Nothing -> pure (Left "Invalid username/password combination.")
    Nothing -> pure (Left "You must be logged in to proceed.")

-- | Display a log in page, with the given message.
loginPage :: ListContains m BoardHeist xs => Text -> BoardAction (HVect xs) a
loginPage msg = template "mod/login" ("message" ## msg)
