diff options
Diffstat (limited to '')
| -rw-r--r-- | server/Handlers.hs | 8 | ||||
| -rw-r--r-- | server/Main.hs | 25 | ||||
| -rw-r--r-- | server/Server.hs | 16 | ||||
| -rw-r--r-- | server/Worker.hs | 26 |
4 files changed, 52 insertions, 23 deletions
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 ] |