server: websocket for updates & auto-reload

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

5 files changed, 146 insertions, 84 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!"
diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs
index 9475045..b90ea6d 100644
--- a/server/HtmlOrphans.hs
+++ b/server/HtmlOrphans.hs
@@ -20,11 +20,12 @@ import           CheckMap        (MapResult (..))
 import           Data.List.Extra (escapeJSON)
 import qualified Data.Map        as M
 import           Handlers        (AdminOverview (..))
-import           Lucid           (HtmlT, ToHtml, button_, onclick_)
+import           Lucid           (HtmlT, ToHtml)
 import           Lucid.Base      (ToHtml (toHtml))
-import           Lucid.Html5     (a_, body_, class_, code_, div_, em_, h1_, h2_,
-                                  h3_, h4_, h5_, head_, href_, html_, id_, li_,
-                                  link_, main_, p_, rel_, script_, span_, src_,
+import           Lucid.Html5     (a_, body_, button_, class_, code_, disabled_,
+                                  div_, em_, h1_, h2_, h3_, h4_, h5_, head_,
+                                  href_, html_, id_, li_, link_, main_,
+                                  onclick_, p_, rel_, script_, span_, src_,
                                   title_, type_, ul_)
 import           Server          (JobStatus (..), Org (orgSlug),
                                   RemoteRef (reporef, repourl), prettySha,
@@ -48,12 +49,15 @@ htmldoc inner = html_ $ do
 
 instance ToHtml JobStatus where
   toHtml status = htmldoc $ case status of
-      Pending -> do
+      Pending _ -> do
         h1_ "Pending …"
         p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)"
-      Linted res _rev -> do
+        autoReloadScript
+      Linted res _rev (pending, _) -> do
         h1_ "Linter Result"
-        button_ [onclick_ "relint()", class_ "btn btn-primary", id_ "relint_button"] "relint"
+        if pending
+          then button_ [class_ "btn btn-primary btn-disabled", disabled_ "true"] "pending …"
+          else button_ [onclick_ "relint()", class_ "btn btn-primary", id_ "relint_button"] "relint"
         toHtml res
         script_
           "function relint() {\n\
@@ -61,17 +65,28 @@ instance ToHtml JobStatus where
           \  xhr.open('POST', 'relint', true);\n\
           \  xhr.onreadystatechange = (e) => {if (xhr.status == 200) {\n\
           \    console.log(e);\n\
-          \    let btn = document.getElementById('relint_button');\n\
-          \    btn.innerText = 'pending … (please reload)';\n\
-          \    btn.disabled = true;\n\
-          \    btn.class = 'btn btn-disabled';\n\
           \  }}\n\
           \  xhr.send(null);\n\
           \}"
+        autoReloadScript
       Failed err -> do
         h1_ "System Error"
         p_ $ "error: " <> toHtml err
         p_ "you should probably ping an admin about this or sth"
+      where
+        autoReloadScript = script_
+          "let ws = new WebSocket('ws://localhost:8080' + window.location.pathname + 'realtime');\n\
+          \ws.onmessage = (event) => {\n\
+          \  let resp = JSON.parse(event.data);\n\
+          \  if (resp == 'RelintPending') {\n\
+          \    let btn = document.getElementById('relint_button');\n\
+          \    btn.innerText = 'pending …';\n\
+          \    btn.disabled = true;\n\
+          \    btn.class = 'btn btn-disabled';\n\
+          \  } else if (resp == 'Reload') {\n\
+          \    location.reload();\n\
+          \  }\n\
+          \}"
 
 instance ToHtml AdminOverview where
   toHtml (AdminOverview state) = htmldoc $ do
@@ -81,9 +96,9 @@ instance ToHtml AdminOverview where
       if null jobs then em_ "(nothing yet)"
       else flip M.foldMapWithKey jobs $ \sha1 (ref, status) -> li_ $ do
         case status of
-          Pending          -> badge Info "pending"
-          (Linted res rev) -> toHtml $ maximumLintLevel res
-          (Failed _)       -> badge Error "system error"
+          Pending _          -> badge Info "pending"
+          (Linted res rev _) -> toHtml $ maximumLintLevel res
+          (Failed _)         -> badge Error "system error"
         " "; a_ [href_ ("/status/"+|orgSlug org|+"/"+|prettySha sha1|+"/")] $ do
           mono $ toHtml $ reporef ref; " on "; mono $ toHtml $ repourl ref
 
