{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NoFieldSelectors      #-}

module Main where

import Control.Exception.Base (handle, SomeException (..))
import Control.Monad ((>=>), forever)
import Data.Functor (void, ($>))
import Data.Result
import Data.String (IsString (..))
import Effectful
import Effectful.Concurrent.Async (runConcurrent, async, waitAnyCancel)
import Effectful.Fail (runFailIO, runFail, Fail)
import Network.HTTP.Conduit (tlsManagerSettings, newManager)
import Network.Wai.Handler.Warp (run)
import Puppy.Config
import Puppy.Context
import Puppy.Crypto.RNG (runRNG)
import Puppy.Database (runDB)
import Puppy.Files (runFiles, Files)
import Puppy.Logging
import Puppy.Protocol.ActivityPub (runActivityPub)
import Puppy.Protocol.ActivityStreams (Id (..))
import Puppy.Protocol.HTTP (runHTTP, HTTP, runSign)
import Puppy.Protocol.HTTP.Signature (Server (..))
import Puppy.TaskQueue
import qualified Data.Text                  as T
import qualified Network.Wai                as WAI
import qualified Puppy.Database             as DB
import qualified Puppy.Protocol.ActivityPub as AP
import qualified Router
import System.Directory (createDirectoryIfMissing)

main :: IO ()
main = runEff . runRNG . runFiles ".state" "res" $ do
  -- Load the initial configuration
  config <- runFailIO $ do
    liftIO $ createDirectoryIfMissing False ".state"
    loadConfig

  -- Initialize the global HTTP manager
  manager <- liftIO (newManager tlsManagerSettings)

  -- Handle some root effects that require shared context that would
  -- be really annoying to thread down to where it needs to go.
  let handler = runConfig config
              . runServerInfo
              -- Initialize the logging root here
              . runLog (LogGeneral { scopeLabel = "main" }) config.logLevel
              -- Need concurrency past this point
              . runConcurrent
              -- Set up the task queue for delivering activities
              . runTaskQueue @DeliverTask
              -- Set up the task queue for performing activities
              . runTaskQueue @PerformTask
              -- This handler does not fail if an error is encountered, so we can safely
              -- run it here
              . runHTTP manager

  -- Actually run the application
  handler $ do

    info "Configuration loaded"
    info "Starting core tasks"

    -- Launch the tasks
    respondTask <- async respond
    performTask <- async perform
    deliverTask <- async deliver

    -- Block until any task returns (which should be never)
    void $ waitAnyCancel [
        respondTask,
        performTask,
        deliverTask
      ]

    info "Server terminated. See ya!"

  where
    -- Take tasks from the queue and handle basic failures by logging their message and then
    -- proceeding to the next task.
    -- NOTE: Does not stop RTS exceptions from taking down the loop
    -- TODO: Add some kind of retry mechanism?
    -- TODO: Add exception handling
    loop :: (TaskQueue task :> es, Log :> es) => (task -> Eff (Fail : es) ()) -> Eff es ()
    loop f = void $ forever $ logFail (dequeue >>= f)
      where
        logFail :: Log :> es => Eff (Fail : es) () -> Eff es ()
        logFail = runFail >=> \case
          Left msg -> warn ("Failed: " <> T.pack msg)
          Right _  -> debug "Finished"

    named = setContext . LogGeneral

    -- | The delivery worker task is responsible for delivering activities
    -- to remote instances.
    deliver = named "task/deliver" $ do
      info "Hello!"
      loop $ \(DeliverTask activity channel) -> do
        let handler = scope activity.id.url
                    -- Set the request signer for HTTP requests to be the channel
                    -- through which the activity is sent.
                    . runSign channel
        handler $ do
          AP.doDeliverTask activity
      info "Stopped"

    -- | The worker task responsible for executing the side effects of
    -- an activity.
    perform = named "task/perform" $ do
      info "Hello!"
      conn <- DB.connect
      loop $ \(PerformTask activity channel) -> do
        let handler = scope activity.id.url
                    . runSign channel
                    . runActivityPub
                    . runDB conn
        handler $ do
          AP.doPerformTask activity
      info "Stopped"

    -- | The server task responsible for accepting requests and responding to
    -- them, as well as delegating to the other two tasks.
    respond = named "task/respond" $ do
      info "Hello!"
      cfg <- getConfig
      conn <- DB.connect
      info (T.unwords ["Starting node", cfg.name, "on port", T.pack (show cfg.port)])
      withConcEffToIO Ephemeral Unlimited $ \unlift -> do
        run cfg.port (app unlift conn)
      info "Stopped"

app
  :: (
    Config :> es,
    Files :> es,
    HTTP :> es,
    IOE :> es,
    Log :> es,
    ServerInfo :> es,
    TaskQueue DeliverTask :> es,
    TaskQueue PerformTask :> es
  ) => (forall r. Eff es r -> IO r)
    -> DB.Connection
    -> WAI.Application
app unlift conn request respond = do
  result <- unlift $ do
    config <- getConfig
    tracer <- genTracer
    let context = LogRequest { scopeLabel = "handle", tracer }
        handler = setContext context
                -- Translates `fail` calls into `Result`s describing the error.
                . handleFail
                -- Initialize dependencies for AP ID resolution
                -- TODO: maybe use a connection pool here. can be an effect
                . runDB conn
                -- Set the key to sign requests with
                . runSign (Server config)
                . runActivityPub
    -- Doing some unlifting magic here to make the exception handling happen with the
    -- logging context that includes the tracer (as opposed to just using `unlift`,
    -- which would make it so that we lose the context of which request triggered
    -- the exception).
    handler $ withEffToIO $ \effToIO -> do
      effToIO $ handleExceptions effToIO $ do
        body <- liftIO (WAI.strictRequestBody request)
        -- TODO: verify request signature here
        Router.dispatch request body
  respond (toResponse result)
  where
    handleFail :: (Log :> es) => Eff (Fail : es) Result -> Eff es Result
    handleFail = runFail >=> \case
      Left msg
        -> warn ("Uncaught failure: " <> T.pack msg)
        $> Error 500 (fromString msg)
      Right res
        -> debug ("Finished, status: " <> status res)
        $> res

    handleExceptions :: (forall r. Eff _ r -> IO r) -> Eff _ Result -> Eff _ Result
    handleExceptions localUnlift
      = liftIO
      . handle (\ex -> localUnlift (warn ("Exception: " <> T.pack (show ex)) $> genResponse ex))
      . localUnlift

    genResponse :: SomeException -> Result
    genResponse _ = Error 500 "Internal error"

    status = T.pack . show . getStatusCode