{-# 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              #-}

module Server ( loadConfig
              , Config(..)
              , 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), eitherDecode,
                                       (.=))
import qualified Data.Aeson           as A
import qualified Data.ByteString.Lazy as LB
import qualified Data.Map             as M
import           Data.UUID            (UUID)
import           Lens.Micro.TH
import           LintConfig           (LintConfig')
import           Toml                 (TomlCodec)
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)

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
  , verbose    :: Bool
  -- ^ port to bind to
  , entrypoint :: FilePath
  , lintconfig :: ConfigRes loaded LintConfig'
  } deriving Generic

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

-- | 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

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 -> 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: " <> show err
        Right file -> pure file
  pure $ config { lintconfig = loaded }


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)