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
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- | simple server offering linting "as a service"
module Main where
import Universum
import Cli.Extras (CliConfig,
mkDefaultCliConfig,
runCli)
import qualified Data.ByteString.Lazy.Char8 as C8
import Data.UUID (UUID)
import Handlers (App, adminOverviewImpl,
statusImpl,
)
import HtmlOrphans ()
import Network.Wai.Handler.Warp (defaultSettings,
runSettings, setPort)
import Network.Wai.Middleware.Gzip (def)
import Network.Wai.Middleware.RequestLogger (OutputFormat (..),
RequestLoggerSettings (..),
mkRequestLogger)
import Servant (Application, Capture,
Get, Handler,
HasServer (ServerT),
JSON, NoContent, Post,
Raw, ReqBody,
ServerError (errBody),
err500, hoistServer,
serve, throwError,
type (:<|>) (..),
type (:>))
import Servant.HTML.Lucid (HTML)
import Servant.Server.StaticFiles (serveDirectoryWebApp)
import Server (AdminOverview,
Config (..), JobStatus,
RemoteRef (..),
ServerState,
defaultState, loadConfig, verbose, port, orgs, Org (orgEntrypoint, orgRepos))
-- | Main API type
type API format =
-- "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID
"status" :> Capture "jobid" UUID :> Get '[format] JobStatus
-- :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent
:<|> "admin" :> "overview" :> Get '[format] AdminOverview
type Routes =
"api" :> API JSON
:<|> "status" :> Capture "jobid" UUID :> Get '[HTML] JobStatus
:<|> "admin" :> "overview" :> Get '[HTML] AdminOverview
:<|> Raw
-- | API's implementation
jsonAPI :: Config True -> MVar ServerState -> ServerT (API JSON) App
jsonAPI config state =
-- submitImpl config state
statusImpl state
-- :<|> relintImpl config state
:<|> adminOverviewImpl state
server :: Config True -> MVar ServerState -> ServerT Routes App
server config state =
jsonAPI config state
:<|> statusImpl state
:<|> adminOverviewImpl state
:<|> serveDirectoryWebApp "./static"
-- | make an application; convert any cli errors into a 500
app :: CliConfig -> Config True -> MVar ServerState -> Application
app cliconfig config =
serve api . hoistServer api conv . server config
where api = Proxy @Routes
conv :: App a -> Handler a
conv m = do
res <- runCli cliconfig m
case res of
Right a -> pure a
Left err -> throwError (err500 { errBody = C8.pack (show err) })
main :: IO ()
main = do
config <- loadConfig "./config.toml"
state <- newMVar defaultState
-- TODO: i really don't like all this cli logging stuff, replace it with
-- fast-logger at some point …
cliconfig <- liftIO $ mkDefaultCliConfig ["-v" | view verbose config]
loggerMiddleware <- mkRequestLogger
$ def { outputFormat = Detailed (view verbose config) }
-- print (keys $ view orgs config)
print (map orgEntrypoint $ view orgs config)
print (map orgRepos $ view orgs config)
let warpsettings =
setPort (view port config)
defaultSettings
runSettings warpsettings
. loggerMiddleware
$ app cliconfig config state
|
