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


-- | simple server offering linting "as a service"
module Main where

import           Universum                            hiding (view)

import           Control.Concurrent                   (threadDelay)
import           Control.Concurrent.Async             (async, link, waitEither_)
import           Control.Concurrent.STM.TQueue        (TQueue, newTQueueIO,
                                                       writeTQueue)
import           Control.Monad.Logger                 (logInfoN,
                                                       runStdoutLoggingT)
import qualified Data.Text                            as T
import           Fmt                                  ((+|), (|+))
import           Handlers                             (AdminOverview (AdminOverview),
                                                       MapService (MapService),
                                                       realtimeImpl, relintImpl,
                                                       stateImpl, statusImpl)
import           HtmlOrphans                          ()
import           Lens.Micro.Platform                  (view)
import           Network.HTTP.Client                  (defaultManagerSettings,
                                                       newManager)
import           Network.Wai.Handler.Warp             (defaultSettings,
                                                       runSettings, setPort)
import           Network.Wai.Middleware.Gzip          (def)
import           Network.Wai.Middleware.RequestLogger (OutputFormat (..),
                                                       RequestLoggerSettings (..),
                                                       mkRequestLogger)
import           Servant                              (Application, Capture,
                                                       Get, JSON, PlainText,
                                                       Post, Raw, ReqBody,
                                                       Server, serve,
                                                       type (:<|>) (..),
                                                       type (:>))
import           Servant.API                          (Header)
import           Servant.API.WebSocket                (WebSocketPending)
import           Servant.Client                       (ClientM, client,
                                                       mkClientEnv, runClientM)
import           Servant.HTML.Lucid                   (HTML)
import           Servant.Server.StaticFiles           (serveDirectoryWebApp)
import           Server                               (CliOptions (..),
                                                       JobStatus, Org (..),
                                                       RemoteRef, ServerState,
                                                       Sha1, emptyState,
                                                       exneuland, interval,
                                                       loadConfig, orgs, port,
                                                       token, verbose)
import           WithCli                              (withCli)
import           Worker                               (Job (Job), linterThread)

type family PolyEndpoint method format payload where
  PolyEndpoint Get format payload =
    Get format payload
  PolyEndpoint Post format payload =
    Header "Auth" Text :> ReqBody format payload :> Post '[PlainText] Text


type MapServiceAPI method =
  "api" :> "maps" :> "list" :> PolyEndpoint method '[JSON] MapService

-- | abstract api
type API format =
       "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> Get '[format] (Org True, RemoteRef, JobStatus, Maybe JobStatus)
  :<|> "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> "relint" :> Post '[format] Text
  :<|> "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> "realtime" :> WebSocketPending
  :<|> "admin" :> "overview" :> Get '[format] AdminOverview

-- | actual set of routes: api for json & html + static pages from disk
type Routes = -- "api" :> API JSON
         MapServiceAPI Get
         :<|> API HTML -- websites mirror the API exactly
         :<|> Raw

-- | API's implementation
jsonAPI :: forall format. TQueue Job -> MVar ServerState -> Server (API format)
jsonAPI queue state = statusImpl state
           :<|> relintImpl queue state
           :<|> realtimeImpl state
           :<|> stateImpl @AdminOverview state

-- | Complete set of routes: API + HTML sites
server :: TQueue Job -> MVar ServerState -> Server Routes
server queue state = -- jsonAPI @JSON queue state
           stateImpl @MapService state
          :<|> jsonAPI @HTML queue state
          :<|> serveDirectoryWebApp "./static"

app :: TQueue Job -> MVar ServerState -> Application
app queue = serve (Proxy @Routes) . server queue

postNewMaps :: Maybe Text -> MapService -> ClientM Text
postNewMaps = client (Proxy @(MapServiceAPI Post))



main :: IO ()
main = withCli $ \CliOptions {..} -> do
  config <- loadConfig (fromMaybe "./config.toml" config)
  state <- newMVar (emptyState config)
  queue :: TQueue Job <- newTQueueIO
  loggerMiddleware <- mkRequestLogger
    $ def { outputFormat = Detailed (view verbose config) }

  putTextLn "reading config …"
  putTextLn $ T.concat $ map showInfo (view orgs config)

  -- periodically ‘pokes’ jobs to re-lint each repo
  poker <- async $ forever $ do
    atomically $ forM_ (view orgs config) $ \org ->
      forM_ (orgRepos org) $ \repo ->
        writeTQueue queue (Job repo org)
    -- microseconds for some reason
    threadDelay (view interval config * 1000000)

  -- TODO: what about tls / https?
  unless offline $ whenJust (view exneuland config) $ \baseurl -> do
    manager' <- newManager defaultManagerSettings
    updater <- async $ runStdoutLoggingT $ forever $ do
      done <- readMVar state
      res <- liftIO $ runClientM
           (postNewMaps (view token config) (MapService done))
           (mkClientEnv manager' baseurl)
      logInfoN $ "exneuland maps POST request: " <> show res
      liftIO $ threadDelay (view interval config * 1000000)
    link updater

  -- spawns threads for each job in the queue
  linter <- async $ void $ linterThread offline config queue state
  link linter
  link poker

  let warpsettings =
       setPort (view port config)
       defaultSettings

  putTextLn $ "starting server on port " <> show (view port config)
  runSettings warpsettings
    . loggerMiddleware
    $ app queue state

  waitEither_ linter poker
  where
    showInfo org =
      "→ org "+|orgSlug org|+" ("+|length (orgRepos org)|+" repositories)\n" :: Text