feat: Add tool to check workflows against a base yaml file.

This allows us to enforce e.g. that every project has the common CI
checks in its "ci.yml".

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

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

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",
+    ],
+)

tools/check-workflows.hs

@@ -0,0 +1,73 @@
+-- | Check that a workflow file is a subset of a reference workflow file.
+--
+-- Usage: check-workflows <ref.yml> <workflow.yml>...
+--
+-- 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 <ref.yml> <workflow.yml>..."
+      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