Server.hs

{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE KindSignatures      #-}
{-# 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')


-- | 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 l = Config
  { tmpdir     :: FilePath
  -- ^ dir to clone git things in
  , port       :: Int
  -- ^ port to bind to
  , entrypoint :: FilePath
  , lintconfig :: ConfigRes l LintConfig'
  }

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

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

makeLenses ''State

defaultState :: State
defaultState = State mempty mempty


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)