diff options
Diffstat (limited to '')
| -rw-r--r-- | server/Handlers.hs | 49 | ||||
| -rw-r--r-- | server/HtmlOrphans.hs | 18 | ||||
| -rw-r--r-- | server/Main.hs | 26 | ||||
| -rw-r--r-- | server/Server.hs | 19 | ||||
| -rw-r--r-- | server/Worker.hs | 7 |
5 files changed, 79 insertions, 40 deletions
diff --git a/server/Handlers.hs b/server/Handlers.hs index 93a7ae2..a7c8395 100644 --- a/server/Handlers.hs +++ b/server/Handlers.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -10,21 +11,24 @@ module Handlers ( -- , relintImpl , stateImpl , AdminOverview(..) - , MapService(..)) where + , MapService(..),relintImpl) where import Universum -import CheckDir (DirResult (dirresultMaps)) -import CheckMap (MapResult (MapResult, mapresultBadges)) -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 Servant (Handler, err404, throwError) -import Server (JobStatus (..), Org (orgUrl), - RemoteRef (RemoteRef, reponame), ServerState, - Sha1, adjustedPath, getJobStatus, unState) +import CheckDir (DirResult (dirresultMaps)) +import CheckMap (MapResult (MapResult, mapresultBadges)) +import Control.Concurrent.STM (TQueue, 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 Servant (Handler, err404, throwError) +import Server (JobStatus (..), Org (orgUrl), + RemoteRef (RemoteRef, reponame), + ServerState, Sha1, adjustedPath, + getJobStatus, unState) +import Worker (Job (Job)) -- | an info type wrapped around the server state, to carry serialisation instances. @@ -37,16 +41,19 @@ newtype MapService = instance ToJSON AdminOverview where toJSON (AdminOverview state) = - toJSON $ view unState state <&> \org -> flip map org $ \(ref, status) -> + 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 $ M.mapWithKey orgObject (view unState state) + toJSON . map orgObject $ view unState state where - orgObject org = A.object . mapMaybe worldObject . M.elems + orgObject (org, statuses) = + A.object + . mapMaybe worldObject + $ M.elems statuses where worldObject (RemoteRef {..}, job) = case job of Linted res rev -> @@ -64,8 +71,8 @@ statusImpl :: MVar ServerState -> Text -> Sha1 -> Handler JobStatus statusImpl state orgslug sha1 = do status <- liftIO $ getJobStatus state orgslug sha1 case status of - Just res -> pure $ snd res - Nothing -> throwError err404 + Just (_,_,jobstatus) -> pure jobstatus + Nothing -> throwError err404 -- | since there are multiple apis that just get state information … stateImpl @@ -74,3 +81,11 @@ stateImpl => MVar ServerState -> Handler s 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" + Just (org, ref, _oldjob) -> do + atomically $ writeTQueue queue (Job ref org) + pure "hello" diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs index 9b09f1d..9475045 100644 --- a/server/HtmlOrphans.hs +++ b/server/HtmlOrphans.hs @@ -20,7 +20,7 @@ import CheckMap (MapResult (..)) import Data.List.Extra (escapeJSON) import qualified Data.Map as M import Handlers (AdminOverview (..)) -import Lucid (HtmlT, ToHtml) +import Lucid (HtmlT, ToHtml, button_, onclick_) import Lucid.Base (ToHtml (toHtml)) import Lucid.Html5 (a_, body_, class_, code_, div_, em_, h1_, h2_, h3_, h4_, h5_, head_, href_, html_, id_, li_, @@ -53,7 +53,21 @@ instance ToHtml JobStatus where p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)" Linted res _rev -> do h1_ "Linter Result" + button_ [onclick_ "relint()", class_ "btn btn-primary", id_ "relint_button"] "relint" toHtml res + script_ + "function relint() {\n\ + \ var xhr = new XMLHttpRequest ();\n\ + \ 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\ + \}" Failed err -> do h1_ "System Error" p_ $ "error: " <> toHtml err @@ -62,7 +76,7 @@ instance ToHtml JobStatus where instance ToHtml AdminOverview where toHtml (AdminOverview state) = htmldoc $ do h1_ "Map List" - flip M.foldMapWithKey (view unState state) $ \org jobs -> do + forM_ (view unState state) $ \(org, jobs) -> do h2_ (toHtml $ orgSlug org) if null jobs then em_ "(nothing yet)" else flip M.foldMapWithKey jobs $ \sha1 (ref, status) -> li_ $ do diff --git a/server/Main.hs b/server/Main.hs index d9a8db7..7109583 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -20,7 +20,8 @@ import qualified Data.Text as T import Fmt ((+|), (|+)) import Handlers (AdminOverview (AdminOverview), MapService (MapService), - stateImpl, statusImpl) + relintImpl, stateImpl, + statusImpl) import HtmlOrphans () import Network.HTTP.Client (defaultManagerSettings, newManager) @@ -43,13 +44,14 @@ import Server (JobStatus, Org (..), emptyState, exneuland, interval, loadConfig, orgs, port, token, - unState, verbose) + verbose) import Worker (Job (Job), linterThread) +import Control.Monad.Logger (logInfoN, + runStdoutLoggingT) import Servant.API (Header) import Servant.Client (ClientM, client, mkClientEnv, runClientM) -import Control.Monad.Logger (logInfoN, runStdoutLoggingT) type family PolyEndpoint method format payload where PolyEndpoint Get format payload = @@ -64,6 +66,7 @@ type MapServiceAPI method = -- | abstract api type API format = "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> Get '[format] JobStatus + :<|> "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> "relint" :> Post '[format] Text :<|> "admin" :> "overview" :> Get '[format] AdminOverview -- | actual set of routes: api for json & html + static pages from disk @@ -73,19 +76,20 @@ type Routes = "api" :> API JSON :<|> Raw -- | API's implementation -jsonAPI :: forall format. MVar ServerState -> Server (API format) -jsonAPI state = statusImpl state +jsonAPI :: forall format. TQueue Job -> MVar ServerState -> Server (API format) +jsonAPI queue state = statusImpl state + :<|> relintImpl queue state :<|> stateImpl @AdminOverview state -- | Complete set of routes: API + HTML sites -server :: MVar ServerState -> Server Routes -server state = jsonAPI @JSON state +server :: TQueue Job -> MVar ServerState -> Server Routes +server queue state = jsonAPI @JSON queue state :<|> stateImpl @MapService state - :<|> jsonAPI @HTML state + :<|> jsonAPI @HTML queue state :<|> serveDirectoryWebApp "./static" -app :: MVar ServerState -> Application -app = serve (Proxy @Routes) . server +app :: TQueue Job -> MVar ServerState -> Application +app queue = serve (Proxy @Routes) . server queue postNewMaps :: Maybe Text -> MapService -> ClientM Text postNewMaps = client (Proxy @(MapServiceAPI Post)) @@ -133,7 +137,7 @@ main = do putTextLn $ "starting server on port " <> show (view port config) runSettings warpsettings . loggerMiddleware - $ app state + $ app queue state waitEither_ linter poker where diff --git a/server/Server.hs b/server/Server.hs index 46a1c8c..97f87ee 100644 --- a/server/Server.hs +++ b/server/Server.hs @@ -179,7 +179,7 @@ instance TS.Show JobStatus where -- | the server's global state; might eventually end up with more -- stuff in here, hence the newtype newtype ServerState = ServerState - { _unState :: Map (Org True) (Map Sha1 (RemoteRef, JobStatus)) } + { _unState :: Map Text (Org True, Map Sha1 (RemoteRef, JobStatus)) } deriving Generic instance NFData LintConfig' => NFData ServerState @@ -190,7 +190,7 @@ makeLenses ''ServerState -- will default to a noop otherwise emptyState :: Config True -> ServerState emptyState config = ServerState - $ M.fromList $ map (, mempty) (view orgs config) + $ 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) @@ -216,13 +216,18 @@ 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 org) state) - pure $ over (unState . ix org . at (toSha ref)) + _ <- evaluateNF (view (unState . ix (orgSlug org) . _2) state) + pure $ over (unState . ix (orgSlug org) . _2 . at (toSha ref)) (const $ Just (ref, status)) state -getJobStatus :: MVar ServerState -> Text -> Sha1 -> IO (Maybe (RemoteRef, JobStatus)) -getJobStatus mvar orgslug sha = withMVar mvar $ \state -> - pure (M.lookup sha (view (unState . ix (Org { orgSlug = orgslug })) state)) +getJobStatus :: MVar ServerState -> Text -> Sha1 -> IO (Maybe (Org True, RemoteRef, JobStatus)) +getJobStatus mvar orgslug sha = withMVar mvar $ \state -> pure $ do + (org, jobs) <- view (unState . at orgslug) state + (ref, status) <- M.lookup sha jobs + Just (org, ref, status) + -- pure $ second (M.lookup sha) orgIndex + -- pure (M.lookup sha (view (unState . ix orgslug) state)) + -- | the path (relative to a baseurl / webdir) where an adjusted -- map should go diff --git a/server/Worker.hs b/server/Worker.hs index 7de9cd3..6092c78 100644 --- a/server/Worker.hs +++ b/server/Worker.hs @@ -4,7 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Worker (linterThread, Job(..)) where @@ -15,9 +15,12 @@ import CheckDir (recursiveCheckDir, import Control.Concurrent.Async (async, link) import Control.Concurrent.STM.TQueue import Control.Exception (IOException, handle) +import Control.Monad.Logger (logError, logErrorN, logInfoN, + runStdoutLoggingT) import qualified Data.Text as T import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID +import Fmt ((+|), (|+)) import Server (Config, JobStatus (..), Org (..), RemoteRef (reporef, repourl), @@ -28,8 +31,6 @@ import System.Exit (ExitCode (ExitFailure, ExitSucce import System.FilePath ((</>)) import System.Process import WriteRepo (writeAdjustedRepository) -import Control.Monad.Logger (runStdoutLoggingT, logErrorN, logInfoN, logError) -import Fmt ((+|), (|+)) data Job = Job { jobRef :: RemoteRef |