diff --git a/server/Main.hs b/server/Main.hs
index 7109583..60098b6 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -20,8 +20,8 @@ import qualified Data.Text                            as T
 import           Fmt                                  ((+|), (|+))
 import           Handlers                             (AdminOverview (AdminOverview),
                                                        MapService (MapService),
-                                                       relintImpl, stateImpl,
-                                                       statusImpl)
+                                                       realtimeImpl, relintImpl,
+                                                       stateImpl, statusImpl)
 import           HtmlOrphans                          ()
 import           Network.HTTP.Client                  (defaultManagerSettings,
                                                        newManager)
@@ -50,6 +50,7 @@ import           Worker                               (Job (Job), linterThread)
 import           Control.Monad.Logger                 (logInfoN,
                                                        runStdoutLoggingT)
 import           Servant.API                          (Header)
+import           Servant.API.WebSocket                (WebSocketPending)
 import           Servant.Client                       (ClientM, client,
                                                        mkClientEnv, runClientM)
 
@@ -67,11 +68,12 @@ type MapServiceAPI method =
 type API format =
        "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> Get '[format] JobStatus
   :<|> "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> "relint" :> Post '[format] Text
+  :<|> "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> "realtime" :> WebSocketPending
   :<|> "admin" :> "overview" :> Get '[format] AdminOverview
 
 -- | actual set of routes: api for json & html + static pages from disk
-type Routes = "api" :> API JSON
-         :<|> MapServiceAPI Get
+type Routes = -- "api" :> API JSON
+         MapServiceAPI Get
          :<|> API HTML -- websites mirror the API exactly
          :<|> Raw
 
@@ -79,12 +81,13 @@ type Routes = "api" :> API JSON
 jsonAPI :: forall format. TQueue Job -> MVar ServerState -> Server (API format)
 jsonAPI queue state = statusImpl state
            :<|> relintImpl queue state
+           :<|> realtimeImpl state
            :<|> stateImpl @AdminOverview state
 
 -- | Complete set of routes: API + HTML sites
 server :: TQueue Job -> MVar ServerState -> Server Routes
-server queue state = jsonAPI @JSON queue state
-          :<|> stateImpl @MapService state
+server queue state = -- jsonAPI @JSON queue state
+           stateImpl @MapService state
           :<|> jsonAPI @HTML queue state
           :<|> serveDirectoryWebApp "./static"
 
diff --git a/server/Server.hs b/server/Server.hs
index 97f87ee..779509d 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -22,39 +22,40 @@
 
 module Server ( loadConfig
               , Org(..)
-              , Sha1
+              , Sha1, toSha
               , Config, tmpdir, port, verbose, orgs, interval, exneuland, token
               , RemoteRef(..)
               , ServerState, emptyState, unState
               , JobStatus(..)
               , setJobStatus
-              , prettySha,getJobStatus,adjustedPath) where
+              , prettySha,getJobStatus,adjustedPath,RealtimeMsg(..),newRealtimeChannel) where
 
 import           Universum
 
