diff --git a/config.json b/config.json
index 1ccb0a57d4ac3f94c0c754d1800050479e6cfdb5..35e89e9bf1c345dc97c1289b27d7e1f73a6acc85 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 9e3027c415a8b8c6393f4b1d2795e6957fcc506e..8611f03a8f5f24211e1277164a86e7dc50656d5c 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 11a81225fc9a4fe71277919525fc207a79377c9d..b0fa3b053e5c9d2b1354b9217b65da86405621aa 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 63cea1f241298128198a8f7e34be55b98a028c35..b937534d9e2456b2788b828d07201b8570a9c51e 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 596c272bc2a1e0e6a163ca052393660e1e1b50ce..40ea43e3eb047454f47232009007055bb244ab22 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 779509d3ad1310d44989ef7b9aac3867a23f2315..da2e73dad7652b9521c5b316e6267c108b5236cf 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 8b3903c226150e38ccf44086046c7af55b4fd711..a5fab58c20634c35aee67394aaa4232b43481ef2 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 b2002bf79c51f8f211aefabefb24e019a7540458..9628e1efcadc5a14686b351473b47fff0bf736f1 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 2ec1537af630972855f724f425153172d2ef856f..e62c9b8a402fefba82958732aef6cea1d18dc7af 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]")