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
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- | simple server offering linting "as a service"
module Main where
import Cli.Extras (CliConfig, Severity (..),
mkDefaultCliConfig, putLog, runCli)
import Control.Concurrent (MVar, newMVar)
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString.Lazy.Char8 as C8
import Data.List (intersperse)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.UUID (UUID)
import Handlers (App, adminOverviewImpl, relintImpl,
statusImpl, submitImpl)
import HtmlOrphans ()
import Network.HTTP.Types.Status (Status (..))
import Network.Wai (Request, pathInfo, requestMethod)
import Network.Wai.Handler.Warp (defaultSettings, runSettings,
setLogger, setPort)
import Servant (Application, Capture, Get, Handler,
HasServer (ServerT), JSON,
NoContent, Post, Proxy (Proxy),
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 (..), State,
defaultState, loadConfig)
-- | 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 State -> ServerT (API JSON) App
jsonAPI config state =
submitImpl config state
:<|> statusImpl state
:<|> relintImpl config state
:<|> adminOverviewImpl state
server :: Config True -> MVar State -> 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 State -> 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
cliconfig <- liftIO $ mkDefaultCliConfig ["-v"]
config <- loadConfig "./config.toml"
state <- newMVar defaultState
let warpsettings =
setPort (port config)
. setLogger (logRequest cliconfig)
$ defaultSettings
runSettings warpsettings (app cliconfig config state)
-- TODO: at some point i should learn how to do these things properly, but
-- for now this works well enough i guess
logRequest :: CliConfig -> Request -> Status -> Maybe Integer -> IO ()
logRequest cliconfig req status _size = void . runCli cliconfig $
putLog Notice
$ "request: "
<> decodeUtf8 (requestMethod req) <> " "
<> parts <> " "
<> T.pack (show (statusCode status)) <> " "
<> decodeUtf8 (statusMessage status)
where parts = T.concat $ intersperse "/" (pathInfo req)
|
