server: add a very simple relint button

server/Handlers.hs

 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE ExplicitForAll    #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 
@@ -10,12 +11,13 @@ module Handlers (
                 -- , relintImpl
                 , stateImpl
                 , AdminOverview(..)
-                , MapService(..)) where
+                , MapService(..),relintImpl) where
 
 import           Universum
 
 import           CheckDir               (DirResult (dirresultMaps))
 import           CheckMap               (MapResult (MapResult, mapresultBadges))
+import           Control.Concurrent.STM (TQueue, writeTQueue)
 import           Data.Aeson             (ToJSON (..), (.=))
 import qualified Data.Aeson             as A
 import qualified Data.Aeson.Key         as A
@@ -23,8 +25,10 @@ import           Data.Coerce    (coerce)
 import qualified Data.Map               as M
 import           Servant                (Handler, err404, throwError)
 import           Server                 (JobStatus (..), Org (orgUrl),
-                                 RemoteRef (RemoteRef, reponame), ServerState,
-                                 Sha1, adjustedPath, getJobStatus, unState)
+                                         RemoteRef (RemoteRef, reponame),
+                                         ServerState, Sha1, adjustedPath,
+                                         getJobStatus, unState)
+import           Worker                 (Job (Job))
 
 
 -- | an info type wrapped around the server state, to carry serialisation instances.
@@ -37,16 +41,19 @@ newtype MapService =
 
 instance ToJSON AdminOverview where
   toJSON (AdminOverview state) =
-    toJSON $ view unState state <&> \org -> flip map org $ \(ref, status) ->
+    toJSON $ view unState state <&> \org -> flip map (snd org) $ \(ref, status) ->
       A.object [ "remote" .= ref
                , "status" .= status
                ]
 
 instance ToJSON MapService where
   toJSON (MapService state) =
-    toJSON $ M.mapWithKey orgObject (view unState state)
+    toJSON . map orgObject $ view unState state
      where
-      orgObject org = A.object . mapMaybe worldObject . M.elems
+      orgObject (org, statuses) =
+        A.object
+        . mapMaybe worldObject
+        $ M.elems statuses
        where
         worldObject (RemoteRef {..}, job) = case job of
           Linted res rev ->
@@ -64,7 +71,7 @@ statusImpl :: MVar ServerState -> Text -> Sha1 -> Handler JobStatus
 statusImpl state orgslug sha1 = do
    status <- liftIO $ getJobStatus state orgslug sha1
    case status of
-     Just res -> pure $ snd res
+     Just (_,_,jobstatus) -> pure jobstatus
      Nothing              -> throwError err404
 
 -- | since there are multiple apis that just get state information …
@@ -74,3 +81,11 @@ stateImpl
   => MVar ServerState
   -> Handler s
 stateImpl state = readMVar state <&> coerce
+
+relintImpl :: TQueue Job -> MVar ServerState -> Text -> Sha1 -> Handler Text
+relintImpl queue state orgslug sha1 =
+  liftIO $ getJobStatus state orgslug sha1 >>= \case
+    Nothing -> pure "something went wrong"
+    Just (org, ref, _oldjob) -> do
+      atomically $ writeTQueue queue (Job ref org)
+      pure "hello"

server/HtmlOrphans.hs

@@ -20,7 +20,7 @@ import           CheckMap        (MapResult (..))
 import           Data.List.Extra (escapeJSON)
 import qualified Data.Map        as M
 import           Handlers        (AdminOverview (..))
-import           Lucid           (HtmlT, ToHtml)
+import           Lucid           (HtmlT, ToHtml, button_, onclick_)
 import           Lucid.Base      (ToHtml (toHtml))
 import           Lucid.Html5     (a_, body_, class_, code_, div_, em_, h1_, h2_,
                                   h3_, h4_, h5_, head_, href_, html_, id_, li_,
@@ -53,7 +53,21 @@ instance ToHtml JobStatus where
         p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)"
       Linted res _rev -> do
         h1_ "Linter Result"
+        button_ [onclick_ "relint()", class_ "btn btn-primary", id_ "relint_button"] "relint"
         toHtml res
+        script_
+          "function relint() {\n\
+          \  var xhr = new XMLHttpRequest ();\n\
+          \  xhr.open('POST', 'relint', true);\n\
+          \  xhr.onreadystatechange = (e) => {if (xhr.status == 200) {\n\
+          \    console.log(e);\n\
+          \    let btn = document.getElementById('relint_button');\n\
+          \    btn.innerText = 'pending … (please reload)';\n\
+          \    btn.disabled = true;\n\
+          \    btn.class = 'btn btn-disabled';\n\
+          \  }}\n\
+          \  xhr.send(null);\n\
+          \}"
       Failed err -> do
         h1_ "System Error"
         p_ $ "error: " <> toHtml err
