Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 3 additions & 0 deletions github-actions.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -59,14 +59,17 @@ library
Language.Github.Actions.Job.Container
Language.Github.Actions.Job.Environment
Language.Github.Actions.Job.Id
Language.Github.Actions.Job.Needs
Language.Github.Actions.Job.Strategy
Language.Github.Actions.Permissions
Language.Github.Actions.RunIf
Language.Github.Actions.Service
Language.Github.Actions.Service.Id
Language.Github.Actions.Shell
Language.Github.Actions.Step
Language.Github.Actions.Step.Id
Language.Github.Actions.Step.With
Language.Github.Actions.UnstructuredMap
Language.Github.Actions.Workflow
Language.Github.Actions.Workflow.Trigger

Expand Down
14 changes: 8 additions & 6 deletions src/Language/Github/Actions/Job.hs
Original file line number Diff line number Diff line change
Expand Up @@ -43,12 +43,14 @@ import Language.Github.Actions.Job.Container (JobContainer)
import qualified Language.Github.Actions.Job.Container as JobContainer
import Language.Github.Actions.Job.Environment (JobEnvironment)
import qualified Language.Github.Actions.Job.Environment as JobEnvironment
import Language.Github.Actions.Job.Id (JobId)
import qualified Language.Github.Actions.Job.Id as JobId
import Language.Github.Actions.Job.Needs (JobNeeds)
import qualified Language.Github.Actions.Job.Needs as JobNeeds
import Language.Github.Actions.Job.Strategy (JobStrategy)
import qualified Language.Github.Actions.Job.Strategy as JobStrategy
import Language.Github.Actions.Permissions (Permissions)
import qualified Language.Github.Actions.Permissions as Permissions
import Language.Github.Actions.RunIf (RunIf)
import qualified Language.Github.Actions.RunIf as RunIf
import Language.Github.Actions.Service (Service)
import qualified Language.Github.Actions.Service as Service
import Language.Github.Actions.Service.Id (ServiceId)
Expand Down Expand Up @@ -93,13 +95,13 @@ data Job = Job
-- | Display name for the job
jobName :: Maybe Text,
-- | Jobs this job depends on
needs :: Maybe (NonEmpty JobId),
needs :: Maybe JobNeeds,
-- | Outputs from this job
outputs :: Map Text Text,
-- | Permissions for this job
permissions :: Maybe Permissions,
-- | Condition for running this job
runIf :: Maybe Text,
runIf :: Maybe RunIf,
-- | Runner type (e.g., "ubuntu-latest")
runsOn :: Maybe Text,
-- | Secrets available to this job
Expand Down Expand Up @@ -179,10 +181,10 @@ gen = do
env <- genTextMap
environment <- Gen.maybe JobEnvironment.gen
jobName <- Gen.maybe genText
needs <- Gen.maybe (Gen.nonEmpty (Range.linear 1 5) JobId.gen)
needs <- Gen.maybe JobNeeds.gen
outputs <- genTextMap
permissions <- Gen.maybe Permissions.gen
runIf <- Gen.maybe genText
runIf <- Gen.maybe RunIf.gen
runsOn <- Gen.maybe genText
secrets <- genTextMap
services <- Gen.map (Range.linear 1 5) $ liftA2 (,) ServiceId.gen Service.gen
Expand Down
78 changes: 78 additions & 0 deletions src/Language/Github/Actions/Job/Needs.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,78 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}

-- |
-- Module : Language.Github.Actions.Job.Needs
-- Description : Job dependency specification for GitHub Actions
-- Copyright : (c) 2025 Bellroy Pty Ltd
-- License : BSD-3-Clause
-- Maintainer : Bellroy Tech Team <haskell@bellroy.com>
--
-- This module provides the 'JobNeeds' type for representing job dependencies
-- in GitHub Actions workflows. GitHub Actions allows both strings and
-- lists of strings for the 'needs' field.
--
-- Examples of valid 'needs' specifications:
-- * @needs: build@ - Single job specified as a string
-- * @needs: [build]@ - Single job specified as a list of strings
-- * @needs: [build, test]@ - Multiple job dependencies specified as a list of strings
--
-- For more information about GitHub Actions job dependencies, see:
-- <https://docs.github.com/en/actions/writing-workflows/workflow-syntax-for-github-actions#jobsjob_idneeds>
module Language.Github.Actions.Job.Needs
( JobNeeds (..),
gen,
)
where

