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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
{-# 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)
|
