server: websocket for updates & auto-reload

todo: find a better solution than writing javascript in haskell strings. SERIOUSLY.

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!"