server: write out adjusted maps

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

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 =

server/Handlers.hs

@@ -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) ]
 
 
 

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?
+  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' (view exneuland config))
-  --   print res
-  --   threadDelay (view interval config * 1000000)
+    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)

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)

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 ]