diff options
Diffstat (limited to '')
| -rw-r--r-- | package.yaml | 2 | ||||
| -rw-r--r-- | server/Handlers.hs | 33 | ||||
| -rw-r--r-- | server/HtmlOrphans.hs | 43 | ||||
| -rw-r--r-- | server/Main.hs | 15 | ||||
| -rw-r--r-- | server/Server.hs | 111 | ||||
| -rw-r--r-- | server/Worker.hs | 28 | ||||
| -rw-r--r-- | stack.yaml | 1 | ||||
| -rw-r--r-- | stack.yaml.lock | 7 | ||||
| -rw-r--r-- | walint.cabal | 2 |
9 files changed, 158 insertions, 84 deletions
diff --git a/package.yaml b/package.yaml index aa7c267..39efe0a 100644 --- a/package.yaml +++ b/package.yaml @@ -102,8 +102,10 @@ executables: - servant-server - servant-client - servant-lucid + - servant-websockets - http-types - http-client + - websockets - process - extra - microlens-platform 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 ] @@ -27,6 +27,7 @@ extra-deps: - which-0.2@sha256:db82ca7d83d64cce8ad579756f02d27c5bd289806ee02474726f7fafb87318e8,858 - cli-git-0.1.0.2@sha256:4e62e6b7357e4fe698df8b58ba53919f9d4a056e9617dbc00c869a365e316387,1122 - servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787 + - servant-websockets-2.0.0@sha256:6e9e3600bced90fd52ed3d1bf632205cb21479075b20d6637153cc4567000234,2253 # mustache is on stackage, but in a version that doesn't yet support aeson 2.0 - mustache-2.4.0@sha256:bd1cfbd027c04d8329877e95413d34dc357d4bee041dd8978cd6a23b114fbda1,3180 allow-newer: true diff --git a/stack.yaml.lock b/stack.yaml.lock index 54de1dd..43a3319 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -82,6 +82,13 @@ packages: original: hackage: servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787 - completed: + hackage: servant-websockets-2.0.0@sha256:6e9e3600bced90fd52ed3d1bf632205cb21479075b20d6637153cc4567000234,2253 + pantry-tree: + size: 523 + sha256: 085c6620bff7671bef1d969652a349271c3703fbf10dd753cb63ee1cd700bca5 + original: + hackage: servant-websockets-2.0.0@sha256:6e9e3600bced90fd52ed3d1bf632205cb21479075b20d6637153cc4567000234,2253 +- completed: hackage: mustache-2.4.0@sha256:bd1cfbd027c04d8329877e95413d34dc357d4bee041dd8978cd6a23b114fbda1,3180 pantry-tree: size: 1182 diff --git a/walint.cabal b/walint.cabal index b9c21fd..aa5f7d3 100644 --- a/walint.cabal +++ b/walint.cabal @@ -172,6 +172,7 @@ executable walint-mapserver , servant-client , servant-lucid , servant-server + , servant-websockets , stm , text , time @@ -182,4 +183,5 @@ executable walint-mapserver , wai-extra , walint , warp + , websockets default-language: Haskell2010 |