@@ -62,7 +76,7 @@ instance ToHtml JobStatus where
 instance ToHtml AdminOverview where
   toHtml (AdminOverview state) = htmldoc $ do
     h1_ "Map List"
-    flip M.foldMapWithKey (view unState state) $ \org jobs -> do
+    forM_ (view unState state) $ \(org, jobs) -> do
       h2_ (toHtml $ orgSlug org)
       if null jobs then em_ "(nothing yet)"
       else flip M.foldMapWithKey jobs $ \sha1 (ref, status) -> li_ $ do

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

server/Server.hs

@@ -179,7 +179,7 @@ instance TS.Show JobStatus where
 -- | the server's global state; might eventually end up with more
 -- stuff in here, hence the newtype
 newtype ServerState = ServerState
-  { _unState :: Map (Org True) (Map Sha1 (RemoteRef, JobStatus)) }
+  { _unState :: Map Text (Org True, Map Sha1 (RemoteRef, JobStatus)) }
   deriving Generic
 
 instance NFData LintConfig' => NFData ServerState
@@ -190,7 +190,7 @@ makeLenses ''ServerState
 -- will default to a noop otherwise
 emptyState :: Config True -> ServerState
 emptyState config = ServerState
-  $ M.fromList $ map (, mempty) (view orgs config)
+  $ M.fromList $ map (\org -> (orgSlug org, (org, mempty))) (view orgs config)
 
 -- | loads a config, along with all things linked in it
 -- (e.g. linterconfigs for each org)
@@ -216,13 +216,18 @@ setJobStatus mvar !org !ref !status = do
     -- will otherwise cause a thunk leak, since Data.Map is annoyingly un-strict
     -- even in its strict variety. for some reason it also doesn't work when
     -- moved inside the `over` though …
-    _ <- evaluateNF (view (unState . ix org) state)
-    pure $ over (unState . ix org . at (toSha ref))
+    _ <- evaluateNF (view (unState . ix (orgSlug org) . _2) state)
+    pure $ over (unState . ix (orgSlug org) . _2 .  at (toSha ref))
                 (const $ Just (ref, status)) state
 
-getJobStatus :: MVar ServerState -> Text -> Sha1 -> IO (Maybe (RemoteRef, JobStatus))
-getJobStatus mvar orgslug sha = withMVar mvar $ \state ->
-  pure (M.lookup sha (view (unState . ix (Org { orgSlug = orgslug })) state))
+getJobStatus :: MVar ServerState -> Text -> Sha1 -> IO (Maybe (Org True, RemoteRef, JobStatus))
+getJobStatus mvar orgslug sha = withMVar mvar $ \state -> pure $ do
+  (org, jobs) <- view (unState . at orgslug) state
+  (ref, status) <- M.lookup sha jobs
+  Just (org, ref, status)
+    -- pure $ second (M.lookup sha) orgIndex
+  -- pure (M.lookup sha (view (unState . ix orgslug) state))
+
 
 -- | the path (relative to a baseurl / webdir) where an adjusted
 -- map should go

server/Worker.hs

@@ -15,9 +15,12 @@ import           CheckDir                      (recursiveCheckDir,
 import           Control.Concurrent.Async      (async, link)
 import           Control.Concurrent.STM.TQueue
 import           Control.Exception             (IOException, handle)
+import           Control.Monad.Logger          (logError, logErrorN, logInfoN,
+                                                runStdoutLoggingT)
 import qualified Data.Text                     as T
 import qualified Data.UUID                     as UUID
 import qualified Data.UUID.V4                  as UUID
+import           Fmt                           ((+|), (|+))
 import           Server                        (Config, JobStatus (..),
                                                 Org (..),
                                                 RemoteRef (reporef, repourl),
@@ -28,8 +31,6 @@ import           System.Exit                   (ExitCode (ExitFailure, ExitSucce
 import           System.FilePath               ((</>))
 import           System.Process
 import           WriteRepo                     (writeAdjustedRepository)
-import Control.Monad.Logger (runStdoutLoggingT, logErrorN, logInfoN, logError)
-import Fmt ((+|), (|+))
 
 data Job = Job
   { jobRef :: RemoteRef