summaryrefslogtreecommitdiff
path: root/server/Handlers.hs
diff options
context:
space:
mode:
authorstuebinm2022-03-06 13:58:42 +0100
committerstuebinm2022-03-06 13:58:42 +0100
commite495931e6126896b09a5e95db8ba6f56fda42808 (patch)
treebb4ce4bb076f894ebef193c143f200c396cfb3d9 /server/Handlers.hs
parentad7343815cc89d34c68f7d38239882bd3d36a577 (diff)
server: websocket for updates & auto-reload
todo: find a better solution than writing javascript in haskell strings. SERIOUSLY.
Diffstat (limited to '')
-rw-r--r--server/Handlers.hs33
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!"