server: add a very simple relint button

1 files changed, 15 insertions, 11 deletions

diff --git a/server/Main.hs b/server/Main.hs
index d9a8db7..7109583 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -20,7 +20,8 @@ import qualified Data.Text                            as T
 import           Fmt                                  ((+|), (|+))
 import           Handlers                             (AdminOverview (AdminOverview),
                                                        MapService (MapService),
-                                                       stateImpl, statusImpl)
+                                                       relintImpl, stateImpl,
+                                                       statusImpl)
 import           HtmlOrphans                          ()
 import           Network.HTTP.Client                  (defaultManagerSettings,
                                                        newManager)
@@ -43,13 +44,14 @@ import           Server                               (JobStatus, Org (..),
                                                        emptyState, exneuland,
                                                        interval, loadConfig,
                                                        orgs, port, token,
-                                                       unState, verbose)
+                                                       verbose)
 import           Worker                               (Job (Job), linterThread)
 
+import           Control.Monad.Logger                 (logInfoN,
+                                                       runStdoutLoggingT)
 import           Servant.API                          (Header)
 import           Servant.Client                       (ClientM, client,
                                                        mkClientEnv, runClientM)
-import Control.Monad.Logger (logInfoN, runStdoutLoggingT)
 
 type family PolyEndpoint method format payload where
   PolyEndpoint Get format payload =
@@ -64,6 +66,7 @@ type MapServiceAPI method =
 -- | abstract api
 type API format =
        "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> Get '[format] JobStatus
+  :<|> "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> "relint" :> Post '[format] Text
   :<|> "admin" :> "overview" :> Get '[format] AdminOverview
 
 -- | actual set of routes: api for json & html + static pages from disk
@@ -73,19 +76,20 @@ type Routes = "api" :> API JSON
          :<|> Raw
 
 -- | API's implementation
-jsonAPI :: forall format. MVar ServerState -> Server (API format)
-jsonAPI state = statusImpl state
+jsonAPI :: forall format. TQueue Job -> MVar ServerState -> Server (API format)
+jsonAPI queue state = statusImpl state
+           :<|> relintImpl queue state
            :<|> stateImpl @AdminOverview state
 
 -- | Complete set of routes: API + HTML sites
-server :: MVar ServerState -> Server Routes
-server state = jsonAPI @JSON state
+server :: TQueue Job -> MVar ServerState -> Server Routes
+server queue state = jsonAPI @JSON queue state
           :<|> stateImpl @MapService state
-          :<|> jsonAPI @HTML state
+          :<|> jsonAPI @HTML queue state
           :<|> serveDirectoryWebApp "./static"
 
-app :: MVar ServerState -> Application
-app = serve (Proxy @Routes) . server
+app :: TQueue Job -> MVar ServerState -> Application
+app queue = serve (Proxy @Routes) . server queue
 
 postNewMaps :: Maybe Text -> MapService -> ClientM Text
 postNewMaps = client (Proxy @(MapServiceAPI Post))
@@ -133,7 +137,7 @@ main = do
   putTextLn $ "starting server on port " <> show (view port config)
   runSettings warpsettings
     . loggerMiddleware
-    $ app state
+    $ app queue state
 
   waitEither_ linter poker
   where