From 7da030ea5cedbdedea09d37f94678b0b5a6834fa Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sun, 6 Mar 2022 08:02:30 +0100
Subject: server: add a very simple relint button

---
 server/Handlers.hs | 49 ++++++++++++++++++++++++++++++++-----------------
 1 file changed, 32 insertions(+), 17 deletions(-)

(limited to 'server/Handlers.hs')

diff --git a/server/Handlers.hs b/server/Handlers.hs
index 93a7ae2..a7c8395 100644
--- a/server/Handlers.hs
+++ b/server/Handlers.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE ExplicitForAll    #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 
@@ -10,21 +11,24 @@ module Handlers (
                 -- , relintImpl
                 , stateImpl
                 , AdminOverview(..)
-                , MapService(..)) where
+                , MapService(..),relintImpl) where
 
 import           Universum
 
-import           CheckDir       (DirResult (dirresultMaps))
-import           CheckMap       (MapResult (MapResult, mapresultBadges))
-import           Data.Aeson     (ToJSON (..), (.=))
-import qualified Data.Aeson     as A
-import qualified Data.Aeson.Key as A
-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)
+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
+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)
+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,8 +71,8 @@ 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
-     Nothing  -> throwError err404
+     Just (_,_,jobstatus) -> pure jobstatus
+     Nothing              -> throwError err404
 
 -- | since there are multiple apis that just get state information …
 stateImpl
@@ -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"
-- 
cgit v1.2.3