From e495931e6126896b09a5e95db8ba6f56fda42808 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sun, 6 Mar 2022 13:58:42 +0100
Subject: server: websocket for updates & auto-reload
todo: find a better solution than writing javascript in haskell strings. SERIOUSLY.
---
server/Handlers.hs | 33 +++++++++------
server/HtmlOrphans.hs | 43 ++++++++++++-------
server/Main.hs | 15 ++++---
server/Server.hs | 111 +++++++++++++++++++++++++++-----------------------
server/Worker.hs | 28 ++++++++++++-
5 files changed, 146 insertions(+), 84 deletions(-)
(limited to 'server')
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 ]
--
cgit v1.2.3