diff --git a/github-tools.cabal b/github-tools.cabal index 29ef423..31c080a 100644 --- a/github-tools.cabal +++ b/github-tools.cabal @@ -119,6 +119,7 @@ library GitHub.Types.Events.WorkflowJobEvent GitHub.Types.Events.WorkflowRunEvent GitHub.Types.PayloadParser + GitHub.Types.Workflow GitHub.WebHook.Handler ghc-options: -Wall @@ -152,6 +153,19 @@ library , vector , yaml +executable check-workflows + main-is: check-workflows.hs + ghc-options: -Wall + hs-source-dirs: tools + default-language: Haskell2010 + build-depends: + base + , Diff + , github-tools + , pretty + , text + , yaml + executable hub-automerge main-is: hub-automerge.hs ghc-options: -Wall diff --git a/src/GitHub/Types/Workflow.hs b/src/GitHub/Types/Workflow.hs new file mode 100644 index 0000000..b069151 --- /dev/null +++ b/src/GitHub/Types/Workflow.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module GitHub.Types.Workflow where + +import Control.Applicative ((<|>)) +import Data.Aeson (FromJSON (..), ToJSON (toJSON), + Value (..)) +import qualified Data.Aeson.Key as Key +import Data.Aeson.KeyMap (KeyMap) +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Aeson.TH (Options (..), defaultOptions, deriveJSON) +import Data.Aeson.Types (parseEither) +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Vector as V +import Debug.Trace (trace) +import Text.Casing (kebab, quietSnake) + +data Input = Input + { inputDefault :: Maybe Text + , inputRequired :: Bool + , inputType :: Text + } + deriving (Show, Eq) +$(deriveJSON defaultOptions{fieldLabelModifier = kebab . drop (Text.length "Input")} ''Input) + +newtype Secret = Secret + { secretRequired :: Bool + } + deriving (Show, Eq) +$(deriveJSON defaultOptions{fieldLabelModifier = kebab . drop (Text.length "Secret")} ''Secret) + +data OnSpec = OnSpec + { onSpecBranches :: Maybe [Text] + , onSpecInputs :: Maybe (HashMap Text Input) + , onSpecSecrets :: Maybe (HashMap Text Secret) + , onSpecTypes :: Maybe [Text] + } + deriving (Show, Eq) +$(deriveJSON defaultOptions{fieldLabelModifier = kebab . drop (Text.length "OnSpec")} ''OnSpec) + +newtype OnSchedule = OnSchedule + { onScheduleCron :: Text + } + deriving (Show, Eq) +$(deriveJSON defaultOptions{fieldLabelModifier = kebab . drop (Text.length "OnSchedule")} ''OnSchedule) + +data OnMap = OnMap + { onMapPullRequest :: Maybe OnSpec + , onMapPullRequestTarget :: Maybe OnSpec + , onMapPush :: Maybe OnSpec + , onMapRelease :: Maybe OnSpec + , onMapSchedule :: Maybe [OnSchedule] + , onMapWorkflowCall :: Maybe OnSpec + , onMapWorkflowDispatch :: Maybe OnSpec + } + deriving (Show, Eq) +$(deriveJSON defaultOptions{fieldLabelModifier = quietSnake . drop (Text.length "OnMap")} ''OnMap) + +data OneOf a b + = A a + | B b + deriving (Show, Eq) + +instance (ToJSON a, ToJSON b) => ToJSON (OneOf a b) where + toJSON (A x) = toJSON x + toJSON (B x) = toJSON x + +instance (FromJSON a, FromJSON b) => FromJSON (OneOf a b) where + parseJSON x = A <$> parseJSON x <|> B <$> parseJSON x + +data Step = Step + { stepId :: Maybe Text + , stepIf :: Maybe Text + , stepName :: Maybe Text + , stepEnv :: Maybe (HashMap Text Text) + , stepRun :: Maybe Text + , stepWith :: Maybe (HashMap Text Value) + , stepUses :: Maybe Text + } + deriving (Show, Eq) +$(deriveJSON defaultOptions{fieldLabelModifier = kebab . drop (Text.length "Step")} ''Step) + +newtype RunConfig = RunConfig + { runConfigShell :: Maybe Text + } + deriving (Show, Eq) +$(deriveJSON defaultOptions{fieldLabelModifier = kebab . drop (Text.length "RunConfig")} ''RunConfig) + +newtype JobDefaults = JobDefaults + { jobDefaultsRun :: Maybe RunConfig + } + deriving (Show, Eq) +$(deriveJSON defaultOptions{fieldLabelModifier = kebab . drop (Text.length "JobDefaults")} ''JobDefaults) + +data Permission + = PermissionRead + | PermissionWrite + deriving (Show, Eq) +$(deriveJSON defaultOptions{constructorTagModifier = kebab . drop (Text.length "Permission")} ''Permission) + +data PermissionsMap = PermissionsMap + { permissionsMapContents :: Maybe Permission + , permissionsMapPullRequests :: Maybe Permission + } + deriving (Show, Eq) +$(deriveJSON defaultOptions{fieldLabelModifier = kebab . drop (Text.length "PermissionsMap")} ''PermissionsMap) + +data PermissionsString + = PermissionsStringReadAll + | PermissionsStringWriteAll + deriving (Show, Eq) +$(deriveJSON defaultOptions{constructorTagModifier = kebab . drop (Text.length "PermissionsString")} ''PermissionsString) + +type Permissions = OneOf PermissionsMap PermissionsString + +data Strategy = Strategy + { strategyFailFast :: Maybe Bool + , strategyMatrix :: HashMap Text [Value] + } + deriving (Show, Eq) +$(deriveJSON defaultOptions{fieldLabelModifier = kebab . drop (Text.length "Strategy")} ''Strategy) + +data Job = Job + { jobDefaults :: Maybe JobDefaults + , jobEnv :: Maybe (HashMap Text Text) + , jobContainer :: Maybe Text + , jobName :: Maybe Text + , jobNeeds :: Maybe [Text] + , jobPermissions :: Maybe Permissions + , jobRunsOn :: Maybe Text + , jobSecrets :: Maybe (HashMap Text Text) + , jobSteps :: Maybe [Step] + , jobStrategy :: Maybe Strategy + , jobUses :: Maybe Text + } + deriving (Show, Eq) +$(deriveJSON defaultOptions{fieldLabelModifier = kebab . drop (Text.length "Job")} ''Job) + +data Concurrency = Concurrency + { concurrencyGroup :: Text + , concurrencyCancelInProgress :: Bool + } + deriving (Show, Eq) +$(deriveJSON defaultOptions{fieldLabelModifier = kebab . drop (Text.length "Concurrency")} ''Concurrency) + +type On = OneOf OnMap [Text] + +data Spec = Spec + { specConcurrency :: Maybe Concurrency + , specEnv :: Maybe (HashMap Text Text) + , specName :: Maybe Text + , specOn :: On + , specPermissions :: Maybe Permissions + , specJobs :: HashMap Text Job + } + deriving (Show, Eq) +$(deriveJSON defaultOptions{fieldLabelModifier = kebab . drop (Text.length "Spec")} ''Spec) + +parseSpec :: Value -> Either String Spec +parseSpec = parseEither parseJSON + +removeNulls :: ToJSON a => a -> Value +removeNulls = go . toJSON + where + go (Array x) = Array . V.map go $ x + go (Object x) = Object . KeyMap.map go . KeyMap.filterWithKey validPair $ x + go x = x + + isEmpty Null = True + isEmpty (Array x) = null x + isEmpty _ = False + + validPair k v = not (isEmpty v || "x-" `Text.isPrefixOf` Key.toText k) + +valueIntersection :: Value -> Value -> Value +valueIntersection (Object x) (Object y) = Object $ KeyMap.intersectionWith valueIntersection x y +valueIntersection (Array x) (Array y) = Array $ V.filter (/= Null) $ V.zipWith valueIntersection x y +valueIntersection _ y = y + +specIntersection :: Spec -> Spec -> Spec +specIntersection a b = + case parseSpec $ valueIntersection (removeNulls $ toJSON a) (removeNulls $ toJSON b) of + Left err -> error $ "workflow spec intersection is not parseable (should not happen): " <> err + Right ok -> ok diff --git a/tools/BUILD.bazel b/tools/BUILD.bazel index 54c25bf..5fdbf5b 100644 --- a/tools/BUILD.bazel +++ b/tools/BUILD.bazel @@ -15,3 +15,18 @@ load("@rules_haskell//haskell:defs.bzl", "haskell_binary") "//third_party/haskell:yaml", ], ) for file in glob(["hub-*.hs"])] + +haskell_binary( + name = "check-workflows", + srcs = ["check-workflows.hs"], + tags = ["no-cross"], + visibility = ["//visibility:public"], + deps = [ + "//hs-github-tools", + "//third_party/haskell:Diff", + "//third_party/haskell:base", + "//third_party/haskell:pretty", + "//third_party/haskell:text", + "//third_party/haskell:yaml", + ], +) diff --git a/tools/check-workflows.hs b/tools/check-workflows.hs new file mode 100644 index 0000000..d7818d4 --- /dev/null +++ b/tools/check-workflows.hs @@ -0,0 +1,73 @@ +-- | Check that a workflow file is a subset of a reference workflow file. +-- +-- Usage: check-workflows ... +-- +-- The reference workflow file is a YAML file that contains a workflow spec. +-- +-- The workflow files must be a superset of the reference workflow spec, i.e. +-- the intersection of the reference workflow spec and the workflow spec must be +-- equal to the reference workflow spec. +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Control.Monad (forM_, unless, when) +import qualified Data.Algorithm.DiffContext as Diff +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.IO as Text +import Data.Yaml (Value (..), decodeFileThrow, + encode) +import GitHub.Types.Workflow +import System.Environment (getArgs) +import System.Exit (exitFailure) +import qualified Text.PrettyPrint as PP + +loadSpec :: FilePath -> IO Value +loadSpec = decodeFileThrow + +mustParseSpec :: Value -> IO Spec +mustParseSpec inValue = + case parseSpec inValue of + Left err -> fail err + Right ok -> return ok + +main :: IO () +main = do + files <- getArgs + case files of + refYmlPath:workflowYmlPaths -> do + ok <- mapM (checkWorkflow refYmlPath) workflowYmlPaths + unless (and ok) exitFailure + _ -> do + putStrLn "Usage: check-workflows ..." + exitFailure + +checkWorkflow :: FilePath -> FilePath -> IO Bool +checkWorkflow refYmlPath workflowYmlPath = do + ref <- mustParseSpec =<< loadSpec refYmlPath + inValue <- loadSpec workflowYmlPath + spec <- mustParseSpec inValue + let outValue = removeNulls spec + when (removeNulls inValue /= outValue) $ do + Text.putStrLn . Text.decodeUtf8 . encode $ outValue + putStrLn "Input not fully parseable" + exitFailure + let intersection = specIntersection ref spec + if intersection == ref + then return True + else do + let intersectionYaml = Text.decodeUtf8 . encode . removeNulls $ intersection + let refYaml = Text.decodeUtf8 . encode . removeNulls $ ref + putStrLn $ workflowYmlPath <> ": intersection not equal to reference spec " <> refYmlPath + Text.putStrLn $ showDiff intersectionYaml refYaml + return False + +showDiff :: Text -> Text -> Text +showDiff a b = Text.pack . PP.render . toDoc $ diff + where + toDoc = Diff.prettyContextDiff (PP.text "payload") + (PP.text "value") + (PP.text . Text.unpack) + diff = Diff.getContextDiff linesOfContext (Text.lines a) (Text.lines b) + linesOfContext = 3