summaryrefslogtreecommitdiff
path: root/src/Fly/Yaml.hs
blob: 1858d1956c1b742b8f778f8e682fbf67124e48ec (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Fly.Yaml where

import Data.Aeson
import Data.List  (nub)
import Data.Maybe (catMaybes)
import Data.Text  (Text)
import Fly.Types

import qualified Data.HashMap.Strict as HM

jobsToValue :: [Job] -> Value
jobsToValue = Object . jobsToMap

groupedJobsToValue :: [GroupedJob] -> Value
groupedJobsToValue groupedJobs =
  let mapWithoutGroups = jobsToMap $ map gjJob groupedJobs
      groupsAsMap = groupedJobsToMap groupedJobs
      mkGroupValue group jobs acc = object [ "name" .= group, "jobs" .= jobs ] : acc
      groupsAsValue = toJSON $ HM.foldrWithKey mkGroupValue [] groupsAsMap
      groupsMap = HM.singleton "groups" groupsAsValue
  in Object $ HM.union mapWithoutGroups groupsMap

jobsToMap :: [Job] -> HM.HashMap Text Value
jobsToMap jobs =
  let resources = nub $ concatMap getResourcesFromJob jobs
      resourceTypes = nub $ customResourceTypes $ map Fly.Types.resourceType resources
  in HM.fromList [ ("resource_types", toJSON resourceTypes)
                 , ("resources", toJSON resources)
                 , ("jobs", toJSON jobs)
                 ]

groupedJobsToMap :: [GroupedJob] -> HM.HashMap Text [Text]
groupedJobsToMap gjs =
  let toGroupJobsPair (GroupedJob j groups) = map (, [jobName j]) groups
      groupJobsPairs = concatMap toGroupJobsPair gjs
  in HM.fromListWith (++) groupJobsPairs

customResourceTypes :: [ResourceType] -> [ResourceType]
customResourceTypes [] = []
customResourceTypes (ResourceTypeInBuilt _ : rts) =  customResourceTypes rts
customResourceTypes (x : rts) =  x : customResourceTypes rts

getResourcesFromHooks :: StepHooks -> [Resource]
getResourcesFromHooks StepHooks{..} =
  concatMap getResourcesFromStep
  $ catMaybes [hookOnSuccess, hookOnFailure, hookOnAbort, hookEnsure]

getResourcesFromStep :: Step -> [Resource]
getResourcesFromStep s =
  stepResources s ++ getResourcesFromHooks (Fly.Types.stepHooks s)
  where
    stepResources (Get GetStep{..} _)   = [getResource]
    stepResources (Put PutStep{..} _)   = [putResource]
    stepResources (Task _ _)            = []
    stepResources (Aggregate steps _)   = getResourcesFromSteps steps
    stepResources (Do steps _)          = getResourcesFromSteps steps
    stepResources (Try step _)          = getResourcesFromStep step
    stepResources (InParallel inParallel _) =
       getResourcesFromSteps $ inParallelSteps inParallel

getResourcesFromSteps :: [Step] -> [Resource]
getResourcesFromSteps = concatMap getResourcesFromStep

getResourcesFromJob :: Job -> [Resource]
getResourcesFromJob Job{..} =
  getResourcesFromSteps
  $ jobPlan ++ catMaybes [ jobOnSuccess, jobOnFailure, jobOnAbort, jobEnsure ]