1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
{-# 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)
|
