{-# 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 (mkDefaultCliConfig, runCli) import Control.Concurrent (MVar, newMVar) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString.Lazy.Char8 as C8 import Data.UUID (UUID) import Handlers (App, relintImpl, statusImpl, submitImpl) import Network.Wai.Handler.Warp (run) import Servant (Application, Capture, Get, Handler, HasServer (ServerT), JSON, NoContent, Post, Proxy (Proxy), ReqBody, ServerError (errBody), err500, hoistServer, serve, throwError, type (:<|>) (..), type (:>)) import Server (Config (..), JobStatus, RemoteRef (..), State, defaultState, 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 :> Post '[format] UUID :<|> "status" :> Capture "jobid" UUID :> Get '[format] JobStatus :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent -- | API's implementation jsonAPI :: Config True -> MVar State -> ServerT (API JSON) App jsonAPI config state = submitImpl config state :<|> statusImpl state :<|> relintImpl config state -- | make an application; convert any cli errors into a 500 app :: Config True -> MVar State -> 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 config' <- loadConfig "./config.toml" state <- newMVar defaultState run (port config') (app config' state)