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
|
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Server ( loadConfig
, Org(..)
, Sha1
, Config, tmpdir, port, verbose, orgs, interval
, RemoteRef(..)
, ServerState, defaultState, unState
, JobStatus(..)
, setJobStatus
, prettySha) where
import Universum
import CheckDir (DirResult)
import Control.Concurrent (modifyMVar_)
import Crypto.Hash.SHA1
import Data.Aeson (FromJSON, ToJSON, ToJSONKey (..),
eitherDecodeFileStrict')
import qualified Data.ByteString.Base64.URL as Base64
import qualified Data.Map as M
import Lens.Micro (traverseOf)
import Lens.Micro.TH
import LintConfig (LintConfig')
import Servant (FromHttpApiData)
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
newtype Sha1 = Sha1 Text
deriving newtype (Eq, Show, Ord, FromHttpApiData, ToJSON)
-- | base64-encoded sha1
prettySha :: Sha1 -> Text
prettySha (Sha1 text) = text
instance ToJSONKey Sha1
toSha :: RemoteRef -> Sha1
toSha ref = Sha1 . decodeUtf8 . Base64.encode . hash . encodeUtf8 $ (show ref :: Text)
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
, _interval :: Int
-- ^ port to bind to
, _orgs :: [Org loaded]
} deriving Generic
makeLenses ''Config
remoteCodec :: TomlCodec RemoteRef
remoteCodec = RemoteRef
<$> T.text "url" .= repourl
<*> T.text "ref" .= reporef
orgCodec :: TomlCodec (Org False)
orgCodec = Org
<$> T.text "slug" .= orgSlug
<*> T.string "lintconfig" .= orgLintconfig
<*> T.string "entrypoint" .= orgEntrypoint
<*> T.list remoteCodec "repo" .= orgRepos
configCodec :: TomlCodec (Config False)
configCodec = Config
<$> T.string "tmpdir" .= _tmpdir
<*> T.int "port" .= _port
<*> T.bool "verbose" .= _verbose
<*> T.int "interval" .= _interval
<*> T.list orgCodec "org" .= _orgs
-- | a job status (of a specific uuid)
data JobStatus =
Pending | Linted DirResult | Failed Text
deriving (Generic, ToJSON)
-- | the server's global state; might eventually end up with more
-- stuff in here, hence the newtype
newtype ServerState = ServerState
{ _unState :: Map Sha1 (RemoteRef, JobStatus) }
makeLenses ''ServerState
defaultState :: ServerState
defaultState = ServerState mempty
-- | loads a config, along with all things linked in it
-- (e.g. linterconfigs for each org)
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 unState (M.insert (toSha ref) (ref, status))
|