-import           CheckDir                   (DirResult)
-import           CheckMap                   (ResultKind (Shrunk))
-import           Control.Arrow              ((>>>))
-import           Control.Concurrent         (modifyMVar_, withMVar)
-import           Crypto.Hash.SHA1           (hash)
-import           Data.Aeson                 (FromJSON, ToJSON, ToJSONKey (..),
-                                             eitherDecodeFileStrict')
-import qualified Data.Aeson                 as A
-import qualified Data.ByteString.Base64.URL as Base64
-import           Data.Coerce                (coerce)
-import           Data.Either.Extra          (mapLeft)
-import           Data.Functor.Contravariant (contramap)
-import qualified Data.Map.Strict            as M
-import           Lens.Micro.Platform        (at, ix, makeLenses, traverseOf)
-import           LintConfig                 (LintConfig')
-import           Servant                    (FromHttpApiData)
-import           Servant.Client             (BaseUrl, parseBaseUrl)
-import qualified Text.Show                  as TS
-import           Toml                       (BiMap (BiMap), TomlBiMap,
-                                             TomlBiMapError (ArbitraryError),
-                                             TomlCodec, prettyTomlDecodeErrors,
-                                             (.=))
-import qualified Toml                       as T
+import           CheckDir                     (DirResult)
+import           CheckMap                     (ResultKind (Shrunk))
+import           Control.Arrow                ((>>>))
+import           Control.Concurrent           (modifyMVar_, withMVar)
+import           Control.Concurrent.STM.TChan (TChan, newBroadcastTChan)
+import           Crypto.Hash.SHA1             (hash)
+import           Data.Aeson                   (FromJSON, ToJSON, ToJSONKey (..),
+                                               eitherDecodeFileStrict')
+import qualified Data.Aeson                   as A
+import qualified Data.ByteString.Base64.URL   as Base64
+import           Data.Coerce                  (coerce)
+import           Data.Either.Extra            (mapLeft)
+import           Data.Functor.Contravariant   (contramap)
+import qualified Data.Map.Strict              as M
+import           Lens.Micro.Platform          (at, ix, makeLenses, traverseOf)
+import           LintConfig                   (LintConfig')
+import           Servant                      (FromHttpApiData)
+import           Servant.Client               (BaseUrl, parseBaseUrl)
+import qualified Text.Show                    as TS
+import           Toml                         (BiMap (BiMap), TomlBiMap,
+                                               TomlBiMapError (ArbitraryError),
+                                               TomlCodec,
+                                               prettyTomlDecodeErrors, (.=))
+import qualified Toml                         as T
 
 -- | a reference in a remote git repository
 data RemoteRef = RemoteRef
@@ -165,16 +166,39 @@ configCodec = Config
     <*> coerce (T.first T.text "token") .= _token
     <*> T.list orgCodec "org" .= _orgs
 
+-- | loads a config, along with all things linked in it
+-- (e.g. linterconfigs for each org)
+loadConfig :: FilePath -> IO (Config True)
+loadConfig path = do
+  res <- T.decodeFileEither configCodec path
+  case res of
+    Right config -> traverseOf orgs (mapM loadOrg) config
+    Left err     -> error $ prettyTomlDecodeErrors err
+    where
+      loadOrg :: Org False -> IO (Org True)
+      loadOrg org = do
+        lintconfig <- eitherDecodeFileStrict' (orgLintconfig org) >>= \case
+          Right c  -> pure c
+          Left err -> error $ show err
+        pure $ org { orgLintconfig = lintconfig }
+
+data RealtimeMsg = RelintPending | Reload
+  deriving (Generic, ToJSON)
+
+type RealtimeChannel = TChan RealtimeMsg
+
 -- | a job status (of a specific uuid)
-data JobStatus =
-  Pending | Linted !(DirResult Shrunk) Text | Failed Text
-  deriving (Generic, ToJSON, NFData)
+data JobStatus
+  = Pending RealtimeChannel
+  | Linted !(DirResult Shrunk) Text (Bool, RealtimeChannel)
+  | Failed Text
+  -- deriving (Generic, ToJSON, NFData)
 
 instance TS.Show JobStatus where
   show = \case
-    Pending        -> "Pending"
-    Linted res rev -> "Linted result"
-    Failed err     -> "Failed with: " <> show err
+    Pending _        -> "Pending"
+    Linted res rev _ -> "Linted result"
+    Failed err       -> "Failed with: " <> show err
 
 -- | the server's global state; might eventually end up with more
 -- stuff in here, hence the newtype
@@ -182,7 +206,7 @@ newtype ServerState = ServerState
   { _unState :: Map Text (Org True, Map Sha1 (RemoteRef, JobStatus)) }
   deriving Generic
 
-instance NFData LintConfig' => NFData ServerState
+-- instance NFData LintConfig' => NFData ServerState
 
 makeLenses ''ServerState
 
@@ -192,23 +216,6 @@ emptyState :: Config True -> ServerState
 emptyState config = ServerState
   $ M.fromList $ map (\org -> (orgSlug org, (org, mempty))) (view orgs config)
 
--- | loads a config, along with all things linked in it
--- (e.g. linterconfigs for each org)
-loadConfig :: FilePath -> IO (Config True)
-loadConfig path = do
-  res <- T.decodeFileEither configCodec path
-  case res of
-    Right config -> traverseOf orgs (mapM loadOrg) config
-    Left err     -> error $ prettyTomlDecodeErrors err
-    where
-      loadOrg :: Org False -> IO (Org True)
-      loadOrg org = do
-        lintconfig <- eitherDecodeFileStrict' (orgLintconfig org) >>= \case
-          Right c  -> pure c
-          Left err -> error $ show err
-        pure $ org { orgLintconfig = lintconfig }
-
-
 -- | NOTE: this does not create the org if it does not yet exist!
 setJobStatus :: MVar ServerState -> Org True -> RemoteRef -> JobStatus -> IO ()
 setJobStatus mvar !org !ref !status = do
@@ -216,7 +223,7 @@ setJobStatus mvar !org !ref !status = do
     -- will otherwise cause a thunk leak, since Data.Map is annoyingly un-strict
     -- even in its strict variety. for some reason it also doesn't work when
     -- moved inside the `over` though …
-    _ <- evaluateNF (view (unState . ix (orgSlug org) . _2) state)
+    _ <- evaluateWHNF (view (unState . ix (orgSlug org) . _2) state)
     pure $ over (unState . ix (orgSlug org) . _2 .  at (toSha ref))
                 (const $ Just (ref, status)) state
 
@@ -234,3 +241,7 @@ getJobStatus mvar orgslug sha = withMVar mvar $ \state -> pure $ do
 adjustedPath :: Text -> Org True -> Text -- TODO: filepath library using Text?
 adjustedPath rev Org {..} =
   orgWebdir <> "/" <> (rev <> show orgGeneration)
+
+
+newRealtimeChannel :: IO RealtimeChannel
+newRealtimeChannel = atomically newBroadcastTChan
diff --git a/server/Worker.hs b/server/Worker.hs
index 6092c78..8b3903c 100644
--- a/server/Worker.hs
+++ b/server/Worker.hs
@@ -13,6 +13,7 @@ import           Universum
 import           CheckDir                      (recursiveCheckDir,
                                                 shrinkDirResult)
 import           Control.Concurrent.Async      (async, link)
+import           Control.Concurrent.STM        (writeTChan)
 import           Control.Concurrent.STM.TQueue
 import           Control.Exception             (IOException, handle)
 import           Control.Monad.Logger          (logError, logErrorN, logInfoN,
@@ -23,9 +24,12 @@ import qualified Data.UUID.V4                  as UUID
 import           Fmt                           ((+|), (|+))
 import           Server                        (Config, JobStatus (..),
                                                 Org (..),
+                                                RealtimeMsg (RelintPending, Reload),
                                                 RemoteRef (reporef, repourl),
                                                 ServerState, adjustedPath,
-                                                setJobStatus, tmpdir)
+                                                getJobStatus,
+                                                newRealtimeChannel,
+                                                setJobStatus, tmpdir, toSha)
 import           System.Directory              (doesDirectoryExist)
 import           System.Exit                   (ExitCode (ExitFailure, ExitSuccess))
 import           System.FilePath               ((</>))
@@ -60,6 +64,18 @@ runJob config Job {..} done = do
     $ finally (lint workdir) (cleanup workdir)
   where
     lint workdir = do
+      maybeRealtime <- getJobStatus done (orgSlug jobOrg) (toSha jobRef) >>= \case
+        Nothing -> pure Nothing
+        Just (org, ref, jobstatus) -> case jobstatus of
+          Linted res rev (_, realtime) -> do
+            setJobStatus done org ref (Linted res rev (True, realtime))
+            pure $ Just realtime
+          Pending realtime -> pure $ Just realtime
+          _ -> pure Nothing
+
+      whenJust maybeRealtime $ \realtime ->
+        atomically $ writeTChan realtime RelintPending
+
       ifM (doesDirectoryExist gitdir)
         -- TODO: these calls fail for dumb http, add some fallback!
         (callgit gitdir
@@ -90,8 +106,16 @@ runJob config Job {..} done = do
           -- writeAdjustedRepository does not return other codes
           $(logError) "wtf, this is impossible"
 
+      realtime <- case maybeRealtime of
+        Just realtime -> do
+          atomically $ writeTChan realtime Reload
+          pure realtime
+        Nothing ->
+          newRealtimeChannel
+
       setJobStatus done jobOrg jobRef $
-        Linted (shrinkDirResult res) rev
+        Linted (shrinkDirResult res) rev (False, realtime)
+
 
     cleanup workdir = do
       callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]