import Data.Aeson (FromJSON, ToJSON (..), Value (..))
import qualified Data.Aeson as Aeson
import Data.List.NonEmpty (NonEmpty)
import GHC.Generics (Generic)
import Hedgehog (MonadGen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Language.Github.Actions.Job.Id (JobId)
import qualified Language.Github.Actions.Job.Id as JobId

-- | Job dependency specification that preserves YAML representation.
--
-- GitHub Actions supports flexible job dependency specification:
--
-- * 'JobNeedsString' - Single job dependency as string like @needs: build@
-- * 'JobNeedsArray' - Multiple job dependencies as array like @needs: [build, test]@
--
-- Examples:
--
-- @
-- -- Single job dependency (string form)
-- stringDep :: JobNeeds
-- stringDep = JobNeedsString (JobId "build")
--
-- -- Multiple job dependencies (array form)
-- arrayDeps :: JobNeeds
-- arrayDeps = JobNeedsArray (JobId "build" :| [JobId "test", JobId "lint"])
-- @
--
-- The type preserves the original YAML format during round-trip serialization.
-- A string input will serialize back to a string, and an array input will
-- serialize back to an array, preventing information loss.
data JobNeeds
= JobNeedsString JobId
| JobNeedsArray (NonEmpty JobId)
deriving stock (Eq, Generic, Ord, Show)

instance FromJSON JobNeeds where
parseJSON v@(Array _) = JobNeedsArray <$> Aeson.parseJSON v
parseJSON v = JobNeedsString <$> Aeson.parseJSON v

instance ToJSON JobNeeds where
toJSON (JobNeedsString jobId) = toJSON jobId
toJSON (JobNeedsArray jobIds) = toJSON jobIds

gen :: (MonadGen m) => m JobNeeds
gen =
Gen.choice
[ JobNeedsString <$> JobId.gen,
JobNeedsArray <$> Gen.nonEmpty (Range.linear 1 5) JobId.gen
]
76 changes: 76 additions & 0 deletions src/Language/Github/Actions/RunIf.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,76 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module : Language.Github.Actions.RunIf
-- Description : Flexible conditional expressions for GitHub Actions
-- Copyright : (c) 2025 Bellroy Pty Ltd
-- License : BSD-3-Clause
-- Maintainer : Bellroy Tech Team <haskell@bellroy.com>
--
-- This module provides the 'RunIf' type for representing conditional expressions
-- in GitHub Actions workflows. GitHub Actions allows both boolean and string
-- expressions in 'if' conditions for jobs and steps.
--
-- Examples of valid 'if' conditions:
-- * @if: false@ - Boolean
-- * @if: "github.ref == 'refs/heads/main'"@ - String
--
-- For more information about GitHub Actions conditional expressions, see:
-- <https://docs.github.com/en/actions/writing-workflows/workflow-syntax-for-github-actions#jobsjob_idif>
module Language.Github.Actions.RunIf
( RunIf (..),
gen,
)
where

import Data.Aeson (FromJSON, ToJSON (..), Value (..))
import qualified Data.Aeson as Aeson
import Data.Text (Text)
import GHC.Generics (Generic)
import Hedgehog (MonadGen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

-- | A conditional expression that can be either a boolean or string.
--
-- GitHub Actions supports flexible 'if' conditions:
--
-- * 'RunIfBool' - Simple boolean values like @true@ or @false@
-- * 'RunIfString' - GitHub expressions like @"github.ref == 'refs/heads/main'"@
--
-- Examples:
--
-- @
-- -- Simple boolean condition
-- simpleFalse :: RunIf
-- simpleFalse = RunIfBool False
--
-- -- GitHub expression condition
-- branchCheck :: RunIf
-- branchCheck = RunIfString "github.ref == 'refs/heads/main'"
-- @
--
-- The type preserves the original format during round-trip serialization,
-- so a boolean input remains a boolean in the output YAML.
data RunIf
= RunIfBool Bool
| RunIfString Text
deriving stock (Eq, Generic, Ord, Show)
Comment on lines +57 to +60
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Possible future work: capture a proper AST here?


instance FromJSON RunIf where
parseJSON (Bool b) = pure $ RunIfBool b
parseJSON (String s) = pure $ RunIfString s
parseJSON v = fail $ "Expected Bool or String for RunIf, got: " ++ show v

instance ToJSON RunIf where
toJSON (RunIfBool b) = Bool b
toJSON (RunIfString s) = String s

gen :: (MonadGen m) => m RunIf
gen =
Gen.choice
[ RunIfBool <$> Gen.bool,
RunIfString <$> Gen.text (Range.linear 5 50) Gen.alphaNum
]
6 changes: 4 additions & 2 deletions src/Language/Github/Actions/Step.hs
Original file line number Diff line number Diff line change
Expand Up @@ -35,6 +35,8 @@ import GHC.Generics (Generic)
import Hedgehog (MonadGen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Language.Github.Actions.RunIf (RunIf)
import qualified Language.Github.Actions.RunIf as RunIf
import Language.Github.Actions.Shell (Shell)
import qualified Language.Github.Actions.Shell as Shell
import Language.Github.Actions.Step.Id (StepId)
Expand Down Expand Up @@ -82,7 +84,7 @@ data Step = Step
-- | Command or script to run
run :: Maybe Text,
-- | Condition for running this step
runIf :: Maybe Text,
runIf :: Maybe RunIf,
-- | Shell to use for running commands
shell :: Maybe Shell,
-- | Unique identifier for this step
Expand Down Expand Up @@ -139,7 +141,7 @@ gen = do
env <- genTextMap
name <- Gen.maybe genText
run <- Gen.maybe genText
runIf <- Gen.maybe genText
runIf <- Gen.maybe RunIf.gen
shell <- Gen.maybe Shell.gen
stepId <- Gen.maybe StepId.gen
timeoutMinutes <- Gen.maybe $ Gen.int (Range.linear 1 120)
Expand Down
10 changes: 5 additions & 5 deletions src/Language/Github/Actions/Step/With.hs
Original file line number Diff line number Diff line change
Expand Up @@ -30,14 +30,15 @@ where
import Data.Aeson (FromJSON, ToJSON (..), (.:), (.:?), (.=))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.KeyMap as AesonKeyMap
import Data.Map (Map)
import Data.Maybe (catMaybes)
import qualified Data.Set as Set
import Data.Text (Text)
import GHC.Generics (Generic)
import Hedgehog (MonadGen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Language.Github.Actions.UnstructuredMap (UnstructuredMap)
import qualified Language.Github.Actions.UnstructuredMap as UnstructuredMap

-- | Docker container arguments for Docker actions.
--
Expand Down Expand Up @@ -95,14 +96,14 @@ data StepWith
= -- | Docker action arguments
StepWithDockerArgs StepWithDockerArgsAttrs
| -- | Environment variables/general inputs
StepWithEnv (Map Text Text)
StepWithEnv UnstructuredMap
deriving stock (Eq, Generic, Ord, Show)

instance FromJSON StepWith where
parseJSON = Aeson.withObject "StepWith" $ \o ->
let objectKeySet = Set.fromList (AesonKeyMap.keys o)
dockerKeySet = Set.fromList ["entryPoint", "args"]
in if objectKeySet `Set.isSubsetOf` dockerKeySet
in if not (null objectKeySet) && objectKeySet `Set.isSubsetOf` dockerKeySet
then do
entryPoint <- o .: "entryPoint"
args <- o .:? "args"
Expand All @@ -127,8 +128,7 @@ gen =
entryPoint <- genText
args <- Gen.maybe genText
pure StepWithDockerArgsAttrs {..},
StepWithEnv <$> genTextMap
StepWithEnv <$> UnstructuredMap.gen
]
where
genText = Gen.text (Range.linear 1 5) Gen.alphaNum
genTextMap = Gen.map (Range.linear 1 5) $ liftA2 (,) genText genText
92 changes: 92 additions & 0 deletions src/Language/Github/Actions/UnstructuredMap.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,92 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module : Language.Github.Actions.UnstructuredMap
-- Description : Flexible value types for GitHub Actions YAML parsing
-- Copyright : (c) 2025 Bellroy Pty Ltd
-- License : BSD-3-Clause
-- Maintainer : Bellroy Tech Team <haskell@bellroy.com>
--
-- This module provides the 'UnstructuredMap' type for representing a map of
-- values that can be strings, numbers, or booleans in GitHub Actions YAML files.
--
-- GitHub Actions allows flexible typing in many contexts:
-- * @retention-days: 1@ (number)
-- * @retention-days: "1"@ (string)
-- * @should-retain: false@ (boolean)
--
-- This type preserves the original YAML type during round-trip parsing,
-- ensuring that numeric values remain numeric and strings remain strings.
module Language.Github.Actions.UnstructuredMap
( UnstructuredValue (..),
UnstructuredMap (..),
renderUnstructuredValue,
gen,
)
where

import Data.Aeson (FromJSON, ToJSON (..), Value (..))
import qualified Data.Aeson as Aeson
import Data.Map (Map)
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.Generics (Generic)
import Hedgehog (MonadGen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

-- | A map that can have values of string, number, or boolean.
--
-- This type is designed to handle the flexible typing that GitHub Actions
-- allows in YAML files.
--
-- The type preserves the original format during round-trip serialization,
-- so numeric inputs remain numeric in the output YAML.
data UnstructuredValue
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Can GHA YAML use nulls here, and if so, should we represent them?

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Hrm hypothetically a null can be represented in the YAML, but I cannot think of any instance where having a null in a GHA workflow would be valid

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I wonder if ScalarValue would have been a more meaningful name here? "Unstructured" can mean different things to different people.

It's still debatable, of course, whether a Null value is "structured" or "scalar".

= UnstructuredValueString Text
| UnstructuredValueNumber Double
| UnstructuredValueBool Bool
deriving stock (Eq, Generic, Ord, Show)

instance FromJSON UnstructuredValue where
parseJSON (String s) = pure $ UnstructuredValueString s
parseJSON (Number n) = pure $ UnstructuredValueNumber (realToFrac n)
parseJSON (Bool b) = pure $ UnstructuredValueBool b
parseJSON v = fail $ "Expected String, Number, or Bool for UnstructuredValue, got: " ++ show v

instance ToJSON UnstructuredValue where
toJSON (UnstructuredValueString s) = String s
toJSON (UnstructuredValueNumber n) = Number (fromRational (toRational n))
toJSON (UnstructuredValueBool b) = Bool b

renderUnstructuredValue :: UnstructuredValue -> Text
renderUnstructuredValue (UnstructuredValueString s) = s
renderUnstructuredValue (UnstructuredValueNumber n) =
-- Format numbers nicely, avoiding unnecessary decimal places for integers
if n == fromInteger (round n)
then Text.pack (show (round n :: Integer))
else Text.pack (show n)
renderUnstructuredValue (UnstructuredValueBool b) = if b then "true" else "false"

newtype UnstructuredMap = UnstructuredMap (Map Text UnstructuredValue)
deriving stock (Eq, Generic, Ord, Show)
deriving newtype (FromJSON, ToJSON)

genUnstructuredValue :: (MonadGen m) => m UnstructuredValue
genUnstructuredValue =
Gen.choice
[ UnstructuredValueString <$> Gen.text (Range.linear 1 20) Gen.alphaNum,
UnstructuredValueNumber <$> Gen.realFloat (Range.linearFrac 0 1000),
UnstructuredValueBool <$> Gen.bool
]

gen :: (MonadGen m) => m UnstructuredMap
gen = UnstructuredMap <$> Gen.map (Range.linear 0 10) genKeyValue
where
genKeyValue = do
key <- Gen.text (Range.linear 1 20) Gen.alphaNum
value <- genUnstructuredValue
pure (key, value)
2 changes: 1 addition & 1 deletion test/Language/Github/Actions/WorkflowTest.hs
Original file line number Diff line number Diff line change
Expand Up @@ -50,7 +50,7 @@ test_goldenWorkflowFromYaml = do
putStrLn $ "roundtrip " <> takeBaseName testYamlFilePath
eitherWorkflow <- Yaml.decodeFileEither @Workflow testYamlFilePath
either
(BS.writeFile outputFilePath >> (\_ -> fail "YAML decoding failed"))
(BS.writeFile outputFilePath >> (\e -> fail $ "YAML decoding failed: " ++ show e))
(\workflow -> writeOutputFiles outputFilePath haskellOutputFilePath workflow >> pure workflow)
$ first (encodeUtf8 . Text.pack . Yaml.prettyPrintParseException) eitherWorkflow
writeOutputFiles :: FilePath -> FilePath -> Workflow -> IO ()
Expand Down
Loading
Loading