diff options
Diffstat (limited to 'server/Handlers.hs')
| -rw-r--r-- | server/Handlers.hs | 33 |
1 files changed, 21 insertions, 12 deletions
diff --git a/server/Handlers.hs b/server/Handlers.hs index a7c8395..0e30d2f 100644 --- a/server/Handlers.hs +++ b/server/Handlers.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} @@ -11,18 +12,22 @@ module Handlers ( -- , relintImpl , stateImpl , AdminOverview(..) - , MapService(..),relintImpl) where + , MapService(..),relintImpl,realtimeImpl) where import Universum import CheckDir (DirResult (dirresultMaps)) import CheckMap (MapResult (MapResult, mapresultBadges)) -import Control.Concurrent.STM (TQueue, writeTQueue) +import Control.Concurrent.STM (TQueue, dupTChan, readTChan, + 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 Network.WebSockets (PendingConnection, acceptRequest, + rejectRequest, sendTextData, + withPingThread) import Servant (Handler, err404, throwError) import Server (JobStatus (..), Org (orgUrl), RemoteRef (RemoteRef, reponame), @@ -35,17 +40,9 @@ import Worker (Job (Job)) newtype AdminOverview = AdminOverview { unAdminOverview :: ServerState } - newtype MapService = MapService { unMapService :: ServerState } -instance ToJSON AdminOverview where - toJSON (AdminOverview state) = - 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 . map orgObject $ view unState state @@ -56,7 +53,7 @@ instance ToJSON MapService where $ M.elems statuses where worldObject (RemoteRef {..}, job) = case job of - Linted res rev -> + Linted res rev _ -> Just (A.fromText reponame .= M.mapWithKey (mapInfo rev) (dirresultMaps res)) _ -> Nothing @@ -85,7 +82,19 @@ 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" + Nothing -> pure "there isn't a job here to restart" Just (org, ref, _oldjob) -> do atomically $ writeTQueue queue (Job ref org) pure "hello" + + +realtimeImpl :: MVar ServerState -> Text -> Sha1 -> PendingConnection -> Handler () +realtimeImpl state orgslug sha1 pending = + liftIO (getJobStatus state orgslug sha1) >>= \case + Just (_org, _ref, Linted _ _ (_, realtime)) -> do + conn <- liftIO $ acceptRequest pending + incoming <- atomically $ dupTChan realtime + liftIO $ withPingThread conn 30 pass $ forever $ do + next <- atomically $ readTChan incoming + sendTextData conn (A.encode next) + _ -> liftIO $ rejectRequest pending "no!" |