diff options
author | stuebinm | 2022-02-07 18:03:08 +0100 |
---|---|---|
committer | stuebinm | 2022-02-07 18:04:08 +0100 |
commit | 729a1983372ed23ec0ceeeb1acdadc6e6989b37a (patch) | |
tree | f76c7cb47a056649486076fac3afa25cc5e668e8 /server/Main.hs | |
parent | f429cbc0d56dc8426285bc2d5ca7301ec241da98 (diff) |
server: proper job handling
Note: the server will not check submissions for duplicates!
(nor does it do any kind of rate-limiting)
Diffstat (limited to 'server/Main.hs')
-rw-r--r-- | server/Main.hs | 42 |
1 files changed, 24 insertions, 18 deletions
diff --git a/server/Main.hs b/server/Main.hs index 33c2c5c..ecaf6b7 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | simple server offering linting "as a service" @@ -15,16 +15,20 @@ 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 Handlers (App, statusImpl, submitImpl) +import Data.UUID (UUID) +import Handlers (App, relintImpl, statusImpl, + submitImpl) import Network.Wai.Handler.Warp (run) -import Servant (Application, Get, Handler, +import Servant (Application, Capture, Get, Handler, HasServer (ServerT), JSON, - Proxy (Proxy), ReqBody, - ServerError (errBody), err500, - hoistServer, serve, throwError, - type (:<|>) (..), type (:>), Post) + NoContent, Post, Proxy (Proxy), + ReqBody, ServerError (errBody), + err500, hoistServer, serve, + throwError, type (:<|>) (..), + type (:>)) import Server (Config (..), JobStatus, - RemoteRef (..), State, loadConfig) + RemoteRef (..), State, + defaultState, loadConfig) {- Needed: @@ -40,8 +44,9 @@ Needed: -} -- | Main API type type API format = - "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] () - :<|> "status" :> ReqBody '[JSON] RemoteRef :> Get '[format] JobStatus + "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID + :<|> "status" :> Capture "jobid" UUID :> Get '[format] JobStatus + :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent -- | API's implementation @@ -49,6 +54,7 @@ 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 @@ -65,7 +71,7 @@ app config = main :: IO () main = do - state <- newMVar (mempty :: State) + state <- newMVar defaultState let config = Config "/tmp" 8080 "main.json" "./config.json" config' <- loadConfig config run (port config) (app config' state) |