From b7c0cd8fbef6147bf1ff2e30abfcf5c4c025862b Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Fri, 25 Feb 2022 16:30:45 +0100
Subject: [PATCH] server: write out adjusted maps
---
config.toml | 19 ++++++++++++++++---
lib/WriteRepo.hs | 2 +-
server/Handlers.hs | 8 +++++---
server/Main.hs | 25 ++++++++++++++-----------
server/Server.hs | 16 ++++++++++++----
server/Worker.hs | 26 +++++++++++++++++++++-----
6 files changed, 69 insertions(+), 27 deletions(-)
diff --git a/config.toml b/config.toml
index a259c20..2e60b4b 100644
--- a/config.toml
+++ b/config.toml
@@ -6,15 +6,28 @@ verbose = true
tmpdir = "/tmp"
# linting interval in seconds
-interval = 10000
-exneuland = "http://localhost:4000"
+interval = 10
+
+# where to post map updates to
+# exneuland = "http://localhost:4000"
+# auth token for map updates
token = "hello, world!"
[[org]]
slug = "divoc"
+
+# baseurl of maps as seen by the frontend
url = "https://world.di.c3voc.de/maps/"
-webdir = "/var/www/divoc"
+# webdir into which maps should be written
+webdir = "/tmp/var/www/divoc"
+
+# increment this if you change the server / linter config
+# (part of urls for linted maps; allows indefinite browser caching)
+generation = 1
+
+# linter's config for this org
lintconfig = "./config.json"
+# map's entrypoint (only maps reachable from here are included)
entrypoint = "main.json"
[[org.repo]] # I hate TOML
diff --git a/lib/WriteRepo.hs b/lib/WriteRepo.hs
index e4815fe..2a62591 100644
--- a/lib/WriteRepo.hs
+++ b/lib/WriteRepo.hs
@@ -24,7 +24,7 @@ import System.FilePath.Posix ((</>))
import Types (Dep (Local))
-
+-- TODO: make this return a custom error type, not an exitcode
writeAdjustedRepository :: LintConfig' -> FilePath -> FilePath -> DirResult Full -> IO ExitCode
writeAdjustedRepository config inPath outPath result
| resultIsFatal config result =
diff --git a/server/Handlers.hs b/server/Handlers.hs
index 719b475..93a7ae2 100644
--- a/server/Handlers.hs
+++ b/server/Handlers.hs
@@ -10,7 +10,7 @@ module Handlers (
-- , relintImpl
, stateImpl
, AdminOverview(..)
- ,MapService(..)) where
+ , MapService(..)) where
import Universum
@@ -24,7 +24,8 @@ import qualified Data.Map as M
import Servant (Handler, err404, throwError)
import Server (JobStatus (..), Org (orgUrl),
RemoteRef (RemoteRef, reponame), ServerState,
- Sha1, getJobStatus, unState)
+ Sha1, adjustedPath, getJobStatus, unState)
+
-- | an info type wrapped around the server state, to carry serialisation instances.
newtype AdminOverview =
@@ -54,7 +55,8 @@ instance ToJSON MapService where
_ -> Nothing
mapInfo rev mappath MapResult { .. } = A.object
[ "badges" .= mapresultBadges
- , "url" .= (orgUrl org <> rev <> "/" <> toText mappath) ]
+ -- TODO: type-safe url library for adding the slash?
+ , "url" .= (orgUrl org <> adjustedPath rev org <> "/" <> toText mappath) ]
diff --git a/server/Main.hs b/server/Main.hs
index d9c548b..cb1a65b 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -51,8 +51,10 @@ import Servant.Client (ClientM, client,
mkClientEnv, runClientM)
type family PolyEndpoint method format payload where
- PolyEndpoint Get format payload = Get format payload
- PolyEndpoint Post format payload = Header "Auth" Text :> ReqBody format payload :> Post '[PlainText] Text
+ PolyEndpoint Get format payload =
+ Get format payload
+ PolyEndpoint Post format payload =
+ Header "Auth" Text :> ReqBody format payload :> Post '[PlainText] Text
type MapServiceAPI method =
@@ -111,20 +113,21 @@ main = do
threadDelay (view interval config * 1000000)
-- TODO: what about tls / https?
- manager' <- newManager defaultManagerSettings
- -- updater <- async $ forever $ do
- -- done <- readMVar state
- -- res <- runClientM
- -- (postNewMaps (view token config) (MapService done))
- -- (mkClientEnv manager' (view exneuland config))
- -- print res
- -- threadDelay (view interval config * 1000000)
+ whenJust (view exneuland config) $ \baseurl -> do
+ manager' <- newManager defaultManagerSettings
+ updater <- async $ forever $ do
+ done <- readMVar state
+ res <- runClientM
+ (postNewMaps (view token config) (MapService done))
+ (mkClientEnv manager' baseurl)
+ print res
+ threadDelay (view interval config * 1000000)
+ link updater
-- spawns threads for each job in the queue
linter <- async $ void $ linterThread config queue state
link linter
link poker
- -- link updater
let warpsettings =
setPort (view port config)
diff --git a/server/Server.hs b/server/Server.hs
index 711da88..46a1c8c 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -28,12 +28,12 @@ module Server ( loadConfig
, ServerState, emptyState, unState
, JobStatus(..)
, setJobStatus
- , prettySha,getJobStatus) where
+ , prettySha,getJobStatus,adjustedPath) where
import Universum
import CheckDir (DirResult)
-import CheckMap (ResultKind (Full, Shrunk))
+import CheckMap (ResultKind (Shrunk))
import Control.Arrow ((>>>))
import Control.Concurrent (modifyMVar_, withMVar)
import Crypto.Hash.SHA1 (hash)
@@ -90,6 +90,7 @@ data Org (loaded :: Bool) = Org
{ orgSlug :: Text
, orgLintconfig :: ConfigRes loaded LintConfig'
, orgEntrypoint :: FilePath
+ , orgGeneration :: Int
, orgRepos :: [RemoteRef]
, orgUrl :: Text
, orgWebdir :: Text
@@ -123,7 +124,7 @@ data Config (loaded :: Bool) = Config
, _verbose :: Bool
, _interval :: Int
-- ^ port to bind to
- , _exneuland :: BaseUrl
+ , _exneuland :: Maybe BaseUrl
, _token :: Maybe Text
, _orgs :: [Org loaded]
} deriving Generic
@@ -142,6 +143,7 @@ orgCodec = Org
<$> T.text "slug" .= orgSlug
<*> T.string "lintconfig" .= orgLintconfig
<*> T.string "entrypoint" .= orgEntrypoint
+ <*> T.int "generation" .= orgGeneration
<*> T.list remoteCodec "repo" .= orgRepos
<*> T.text "url" .= orgUrl
<*> T.text "webdir" .= orgWebdir
@@ -158,7 +160,7 @@ configCodec = Config
<*> T.int "port" .= _port
<*> T.bool "verbose" .= _verbose
<*> T.int "interval" .= _interval
- <*> T.match (urlBimap >>> T._String) "exneuland" .= _exneuland
+ <*> coerce (T.first (T.match (urlBimap >>> T._String)) "exneuland") .= _exneuland
-- First is just Maybe but with different semantics
<*> coerce (T.first T.text "token") .= _token
<*> T.list orgCodec "org" .= _orgs
@@ -221,3 +223,9 @@ setJobStatus mvar !org !ref !status = do
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))
+
+-- | the path (relative to a baseurl / webdir) where an adjusted
+-- map should go
+adjustedPath :: Text -> Org True -> Text -- TODO: filepath library using Text?
+adjustedPath rev Org {..} =
+ orgWebdir <> "/" <> (rev <> show orgGeneration)
diff --git a/server/Worker.hs b/server/Worker.hs
index af07904..b3ce1da 100644
--- a/server/Worker.hs
+++ b/server/Worker.hs
@@ -20,12 +20,13 @@ import qualified Data.UUID.V4 as UUID
import Server (Config, JobStatus (..),
Org (..),
RemoteRef (reporef, repourl),
- ServerState, setJobStatus,
- tmpdir)
+ ServerState, adjustedPath,
+ setJobStatus, tmpdir)
import System.Directory (doesDirectoryExist)
+import System.Exit (ExitCode (ExitFailure))
import System.FilePath ((</>))
import System.Process
-
+import WriteRepo (writeAdjustedRepository)
data Job = Job
{ jobRef :: RemoteRef
@@ -67,9 +68,24 @@ runJob config Job {..} done = do
callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ]
res <- recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg)
- >>= evaluateNF . shrinkDirResult
+ >>= evaluateNF
+
+ writeAdjustedRepository (orgLintconfig jobOrg) workdir (toString $ adjustedPath rev jobOrg) res
+ >>= \case ExitFailure 1 ->
+ -- error's in the result anyways
+ pure ()
+ ExitFailure 2 ->
+ -- TODO: use a fastlogger for this or sth
+ -- TODO: shouldn't have linted this map at all
+ putTextLn "ERROR: outpath already exists"
+ ExitFailure n -> do -- impossible
+ print n
+ pure ()
+ _ -> pure () -- all good
+
+ putTextLn "still here!"
setJobStatus done jobOrg jobRef $
- Linted res rev
+ Linted (shrinkDirResult res) rev
cleanup workdir = do
callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
--
GitLab