summaryrefslogtreecommitdiff
path: root/src/Fly/Yaml.hs
blob: 87135ff80fe1afa8a3b7375946a9db187a73a637 (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
71
72
{-# 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
import qualified Data.Map.Ordered as OM

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 $ foldr mkGroupValue [] (OM.assocs 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] -> OM.OMap Text [Text]
groupedJobsToMap gjs =
  let toGroupJobsPair (GroupedJob j groups) = map (, [jobName j]) groups
      groupJobsPairs = concatMap toGroupJobsPair gjs
      foldFn pair = OM.unionWithL (\_ v1 v2 -> v1 ++ v2) (OM.fromList [pair])
  in foldr foldFn OM.empty 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 ]