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

module Server ( loadConfig
              , Org(..)
              , Config, tmpdir, port, verbose, orgs
              , RemoteRef(..)
              , ServerState, registry, jobs, defaultState
              , JobStatus(..)
              , setJobStatus
              , setRegistry
              , AdminOverview(..)
              ) where

import           Universum

import           CheckDir             (DirResult)
import           Control.Concurrent   (modifyMVar_)
import           Data.Aeson           (FromJSON, ToJSON (toJSON),
                                       (.=), eitherDecodeFileStrict')
import qualified Data.Aeson           as A
import qualified Data.Map             as M
import           Data.UUID            (UUID)
import Lens.Micro (traverseOf)
import           Lens.Micro.TH
import           LintConfig           (LintConfig')
import           Toml                 (TomlCodec, prettyTomlDecodeErrors)
import qualified Toml                 as T

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

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


data Org (loaded :: Bool) = Org
  { orgSlug :: Text
  , orgLintconfig :: ConfigRes loaded LintConfig'
  , orgEntrypoint :: FilePath
  , orgRepos :: [RemoteRef]
  }


-- | the server's configuration
data Config (loaded :: Bool) = Config
  { _tmpdir     :: FilePath
  -- ^ dir to clone git things in
  , _port       :: Int
  , _verbose    :: Bool
  -- ^ port to bind to
  , _orgs       :: [Org loaded]
  } deriving Generic

makeLenses ''Config


remoteCodec :: TomlCodec RemoteRef
remoteCodec = RemoteRef
  <$> T.text "url" T..= repourl
  <*> T.text "ref" T..= reporef

orgCodec :: TomlCodec (Org False)
orgCodec = Org
  <$> T.text "slug" T..= orgSlug
  <*> T.string "lintconfig" T..= orgLintconfig
  <*> T.string "entrypoint" T..= orgEntrypoint
  <*> T.list remoteCodec "repo" T..= orgRepos


configCodec :: TomlCodec (Config False)
configCodec = Config
    <$> T.string "tmpdir" T..= _tmpdir
    <*> T.int "port" T..= _port
    <*> T.bool "verbose" T..= _verbose
    <*> T.list orgCodec "org" T..= _orgs

-- | a job status (of a specific uuid)
data JobStatus =
  Pending | Linted DirResult | Failed Text
  deriving (Generic, ToJSON)

-- | the server's global state
data ServerState = ServerState
  { _jobs     :: Map RemoteRef JobStatus
  , _registry :: Map UUID RemoteRef
  }
makeLenses ''ServerState

defaultState :: ServerState
defaultState = ServerState mempty mempty

-- | an info type wrapped around the server state, to carry serialisation instances.
-- TODO: should probably not be defined here
newtype AdminOverview =
  AdminOverview { unAdminOverview :: ServerState }

instance ToJSON AdminOverview where
  toJSON (AdminOverview state) =
    toJSON . flip M.mapWithKey (view registry state) $ \uuid ref ->
      A.object [ "reference" .= uuid
               , "remote" .= ref
               , "status" .= M.lookup ref (view jobs state)
               ]

loadConfig :: FilePath -> IO (Config True)
loadConfig path = do
  res <- T.decodeFileEither configCodec path
  case res of
    Right config -> traverseOf orgs (mapM loadOrg) config
    Left err -> error $ prettyTomlDecodeErrors err
    where
      loadOrg :: Org False -> IO (Org True)
      loadOrg org = do
        lintconfig <- eitherDecodeFileStrict' (orgLintconfig org) >>= \case
          Right c -> pure c
          Left err -> error $ show err
        pure $ org { orgLintconfig = lintconfig }


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

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