blob: 77c8fdee8d26879f46a3527c23848fe70e2d082e (
plain)
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
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- | simple server offering linting "as a service"
module Main where
import CheckDir (DirResult)
import Cli.Extras (mkDefaultCliConfig, runCli)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString.Lazy.Char8 as C8
import Data.Text (Text)
import Git (App, submitImpl)
import Network.Wai.Handler.Warp (run)
import Servant
import Serverconfig (Config (..), RemoteRef (..),
loadConfig)
{-
Needed:
- admin overview (perhaps on seperate port?)
- in json:
- submit a repository link & ref name, get back job id
- look up a lint status by job id
- in html
- look up a lint status, pretty-printed
- front page with overview & links
- possibly a "update & relint" button?
- links to documentation
-}
-- | Main API type
type API format =
"submit" :> ReqBody '[JSON] RemoteRef :> Get '[format] DirResult
:<|> "status" :> Capture "sha1" Text :> Get '[format] [Int]
-- | API's implementation
jsonAPI :: Config True -> ServerT (API JSON) App
jsonAPI config =
submitImpl config
:<|> (\sha -> do
liftIO $ print sha
pure [1])
-- | make an application; convert any cli errors into a 500
app :: Config True -> Application
app config =
serve api $ hoistServer api conv (jsonAPI config)
where api = Proxy @(API JSON)
conv :: App a -> Handler a
conv m = do
config <- liftIO $ mkDefaultCliConfig []
res <- runCli config m
case res of
Right a -> pure a
Left err -> throwError (err500 { errBody = C8.pack (show err) })
main :: IO ()
main = do
let config = Config "/tmp" 8080 "main.json" "./config.json"
config' <- loadConfig config
run (port config) (app config')
|
