{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}

module Server (loadConfig, Config(..), RemoteRef(..), State, registry, jobs, JobStatus(..),
                    setJobStatus,defaultState,setRegistry) where

import           CheckDir             (DirResult)
import           Control.Concurrent   (MVar, modifyMVar_)
import           Data.Aeson           (FromJSON, ToJSON, eitherDecode)
import qualified Data.ByteString.Lazy as LB
import           Data.Map             (Map)
import qualified Data.Map             as M
import           Data.Text            (Text)
import           Data.UUID            (UUID)
import           GHC.Generics         (Generic)
import           Lens.Micro           (over)
import           Lens.Micro.TH
import           LintConfig           (LintConfig')
import           Lucid                (ToHtml (..))
import           Lucid.Html5
import           Orphans              ()
import           System.Exit.Compat   (exitFailure)
import           Toml                 (TomlCodec)
import qualified Toml
import           Toml.Codec           ((.=))

-- | a reference in a remote git repository
data RemoteRef = RemoteRef
  { repourl :: Text
  , reporef :: Text
  } deriving (Generic, FromJSON, Eq, Ord)

type family ConfigRes (b :: Bool) a where
  ConfigRes True a = a
  ConfigRes False a = FilePath

-- | the server's configuration
data Config (loaded :: Bool) = Config
  { tmpdir     :: FilePath
  -- ^ dir to clone git things in
  , port       :: Int
  -- ^ port to bind to
  , entrypoint :: FilePath
  , lintconfig :: ConfigRes loaded LintConfig'
  } deriving Generic

configCodec :: TomlCodec (Config False)
configCodec = Config
    <$> Toml.string "tmpdir" .= tmpdir
    <*> Toml.int "port" .= port
    <*> Toml.string "entrypoint" .= entrypoint
    <*> Toml.string "lintconfig" .= lintconfig

data JobStatus =
  Pending | Linted DirResult | Failed Text
  deriving (Generic, ToJSON)

data State = State
  { _jobs     :: Map RemoteRef JobStatus
  , _registry :: Map UUID RemoteRef
  }

instance ToHtml JobStatus where
  toHtml status = html_ $ do
    head_ $ do
      title_ "Job Status"
      link_ [rel_ "stylesheet", type_ "text/css", href_ "/bootstrap.min.css" ]
      link_ [rel_ "stylesheet", type_ "text/css", href_ "/style.css" ]
    body_ $ main_ [class_ "main-content"] $ case status of
      Pending -> do
        h1_ "Pending …"
        p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)"
      Linted res -> do
        h1_ "Linter Result"
        toHtml res
      Failed err -> do
        h1_ "System Error"
        p_ $ "error: " <> toHtml err
        p_ "you should probably ping an admin about this or sth"

makeLenses ''State

defaultState :: State
defaultState = State mempty mempty

loadConfig :: FilePath -> IO (Config True)
loadConfig path = do
  res <- Toml.decodeFileEither configCodec path
  case res of
    Right config -> loadConfig' config
    Left err -> do
      print err
      exitFailure

loadConfig' :: Config False -> IO (Config True)
loadConfig' config = do
  loaded <- LB.readFile (lintconfig config) >>= \res ->
      case eitherDecode res :: Either String LintConfig' of
        Left err   -> error $ "config file invalid: " <> err
        Right file -> pure file
  pure $ config { lintconfig = loaded }


setJobStatus :: MVar State -> RemoteRef -> JobStatus -> IO ()
setJobStatus mvar ref status = modifyMVar_ mvar
  $ pure . over jobs (M.insert ref status)

setRegistry :: MVar State -> UUID -> RemoteRef -> IO ()
setRegistry mvar uuid ref = modifyMVar_ mvar
  $ pure . over registry (M.insert uuid ref)