content: {-# 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)
  