diff options
| -rw-r--r-- | config.json | 16 | ||||
| -rw-r--r-- | lib/CheckMap.hs | 13 | ||||
| -rw-r--r-- | lib/LintConfig.hs | 163 | ||||
| -rw-r--r-- | lib/Properties.hs | 68 | ||||
| -rw-r--r-- | lib/Uris.hs | 90 | ||||
| -rw-r--r-- | server/Server.hs | 22 | ||||
| -rw-r--r-- | server/Worker.hs | 22 | ||||
| -rw-r--r-- | src/Main.hs | 9 | ||||
| -rw-r--r-- | src/Version.hs | 2 |
9 files changed, 222 insertions, 183 deletions
diff --git a/config.json b/config.json index 1ccb0a5..35e89e9 100644 --- a/config.json +++ b/config.json @@ -6,13 +6,13 @@ "MaxLintLevel":"Fatal", "DontCopyAssets":false, "UriSchemas": { - "world": { - "scope" : ["map"], - "substs" : { - } - }, - "https": { - "scope" : [ "website", "audio" ] - } + "https:": [ + { + "scope" : [ "website", "audio" ] + }, + { + "scope" : [ "script" ], + "allowed" : [ "scripts.world.di.c3voc.de" ] + }] } } diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 9e3027c..8611f03 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -10,6 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RecordWildCards #-} -- | Module that contains the high-level checking functions module CheckMap (loadAndLintMap, MapResult(..), ResultKind(..), Optional,shrinkMapResult) where @@ -28,7 +29,7 @@ import Badges (Badge) import Data.Tiled (Layer (layerLayers, layerName), Tiledmap (tiledmapLayers, tiledmapTilesets), loadTiledmap) -import LintConfig (LintConfig (configAssemblyTag), LintConfig') +import LintConfig (LintConfig', LintConfig (..)) import LintWriter (LintResult, invertLintResult, resultToAdjusted, resultToBadges, resultToDeps, resultToLints, resultToOffers, @@ -111,11 +112,12 @@ loadAndLintMap config path depth = loadTiledmap path <&> \case -- | lint a loaded map runLinter :: Bool -> LintConfig' -> Tiledmap -> Int -> MapResult Full -runLinter isMain config tiledmap depth = MapResult +runLinter isMain config@LintConfig{..} tiledmap depth = MapResult { mapresultLayer = invertThing layer , mapresultTileset = invertThing tileset , mapresultGeneral = - ([Hint Error "main.json should link back to the lobby" | isMain && not (any linksLobby layerDeps)]) + [Hint Warning "main.json should link back to the lobby" + | isMain && not (any linksLobby layerDeps)] <> lintsToHints (resultToLints generalResult) , mapresultDepends = resultToDeps generalResult <> layerDeps @@ -127,9 +129,10 @@ runLinter isMain config tiledmap depth = MapResult } where linksLobby = \case - MapLink link -> "/@/rc3_21/lobby" `T.isPrefixOf` link + MapLink link -> + ("/@/"<>configEventSlug<>"/lobby") `T.isPrefixOf` link || configAssemblyTag config == "lobby" - _ -> False + _ -> False layerDeps = concatMap resultToDeps layer layer = checkLayerRec config depth (V.toList $ tiledmapLayers tiledmap) tileset = checkThing tiledmapTilesets checkTileset diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs index 11a8122..b0fa3b0 100644 --- a/lib/LintConfig.hs +++ b/lib/LintConfig.hs @@ -1,19 +1,21 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Module that deals with handling config options -module LintConfig (LintConfig(..), LintConfig', patchConfig) where +module LintConfig (LintConfig(..), LintConfig', ConfigKind (..), patchConfig,stuffConfig,feedConfig) where import Universum -import qualified Universum.Unsafe as Unsafe import Data.Aeson (FromJSON (parseJSON), Options (..), defaultOptions, eitherDecode) @@ -28,38 +30,51 @@ import Uris (SchemaSet, Substitution (DomainSubstitution)) import WithCli.Pure (Argument (argumentType, parseArgument)) -type family HKD f a where - HKD Identity a = a - HKD f a = f a -data LintConfig f = LintConfig - { configScriptInject :: HKD f (Maybe Text) + +data ConfigKind = Complete | Basic | Skeleton | Patch + +-- | a field that must be given in configs for both server & standalone linter +type family ConfigField (f::ConfigKind) a where + ConfigField Patch a = Maybe a + ConfigField _ a = a + +-- | a field that must be given for the standalone linter, but not the server +-- (usually because the server will infer them from its own config) +type family StandaloneField (f :: ConfigKind) a where + StandaloneField Complete a = a + StandaloneField Skeleton a = a + StandaloneField _ a = Maybe a + +-- | a field specific to a single world / assembly +type family WorldField (f :: ConfigKind) a where + WorldField Complete a = a + WorldField _ a = Maybe a + +data LintConfig (f :: ConfigKind) = LintConfig + { configScriptInject :: ConfigField f (Maybe Text) -- ^ Link to Script that should be injected - , configAssemblyTag :: HKD f Text + , configAssemblyTag :: WorldField f Text -- ^ Assembly name (used for jitsiRoomAdminTag) - , configAssemblies :: HKD f [Text] + , configAssemblies :: StandaloneField f [Text] -- ^ list of all assembly slugs (used to lint e.g. world:// links) - , configMaxLintLevel :: HKD f Level + , configEventSlug :: StandaloneField f Text + -- ^ slug of this event (used e.g. to resolve world:// links) + , configMaxLintLevel :: ConfigField f Level -- ^ Maximum warn level allowed before the lint fails - , configDontCopyAssets :: HKD f Bool + , configDontCopyAssets :: ConfigField f Bool -- ^ Don't copy map assets (mostly useful for development) - , configAllowScripts :: HKD f Bool + , configAllowScripts :: ConfigField f Bool -- ^ Allow defining custom scripts in maps - , configUriSchemas :: HKD f SchemaSet + , configUriSchemas :: ConfigField f SchemaSet } deriving (Generic) -type LintConfig' = LintConfig Identity +type LintConfig' = LintConfig Complete --- TODO: should probably find a way to write these constraints nicer ... -deriving instance - ( Show (HKD a (Maybe Text)) - , Show (HKD a Text) - , Show (HKD a Level) - , Show (HKD a [Text]) - , Show (HKD a Bool) - , Show (HKD a SchemaSet) - ) - => Show (LintConfig a) +deriving instance Show (LintConfig Complete) +deriving instance Show (LintConfig Skeleton) +deriving instance Show (LintConfig Patch) +instance NFData (LintConfig Basic) aesonOptions :: Options aesonOptions = defaultOptions @@ -68,23 +83,13 @@ aesonOptions = defaultOptions , fieldLabelModifier = drop 6 } -instance - ( FromJSON (HKD a (Maybe Text)) - , FromJSON (HKD a [Text]) - , FromJSON (HKD a Text) - , FromJSON (HKD a Level) - , FromJSON (HKD a Bool) - , FromJSON (HKD a SchemaSet) - ) - => FromJSON (LintConfig a) - where - parseJSON = genericParseJSON aesonOptions +instance FromJSON (LintConfig Complete) where + parseJSON = genericParseJSON aesonOptions --- need to define this one extra, since Aeson will not make --- Maybe fields optional if the type isn't given explicitly. --- --- Whoever said instances had confusing semantics? -instance {-# Overlapping #-} FromJSON (LintConfig Maybe) where +instance FromJSON (LintConfig Patch) where + parseJSON = genericParseJSON aesonOptions + +instance FromJSON (LintConfig Basic) where parseJSON = genericParseJSON aesonOptions @@ -118,30 +123,66 @@ instance GPatch i o -- abstract, I just wanted to play around with higher kinded types for -- a bit. patch :: - ( Generic (f Maybe) - , Generic (f Identity) - , GPatch (Rep (f Identity)) - (Rep (f Maybe)) + ( Generic (f Patch) + , Generic (f Complete) + , GPatch (Rep (f Complete)) + (Rep (f Patch)) ) - => f Identity - -> f Maybe - -> f Identity + => f Complete + -> f Patch + -> f Complete patch x y = to (gappend (from x) (from y)) -patchConfig :: LintConfig Identity -> Maybe (LintConfig Maybe) -> LintConfig Identity -patchConfig config p = config' - { configUriSchemas = ("world", assemblysubsts) : configUriSchemas config'} - where config' = case p of - Just p -> patch config p - Nothing -> config - assemblysubsts = - DomainSubstitution (M.fromList generated) scope - where generated = (\slug -> (slug, "/@/rc3_21/"<>slug)) <$> configAssemblies config' - scope = (\(DomainSubstitution _ s) -> s) - . snd . Unsafe.head - . filter ((==) "world" . fst) - $ configUriSchemas config' - +patchConfig + :: LintConfig Complete + -> Maybe (LintConfig Patch) + -> LintConfig Complete +patchConfig config p = expandWorlds config' + where + config' = case p of + Just p -> patch config p + Nothing -> config + + +-- | feed a basic server config +feedConfig + :: LintConfig Basic + -> [Text] + -> Text + -> LintConfig Skeleton +feedConfig LintConfig{..} worlds eventslug = expandWorlds $ + LintConfig + { configAssemblies = worlds + , configEventSlug = eventslug + , .. } + +-- | stuff a +stuffConfig :: LintConfig Skeleton -> Text -> LintConfig Complete +stuffConfig LintConfig{..} assemblyslug = + LintConfig + { configAssemblyTag = assemblyslug + , ..} + +class HasWorldList (a :: ConfigKind) +instance HasWorldList 'Complete +instance HasWorldList 'Skeleton + +-- kinda sad that ghc can't solve these contraints automatically, +-- though i guess it also makes sense … +expandWorlds + :: ( ConfigField a SchemaSet ~ SchemaSet + , StandaloneField a [Text] ~ [Text] + , StandaloneField a Text ~ Text + , HasWorldList a) + => LintConfig a -> LintConfig a +expandWorlds config = config { configUriSchemas = configUriSchemas' } + where + configUriSchemas' = + M.insert "world:" [assemblysubsts] (configUriSchemas config) + assemblysubsts = + DomainSubstitution (M.fromList generated) ["map"] + where generated = configAssemblies config + <&> \slug -> (slug, "/@/"<>configEventSlug config<>"/"<>slug) instance (FromJSON (LintConfig a)) => Argument (LintConfig a) where parseArgument str = diff --git a/lib/Properties.hs b/lib/Properties.hs index 63cea1f..b937534 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -15,7 +15,7 @@ module Properties (checkMap, checkTileset, checkLayer) where import Universum hiding (intercalate, isPrefixOf) -import Data.Text (intercalate, isInfixOf, isPrefixOf) +import Data.Text (intercalate, isPrefixOf) import qualified Data.Text as T import Data.Tiled (Layer (..), Object (..), Property (..), PropertyValue (..), Tile (..), @@ -42,8 +42,7 @@ import LintWriter (LintWriter, adjust, askContext, import Paths (PathResult (..), RelPath (..), getExtension, isOldStyle, parsePath) import Types (Dep (Link, Local, LocalMap, MapLink)) -import Uris (SubstError (..), applySubsts, - extractDomain, parseUri) +import Uris (SubstError (..), applySubsts) @@ -140,12 +139,9 @@ checkMapProperty p@(Property name _) = case name of -- "canonical" form, but allowing that here so that multiple -- scripts can be used by one map _ | T.toLower name == "script" -> - unwrapString p $ \str -> - unless (checkIsRc3Url str && - not ( "/../" `isInfixOf` str) && - not ( "%" `isInfixOf` str) && - not ( "@" `isInfixOf` str)) - $ forbid "only scripts hosted on static.rc3.world are allowed." + unwrapURI (Proxy @"script") p + (dependsOn . Link) + (const $ forbid "scripts loaded from local files are disallowed") | name `elem` ["jitsiRoom", "playAudio", "openWebsite" , "url", "exitUrl", "silent", "getBadge"] -> complain $ "property " <> name @@ -342,11 +338,6 @@ checkObjectGroupProperty (Property name _) = case name of \not the object layer." _ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers" -checkIsRc3Url :: Text -> Bool -checkIsRc3Url text= case extractDomain text of - Nothing -> False - Just domain -> do - domain == "https://static.rc3.world" -- | Checks a single (custom) property of a "normal" tile layer @@ -405,7 +396,8 @@ checkTileThing removeExits p@(Property name _value) = case name of unwrapURI (Proxy @"map") p (\link -> do assemblyslug <- lintConfig configAssemblyTag - case T.stripPrefix ("/@/rc3_21/"<>assemblyslug<>"/") link of + eventslug <- lintConfig configEventSlug + case T.stripPrefix ("/@/"<>eventslug<>"/"<>assemblyslug<>"/") link of Nothing -> do dependsOn (MapLink link) setProperty "exitUrl" link @@ -424,8 +416,8 @@ checkTileThing removeExits p@(Property name _value) = case name of let ext = getExtension path in if | isOldStyle path -> complain "Old-Style inter-repository links (using {<placeholder>}) \ - \cannot be used at rC3 2021; please use world:// instead \ - \(see howto.rc3.world)." + \cannot be used at divoc bb3; please use world:// instead \ + \(see https://di.c3voc.de/howto:world)." | ext == "tmx" -> complain "Cannot use .tmx map format; use Tiled's json export instead." | ext /= "json" -> @@ -471,22 +463,21 @@ checkTileThing removeExits p@(Property name _value) = case name of , "jitsiroomadmintag", "jitsiinterfaceconfig" , "openwebsitepolicy", "allowapi" ] -> forbidProperty name - -- the openWebsite Api can only be allowed if the website is on static.rc3.world - | T.toLower name == "openwebsiteallowapi" - -> do - properties <- askContext <&> getProperties - unless (all (\(Property name value) -> case value of - StrProp str -> name /= "openWebsite" || checkIsRc3Url str - _ -> True - ) properties) - $ complain "\"openWebsiteAllowApi\" can only be used with websites hosted \ - \on https://static.rc3.world" | name `elem` [ "openWebsite", "openTab" ] -> do uselessEmptyLayer - suggestProperty $ Property "openWebsiteTrigger" (StrProp "onaction") - unwrapURI (Proxy @"website") p - (dependsOn . Link) - (const $ forbid "accessing local html files is disallowed.") + suggestProperty $ Property "openWebsiteTrigger" "onaction" + + properties <- askContext <&> getProperties + let isScript = any (\(Property name _) -> + T.toLower name == "openwebsiteallowapi") + properties + if isScript + then unwrapURI (Proxy @"script") p + (dependsOn . Link) + (const $ forbid "accessing local html files is disallowed") + else unwrapURI (Proxy @"website") p + (dependsOn . Link) + (const $ forbid "accessing local html files is disallowed.") | otherwise -> when (not removeExits || name `notElem` [ "collides", "name", "tilesetCopyright" ]) $ do warnUnknown p knownTileLayerProperites @@ -634,11 +625,6 @@ setProperty name value = adjust $ \ctxt -> $ \ps -> Just $ Property name (asProperty value) : filter sameName ps where sameName (Property name' _) = name /= name' -removeProperty :: HasProperties ctxt => Text -> LintWriter ctxt -removeProperty name = adjust $ \ctxt -> - flip adjustProperties ctxt - $ \ps -> Just $ filter (\(Property name' _) -> name' /= name) ps - naiveEscapeProperty :: HasProperties a => Property -> LintWriter a naiveEscapeProperty prop@(Property name _) = unwrapString prop (setProperty name . naiveEscapeHTML) @@ -691,7 +677,9 @@ unwrapBadgeToken str f = case parseToken str of Nothing -> complain "invalid badge token." --- | unwraps a URI +-- | unwraps a link, giving two cases: +-- - the link might be an (allowed) remote URI +-- - the link might be relative to this map (i.e. just a filepath) unwrapURI :: (KnownSymbol s, HasProperties a) => Proxy s -> Property @@ -715,12 +703,12 @@ unwrapURI sym p@(Property name _) f g = unwrapString p $ \link -> do DomainDoesNotExist domain -> "The domain " <> domain <> " does not exist; \ \please make sure it is spelled correctly." SchemaDoesNotExist schema -> - "the URI schema " <> schema <> ":// cannot be used." + "the URI schema " <> schema <> "// cannot be used." WrongScope schema allowed -> - "the URI schema " <> schema <> ":// cannot be used in property \ + "the URI schema " <> schema <> "// cannot be used in property \ \\"" <> name <> "\"; allowed " <> (if length allowed == 1 then "is " else "are ") - <> intercalate ", " (fmap (<> "://") allowed) <> "." + <> intercalate ", " (map (<> "//") allowed) <> "." VarsDisallowed -> "extended API links are disallowed in links" diff --git a/lib/Uris.hs b/lib/Uris.hs index 596c272..40ea43e 100644 --- a/lib/Uris.hs +++ b/lib/Uris.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} -- | Functions to deal with uris and custom uri schemes module Uris where @@ -16,7 +17,8 @@ import Data.Aeson (FromJSON (..), Options (..), import qualified Data.Map.Strict as M import qualified Data.Text as T import GHC.TypeLits (KnownSymbol, symbolVal) -import Network.URI (URI (..), URIAuth (..), parseURI) +import Network.URI (URI (..), URIAuth (..), parseURI, + uriToString) import qualified Network.URI.Encode as URI data Substitution = @@ -24,7 +26,7 @@ data Substitution = | DomainSubstitution { substs :: Map Text Text, scope :: [String] } | Allowed { scope :: [String], allowed :: [Text] } | Unrestricted { scope :: [String] } - deriving (Generic, Show) + deriving (Generic, Show, NFData) instance FromJSON Substitution where @@ -33,30 +35,23 @@ instance FromJSON Substitution where , rejectUnknownFields = True } -type SchemaSet = Map Text Substitution +type SchemaSet = Map Text [Substitution] -extractDomain :: Text -> Maybe Text -extractDomain url = - case parseUri url of - Nothing -> Nothing - Just (_,domain,_) -> Just domain - - - - -parseUri :: Text -> Maybe (Text, Text, Text) -parseUri uri = - case parseURI (toString uri) of +-- | deconstruct a URI into a triple of [schema:]//[domain]/[tail...], +-- and a normalised version of the same URI +parseUri :: Text -> Maybe (Text, Text, Text, Text) +parseUri raw = + case parseURI (toString raw) of Nothing -> Nothing - Just parsedUri -> case uriAuthority parsedUri of + Just uri@URI{..} -> case uriAuthority of Nothing -> Nothing - -- https: - Just uriAuth -> Just (T.replace (fromString ":") (fromString "") (fromString (uriScheme parsedUri )), - -- //anonymous@ www.haskell.org :42 - fromString(uriUserInfo uriAuth++uriRegName uriAuth ++ uriPort uriAuth), - -- /ghc ?query #frag - fromString(uriPath parsedUri ++ uriQuery parsedUri ++ uriFragment parsedUri)) + Just URIAuth {..} -> Just + ( fromString uriScheme + , fromString $ uriUserInfo <> uriRegName <> uriPort + , fromString $ uriPath <> uriQuery <> uriFragment + , fromString $ uriToString id uri "" + ) data SubstError = @@ -66,41 +61,46 @@ data SubstError = | IsBlocked | DomainIsBlocked [Text] | VarsDisallowed + | WrongScope Text [Text] -- ^ This link's schema exists, but cannot be used in this scope. -- The second field contains a list of schemas that may be used instead. - | WrongScope Text [Text] deriving (Eq, Ord) -- errors are ordered so we can show more specific ones applySubsts :: KnownSymbol s => Proxy s -> SchemaSet -> Text -> Either SubstError Text applySubsts s substs uri = do - when (T.isInfixOf (toText "{{") uri || T.isInfixOf (toText "}}") uri) + when (T.isInfixOf "{{" uri || T.isInfixOf "}}" uri) $ Left VarsDisallowed - parts@(schema, _, _) <- note NotALink $ parseUri uri + parts@(schema, _, _, _) <- maybeToRight NotALink $ parseUri uri - let rule = M.lookup schema substs + let rules = filter (elem thisScope . scope) . concat $ M.lookup schema substs - case map (applySubst parts) rule of - Nothing -> Left (SchemaDoesNotExist schema) - Just result -> result + case nonEmpty $ map (applySubst parts) rules of + Nothing -> Left (SchemaDoesNotExist schema) + Just result -> minimum result where - note = maybeToRight - applySubst (schema, domain, rest) rule = do + thisScope = symbolVal s + applySubst (schema, domain, rest, uri) rule = do + + -- is this scope applicable? unless (symbolVal s `elem` scope rule) $ Left (WrongScope schema - (map fst . filter (elem (symbolVal s) . scope . snd) $ toPairs substs)) + $ map fst -- make list of available uri schemes + . filter (any (elem thisScope . scope) . snd) + $ toPairs substs) + case rule of DomainSubstitution table _ -> do - prefix <- note (DomainDoesNotExist (schema <> toText "://" <> domain)) - $ M.lookup domain table + prefix <- case M.lookup domain table of + Nothing -> Left (DomainDoesNotExist (schema <> "//" <> domain)) + Just a -> Right a pure (prefix <> rest) Prefixed {..} | domain `elem` blocked -> Left IsBlocked - | domain `elem` allowed || toText "streamproxy.rc3.world" `T.isSuffixOf` domain -> Right uri + | domain `elem` allowed -> Right uri | otherwise -> Right (prefix <> URI.encodeText uri) - Allowed _ domains -> if domain `elem` domains - || toText "streamproxy.rc3.world" `T.isSuffixOf` domain - then Right uri - else Left (DomainIsBlocked domains) + Allowed _ allowlist + | domain `elem` allowlist -> Right uri + | otherwise -> Left (DomainIsBlocked allowlist) Unrestricted _ -> Right uri diff --git a/server/Server.hs b/server/Server.hs index 779509d..da2e73d 100644 --- a/server/Server.hs +++ b/server/Server.hs @@ -47,7 +47,8 @@ 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 LintConfig (ConfigKind (..), LintConfig, + feedConfig) import Servant (FromHttpApiData) import Servant.Client (BaseUrl, parseBaseUrl) import qualified Text.Show as TS @@ -89,7 +90,7 @@ toSha ref = Sha1 data Org (loaded :: Bool) = Org { orgSlug :: Text - , orgLintconfig :: ConfigRes loaded LintConfig' + , orgLintconfig :: ConfigRes loaded (LintConfig Skeleton) , orgEntrypoint :: FilePath , orgGeneration :: Int , orgRepos :: [RemoteRef] @@ -97,7 +98,8 @@ data Org (loaded :: Bool) = Org , orgWebdir :: Text } deriving (Generic) -instance NFData LintConfig' => NFData (Org True) +instance NFData (LintConfig Skeleton) => NFData (Org True) +deriving instance Show (LintConfig Skeleton) => Show (Org True) -- | Orgs are compared via their slugs only -- TODO: the server should probably refuse to start if two orgs have the @@ -176,11 +178,15 @@ loadConfig path = do 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 } + loadOrg org@Org{..} = do + lintconfig <- + eitherDecodeFileStrict' orgLintconfig >>= \case + Right (c :: LintConfig Basic) -> pure c + Left err -> error $ show err + let config = org { orgLintconfig = + feedConfig lintconfig (map reponame orgRepos) orgSlug } + print config + pure config data RealtimeMsg = RelintPending | Reload deriving (Generic, ToJSON) diff --git a/server/Worker.hs b/server/Worker.hs index 8b3903c..a5fab58 100644 --- a/server/Worker.hs +++ b/server/Worker.hs @@ -22,12 +22,12 @@ import qualified Data.Text as T import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID import Fmt ((+|), (|+)) +import LintConfig (stuffConfig) import Server (Config, JobStatus (..), Org (..), RealtimeMsg (RelintPending, Reload), - RemoteRef (reporef, repourl), - ServerState, adjustedPath, - getJobStatus, + RemoteRef (..), ServerState, + adjustedPath, getJobStatus, newRealtimeChannel, setJobStatus, tmpdir, toSha) import System.Directory (doesDirectoryExist) @@ -63,6 +63,7 @@ runJob config Job {..} done = do handle whoops $ finally (lint workdir) (cleanup workdir) where + lintConfig = stuffConfig (orgLintconfig jobOrg) (reponame jobRef) lint workdir = do maybeRealtime <- getJobStatus done (orgSlug jobOrg) (toSha jobRef) >>= \case Nothing -> pure Nothing @@ -80,9 +81,9 @@ runJob config Job {..} done = do -- TODO: these calls fail for dumb http, add some fallback! (callgit gitdir [ "fetch", "origin", toString ref, "--depth", "1" ]) - (callgit gitdir - [ "clone", toString ref, "--bare" - , "--depth", "1", "-b", toString ref]) + (callProcess "git" + [ "clone", toString url, "--bare" + , "--depth", "1", "-b", toString ref, gitdir]) rev <- map T.strip -- git returns a newline here $ readgit' gitdir ["rev-parse", toString ref] @@ -90,10 +91,10 @@ runJob config Job {..} done = do callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ] - res <- recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg) + res <- recursiveCheckDir lintConfig workdir (orgEntrypoint jobOrg) >>= evaluateNF - writeAdjustedRepository (orgLintconfig jobOrg) workdir (toString outPath) res + writeAdjustedRepository lintConfig workdir (toString outPath) res >>= runStdoutLoggingT . \case ExitSuccess -> logInfoN $ "linted map "+| (show jobRef :: Text) |+"." @@ -126,7 +127,6 @@ runJob config Job {..} done = do url = repourl jobRef ref = reporef jobRef - callgit = callgit' gitdir = view tmpdir config </> toString hashedname hashedname = T.map escapeSlash url where escapeSlash = \case { '/' -> '-'; a -> a } @@ -137,8 +137,8 @@ readgit' dir args = map toText $ print args readProcess "git" ([ "-C", toString dir ] <> args) "" -callgit' :: MonadIO m => FilePath -> [String] -> m () -callgit' dir args = +callgit :: MonadIO m => FilePath -> [String] -> m () +callgit dir args = liftIO $ do print args callProcess "git" ([ "-C", toString dir ] <> args) diff --git a/src/Main.hs b/src/Main.hs index b2002bf..9628e1e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} @@ -15,9 +16,9 @@ import Data.Aeson.Encode.Pretty (encodePretty) import Data.Aeson.KeyMap (coercionToHashMap) import WithCli (HasArguments, withCli) -import CheckDir (recursiveCheckDir, resultIsFatal, DirResult (dirresultGraph)) -import Control.Monad (when) -import LintConfig (LintConfig (..), patchConfig) +import CheckDir (recursiveCheckDir, resultIsFatal) +import LintConfig (ConfigKind (..), LintConfig (..), + patchConfig) import System.Exit (ExitCode (ExitFailure)) import Types (Level (..)) import Util (printPretty) @@ -40,7 +41,7 @@ data Options = Options -- ^ path to write the (possibly adjusted) maps to after linting , configFile :: Maybe FilePath -- ^ path to a config file. Currently required. - , config :: Maybe (LintConfig Maybe) + , config :: Maybe (LintConfig Patch) -- ^ a "patch" for the configuration file , version :: Bool , dot :: Bool diff --git a/src/Version.hs b/src/Version.hs index 2ec1537..e62c9b8 100644 --- a/src/Version.hs +++ b/src/Version.hs @@ -9,7 +9,7 @@ import qualified Language.Haskell.TH as TH import System.Process (readProcess) version :: String -version = "walint rc3 2021 (" <> +version = "walint divoc bb3 2022 (" <> $(do hash <- liftIO $ catchAny (readProcess "git" ["rev-parse", "HEAD"] "") (\_ -> pure "[unknown]") |