From dbf2253dc4256809b255767cbf4ae9c236f18542 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Sat, 19 Mar 2022 19:12:04 +0100
Subject: [PATCH] remove leftover rc3 things & some new stuff
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
this removes:
- the bbb properties
- all explicit mentions of rc3
- the weird script domain hacks (done via a substitution now)
- some (few) of the weirder code choices
it also adds some more type level witchery to deal with configs, which
for some reason seems to be the hardest problem of this entire program …
also the server now does inter-assembly dependency checking!
---
config.json | 16 ++---
lib/CheckMap.hs | 13 ++--
lib/LintConfig.hs | 163 +++++++++++++++++++++++++++++-----------------
lib/Properties.hs | 68 ++++++++-----------
lib/Uris.hs | 90 ++++++++++++-------------
server/Server.hs | 22 ++++---
server/Worker.hs | 22 +++----
src/Main.hs | 9 +--
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]")
--
GitLab