From 729a1983372ed23ec0ceeeb1acdadc6e6989b37a Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Mon, 7 Feb 2022 18:03:08 +0100
Subject: server: proper job handling

Note: the server will not check submissions for duplicates!
(nor does it do any kind of rate-limiting)
---
 server/Server.hs | 27 ++++++++++++++++++++++-----
 1 file changed, 22 insertions(+), 5 deletions(-)

(limited to 'server/Server.hs')

diff --git a/server/Server.hs b/server/Server.hs
index 41e5bde..93bfb30 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -3,12 +3,13 @@
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE KindSignatures      #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE TypeOperators       #-}
 
-module Server (loadConfig, Config(..), RemoteRef(..), State, JobStatus(..),
-                    setJobStatus) where
+module Server (loadConfig, Config(..), RemoteRef(..), State, registry, jobs, JobStatus(..),
+                    setJobStatus,defaultState,setRegistry) where
 
 import           CheckDir             (DirResult)
 import           Control.Concurrent   (MVar, modifyMVar_)
@@ -17,9 +18,13 @@ import qualified Data.ByteString.Lazy as LB
 import           Data.Map             (Map)
 import qualified Data.Map             as M
 import           Data.Text            (Text)
+import           Data.UUID            (UUID)
 import           GHC.Generics         (Generic)
+import           Lens.Micro           (over)
+import           Lens.Micro.TH
 import           LintConfig           (LintConfig')
 
+
 -- | a reference in a remote git repository
 data RemoteRef = RemoteRef
   { repourl :: Text
@@ -44,7 +49,15 @@ data JobStatus =
   Pending | Linted DirResult | Failed Text
   deriving (Generic, ToJSON)
 
-type State = Map RemoteRef JobStatus
+data State = State
+  { _jobs     :: Map RemoteRef JobStatus
+  , _registry :: Map UUID RemoteRef
+  }
+
+makeLenses ''State
+
+defaultState :: State
+defaultState = State mempty mempty
 
 
 loadConfig :: Config False -> IO (Config True)
@@ -57,5 +70,9 @@ loadConfig config = do
 
 
 setJobStatus :: MVar State -> RemoteRef -> JobStatus -> IO ()
-setJobStatus mvar ref status = modifyMVar_ mvar $ \state ->
-  pure $ M.insert ref status state
+setJobStatus mvar ref status = modifyMVar_ mvar
+  $ pure . over jobs (M.insert ref status)
+
+setRegistry :: MVar State -> UUID -> RemoteRef -> IO ()
+setRegistry mvar uuid ref = modifyMVar_ mvar
+  $ pure . over registry (M.insert uuid ref)
-- 
cgit v1.2.3