{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}


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

import           Universum

import           Control.Concurrent                   (threadDelay)
import           Control.Concurrent.Async             (async, link, waitEither_)
import           Control.Concurrent.STM.TQueue        (TQueue, newTQueueIO,
                                                       writeTQueue)
import qualified Data.Text                            as T
import           Fmt                                  ((+|), (|+))
import           Handlers                             (AdminOverview (AdminOverview),
                                                       MapService (MapService),
                                                       stateImpl, statusImpl)
import           HtmlOrphans                          ()
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,
                                                       EmptyAPI, Get, JSON,
                                                       PlainText, Post, Raw,
                                                       ReqBody, Server, serve,
                                                       type (:<|>) (..),
                                                       type (:>))
import           Servant.HTML.Lucid                   (HTML)
import           Servant.Server.StaticFiles           (serveDirectoryWebApp)
import           Server                               (JobStatus, Org (..),
                                                       ServerState, Sha1,
                                                       emptyState, exneuland,
                                                       interval, loadConfig,
                                                       orgs, port, token,
                                                       unState, verbose)
import           Worker                               (Job (Job), linterThread)

import           Servant.API                          (Header)
import           Servant.Client                       (BaseUrl (BaseUrl),
                                                       ClientM, Scheme (Http),
                                                       client, mkClientEnv,
                                                       runClientM)

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] JobStatus
  :<|> "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. MVar ServerState -> Server (API format)
jsonAPI state = statusImpl state
           :<|> stateImpl @AdminOverview state

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

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

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

main :: IO ()
main = do
  config <- loadConfig "./config.toml"
  state <- newMVar (emptyState config)
  queue :: TQueue Job <- newTQueueIO
  -- TODO: i really don't like all this cli logging stuff, replace it with
  -- fast-logger at some point …
  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
    readMVar state >>= \state ->
      print (length $ view unState state)
    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?
  manager' <- newManager defaultManagerSettings
  updater <- async $ forever $ do
    done <- readMVar state
    res <- runClientM
           (postNewMaps (view token config) (MapService done))
           (mkClientEnv manager' (view exneuland config))
    print res
    threadDelay (view interval config * 1000000)

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

  let warpsettings =
       setPort (view port config)
       defaultSettings

  runSettings warpsettings
    . loggerMiddleware
    $ app state

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