{-# LANGUAGE FlexibleContexts    #-}

-- | Description : The main module that starts the server.
module Guide.Main
(
  -- * Main
  main,

  -- * All supported commands
  runServer,
  dryRun,
  loadPublic,
  apiDocs,
)
where


import Imports

-- Concurrent
import Control.Concurrent.Async
-- Monads and monad transformers
import Control.Monad.Morph
-- Web
import Lucid hiding (for_)
import Network.Wai.Middleware.Static (addBase, staticPolicy)
import Web.Spock hiding (get, head, text)
import Web.Spock.Config
import Web.Spock.Lucid
-- Spock-digestive
import Web.Spock.Digestive (runForm)
-- Highlighting
import CMark.Highlight (pygments, styleToCss)
-- acid-state
import Data.Acid as Acid
import Data.SafeCopy as SafeCopy
import Data.Serialize.Get as Cereal
-- IO
import System.IO
-- Catching Ctrl-C and termination
import System.Signal

-- HVect
import Data.HVect hiding (length)

import Guide.Api (runApiServer, apiSwaggerRendered)
import Guide.App
import Guide.Cli
import Guide.Config
import Guide.Handlers
import Guide.JS (JS (..), allJSFunctions)
import Guide.Logger
import Guide.Routes (authRoute, haskellRoute)
import Guide.ServerStuff
import Guide.Session
import Guide.State
import Guide.Types
import Guide.Uid
import Guide.Views
import Guide.Views.Utils (getCSS, getCsrfHeader, getJS, protectForm)
import Guide.Database.Import (loadIntoPostgres)

import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Web.Spock as Spock


{- Note [acid-state]
~~~~~~~~~~~~~~~~~~~~

Until we are done with migrating to PostgreSQL, this app uses acid-state.
Acid-state works as follows:

  * Everything is stored as Haskell values (in particular, all data is stored
    in 'GlobalState').

  * All changes to the state (and all queries) have to be done by using
    'dbUpdate'/'dbQuery' and types (GetItem, SetItemName, etc) from the
    Types.hs module.

  * The data is kept in-memory, but all changes are logged to the disk (which
    lets us recover the state in case of a crash by reapplying the changes)
    and you can't access the state directly. When the application exits, it
    creates a snapshot of the state (called “checkpoint”) and writes it to
    the disk. Additionally, a checkpoint is created every hour (grep for
    “createCheckpoint”).

  * acid-state has a nasty feature – when the state hasn't changed,
    'createCheckpoint' appends it to the previous checkpoint. When state
    doesn't change for a long time, it means that checkpoints can grow to 100
    MB or more. So, we employ a dirty bit and use createCheckpoint' instead
    of createCheckpoint. The former only creates the checkpoint if the dirty
    bit is set, which is good.

  * When any type is changed, we have to write a migration function that
    would read the old version of the type and turn it into the new
    version. This is done by 'changelog' – you only need to provide the list
    of differences between the old type and the new type.

  * There are actually ways to access the state directly (GetGlobalState and
    SetGlobalState), but the latter should only be used when doing something
    one-off (e.g. if you need to migrate all IDs to a different ID scheme).

-}

----------------------------------------------------------------------------
-- Main
----------------------------------------------------------------------------

-- | Parse an input and run a command.
main :: IO ()
main = do
  command <- parseCommandLine
  config <- readConfig
  runCommand config command

-- | Run a specific 'Command' with the given 'Config'.
runCommand :: Config -> Command -> IO ()
runCommand config = \case
  RunServer -> runServer config
  DryRun -> dryRun config
  LoadPublic path -> loadPublic config path
  ApiDocs -> apiDocs config
  LoadIntoPostgres -> loadIntoPostgres config

----------------------------------------------------------------------------
-- Commands
----------------------------------------------------------------------------

-- | Start the server.
runServer :: Config -> IO ()
runServer config@Config{..} = withLogger config $ \logger -> do
  installTerminationCatcher =<< myThreadId
  workAsync <- async $ withDB (pure ()) $ \db -> do
    hSetBuffering stdout NoBuffering
    -- Run checkpoints creator, new and old server concurrently.
    mapConcurrently_ id
      [ checkPoint db
      , runNewApi logger config db
      , runOldServer logger config db
      ]
  -- Hold processes running and finish on exit or exception.
  forever (threadDelay (1000000 * 60))
    `finally` cancel workAsync

-- | Load database from @state/@, check that it can be loaded successfully,
-- and exit.
dryRun :: Config -> IO ()
dryRun config = withLogger config $ \logger -> do
  db :: DB <- openLocalStateFrom "state/" (error "couldn't load state")
  logDebugIO logger "loaded the database successfully"
  closeAcidState db

-- | Load 'PublicDB' from given file, create acid-state database from it,
-- and exit.
loadPublic :: Config -> FilePath -> IO ()
loadPublic config path = withLogger config $ \logger ->
  (Cereal.runGet SafeCopy.safeGet <$> BS.readFile path) >>= \case
    Left err -> error err
    Right publicDB -> do
      db <- openLocalStateFrom "state/" emptyState
      Acid.update db (ImportPublicDB publicDB)
      createCheckpointAndClose' db
      logDebugIO logger "PublicDB imported to GlobalState"

-- | Dump API docs to the output.
apiDocs :: Config -> IO ()
apiDocs config = withLogger config $ \_logger ->
  T.putStrLn apiSwaggerRendered

----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------

lucidWithConfig
  :: (MonadIO m, HasSpock (ActionCtxT cxt m),
      SpockState (ActionCtxT cxt m) ~ ServerState)
  => HtmlT (ReaderT Config IO) a -> ActionCtxT cxt m a
lucidWithConfig x = do
  cfg <- getConfig
  lucidIO (hoist (flip runReaderT cfg) x)

-- | Create a checkpoint every six hours. Note: if nothing was changed, the
-- checkpoint won't be created, which saves us some space.
checkPoint :: DB -> IO b
checkPoint db = forever $ do
  createCheckpoint' db
  threadDelay (1000000 * 3600 * 6)

-- | Run the API (new server)
runNewApi :: Logger -> Config -> AcidState GlobalState -> IO ()
runNewApi logger = runApiServer (pushLogger "api" logger)

-- | Run Spock (old server).
runOldServer :: Logger -> Config -> DB -> IO ()
runOldServer logger config@Config{..} db = do
  let serverState = ServerState {
        _config = config,
        _db     = db }
  spockConfig <- do
    cfg <- defaultSpockCfg () PCNoDatabase serverState
    store <- newAcidSessionStore db
    let sessionCfg = SessionCfg {
          sc_cookieName = "spockcookie",
          sc_sessionTTL = 3600,
          sc_sessionIdEntropy = 64,
          sc_sessionExpandTTL = True,
          sc_emptySession = emptyGuideData,
          sc_store = store,
          sc_housekeepingInterval = 60 * 10,
          sc_hooks = defaultSessionHooks
        }
    return cfg {
      spc_maxRequestSize = Just (1024*1024),
      spc_csrfProtection = True,
      spc_sessionCfg = sessionCfg }
  logDebugIO logger $ format "Spock is running on port {}" portMain
  runSpockNoBanner portMain $ spock spockConfig guideApp

-- TODO: Fix indentation after rebasing.
guideApp :: GuideApp ()
guideApp = do
    createAdminUser  -- TODO: perhaps it needs to be inside of “prehook
                     -- initHook”? (I don't actually know what “prehook
                     -- initHook” does, feel free to edit.)
    prehook initHook $ do
      middleware (staticPolicy (addBase "static"))
      -- Javascript
      Spock.get "/js.js" $ do
        setHeader "Content-Type" "application/javascript; charset=utf-8"
        (csrfTokenName, csrfTokenValue) <- getCsrfHeader
        let jqueryCsrfProtection =
              format "guidejs.csrfProtection.enable(\"{}\", \"{}\");"
                     csrfTokenName csrfTokenValue
        js <- getJS
        Spock.bytes $ toUtf8ByteString (fromJS allJSFunctions <> js <> jqueryCsrfProtection)
      -- CSS
      Spock.get "/highlight.css" $ do
        setHeader "Content-Type" "text/css; charset=utf-8"
        Spock.bytes $ toUtf8ByteString (styleToCss pygments)
      Spock.get "/css.css" $ do
        setHeader "Content-Type" "text/css; charset=utf-8"
        css <- getCSS
        Spock.bytes $ toUtf8ByteString css
      Spock.get "/admin.css" $ do
        setHeader "Content-Type" "text/css; charset=utf-8"
        css <- getCSS
        admincss <- liftIO $ T.readFile "static/admin.css"
        Spock.bytes $ toUtf8ByteString (css <> admincss)

      -- Main page
      Spock.get root $
        lucidWithConfig renderRoot

      -- Admin page
      prehook authHook $ prehook adminHook $ do
        Spock.get "admin" $ do
          s <- dbQuery GetGlobalState
          lucidIO $ renderAdmin s
        adminMethods
        Spock.get ("admin" <//> "links") $ do
          s <- dbQuery GetGlobalState
          lucidIO $ renderAdminLinks s

      -- Static pages
      Spock.get "markdown" $ lucidWithConfig $
        renderStaticMd "Markdown" "markdown.md"
      Spock.get "license" $ lucidWithConfig $
        renderStaticMd "License" "license.md"

      -- Haskell
      Spock.get (haskellRoute <//> root) $ do
        s <- dbQuery GetGlobalState
        q <- param "q"
        lucidWithConfig $ renderHaskellRoot s q
      -- Category pages
      Spock.get (haskellRoute <//> var) $ \path -> do
        -- The links look like /parsers-gao238b1 (because it's nice when
        -- you can find out where a link leads just by looking at it)
        let (_, catId) = T.breakOnEnd "-" path
        when (T.null catId)
          Spock.jumpNext
        mbCategory <- dbQuery (GetCategoryMaybe (Uid catId))
        case mbCategory of
          Nothing -> Spock.jumpNext
          Just category -> do
            -- If the slug in the url is old (i.e. if it doesn't match the
            -- one we would've generated now), let's do a redirect
            when (categorySlug category /= path) $
              -- TODO: this link shouldn't be absolute [absolute-links]
              Spock.redirect ("/haskell/" <> categorySlug category)
            lucidWithConfig $ renderCategoryPage category
      -- The add/set methods return rendered parts of the structure (added
      -- categories, changed items, etc) so that the Javascript part could
      -- take them and inject into the page. We don't want to duplicate
      -- rendering on server side and on client side.
      methods

      -- plain "/auth" logs out a logged-in user and lets a logged-out user
      -- log in (this is not the best idea, granted, and we should just
      -- show logged-in users a “logout” link and logged-out users a
      -- “login” link instead)
      Spock.get (authRoute <//> root) $ do
        user <- getLoggedInUser
        if isJust user
          then Spock.redirect "/auth/logout"
          else Spock.redirect "/auth/login"
      Spock.getpost (authRoute <//> "login") $ authRedirect "/" loginAction
      Spock.get (authRoute <//> "logout") logoutAction
      Spock.getpost (authRoute <//> "register") $ authRedirect "/" signupAction

loginAction :: GuideAction ctx ()
loginAction = do
  r <- runForm "login" loginForm
  case r of
    (v, Nothing) -> do
      formHtml <- protectForm loginFormView v
      lucidWithConfig $ renderRegister formHtml
    (v, Just Login {..}) -> do
      loginAttempt <- dbQuery $
        LoginUser loginEmail (toUtf8ByteString loginUserPassword)
      case loginAttempt of
        Right user -> do
          modifySession (sessionUserID ?~ userID user)
          Spock.redirect "/"
        -- TODO: *properly* show error message/validation of input
        Left err -> do
          formHtml <- protectForm loginFormView v
          lucidWithConfig $ renderRegister $ do
            div_ $ toHtml ("Error: " <> err)
            formHtml

logoutAction :: GuideAction ctx ()
logoutAction = do
  modifySession (sessionUserID .~ Nothing)
  Spock.redirect "/"

signupAction :: GuideAction ctx ()
signupAction = do
  r <- runForm "register" registerForm
  case r of
    (v, Nothing) -> do
      formHtml <- protectForm registerFormView v
      lucidWithConfig $ renderRegister formHtml
    (v, Just UserRegistration {..}) -> do
      user <- makeUser registerUserName registerUserEmail
                       (toUtf8ByteString registerUserPassword)
      success <- dbUpdate $ CreateUser user
      if success
        then do
          modifySession (sessionUserID ?~ userID user)
          Spock.redirect ""
        else do
          formHtml <- protectForm registerFormView v
          lucidWithConfig $ renderRegister formHtml

initHook :: GuideAction () (HVect '[])
initHook = return HNil

authHook :: GuideAction (HVect xs) (HVect (User ': xs))
authHook = do
  oldCtx <- getContext
  maybeUser <- getLoggedInUser
  case maybeUser of
    Nothing   -> Spock.text "Not logged in."
    Just user -> return (user :&: oldCtx)

adminHook :: ListContains n User xs => GuideAction (HVect xs) (HVect (IsAdmin ': xs))
adminHook = do
  oldCtx <- getContext
  let user = findFirst oldCtx
  if userIsAdmin user
    then return (IsAdmin :&: oldCtx)
    else Spock.text "Not authorized."

-- | Redirect the user to a given path if they are logged in.
authRedirect :: Text -> GuideAction ctx a -> GuideAction ctx a
authRedirect path action = do
  user <- getLoggedInUser
  case user of
    Just _ ->
      Spock.redirect path
    Nothing -> action

-- TODO: a function to find all links to Hackage that have version in them

data Quit = CtrlC | ServiceStop
  deriving (Eq, Ord, Show)

instance Exception Quit

-- | Set up a handler that would catch SIGINT (i.e. Ctrl-C) and SIGTERM
-- (i.e. service stop) and throw an exception instead of the signal. This
-- lets us create a checkpoint and close connections on exit.
installTerminationCatcher
  :: ThreadId  -- ^ Thread to kill when the signal comes
  -> IO ()
installTerminationCatcher thread = void $ do
  installHandler sigINT  (\_ -> throwTo thread CtrlC)
  installHandler sigTERM (\_ -> throwTo thread ServiceStop)

-- | Create an admin user (with login “admin”, email “admin@guide.aelve.com”
-- and password specified in the config).
--
-- The user won't be added if it exists already.
createAdminUser :: GuideApp ()
createAdminUser = do
  dbUpdate DeleteAllUsers
  pass <- toUtf8ByteString . adminPassword <$> getConfig
  user <- makeUser "admin" "admin@guide.aelve.com" pass
  void $ dbUpdate $ CreateUser (user & _userIsAdmin .~ True)
