|
| 1 | +module Setup.BuildPlan (buildPlan, BuildPlan) where |
| 2 | + |
| 3 | +import Prelude |
| 4 | + |
| 5 | +import Actions.Core as Core |
| 6 | +import Affjax as AX |
| 7 | +import Affjax.ResponseFormat as RF |
| 8 | +import Data.Argonaut.Core (stringify) |
| 9 | +import Data.Argonaut.Decode (decodeJson, printJsonDecodeError, (.:)) |
| 10 | +import Data.Array as Array |
| 11 | +import Data.Bifunctor (bimap) |
| 12 | +import Data.Either (Either(..), hush) |
| 13 | +import Data.Foldable (elem, fold) |
| 14 | +import Data.Int (toNumber) |
| 15 | +import Data.Maybe (Maybe(..), fromMaybe) |
| 16 | +import Data.String as String |
| 17 | +import Data.Traversable (traverse) |
| 18 | +import Data.Version (Version) |
| 19 | +import Data.Version as Version |
| 20 | +import Effect (Effect) |
| 21 | +import Effect.Aff (Aff, Error, Milliseconds(..), delay, error, throwError) |
| 22 | +import Effect.Aff.Retry (RetryPolicy, RetryPolicyM, RetryStatus(..)) |
| 23 | +import Effect.Aff.Retry as Retry |
| 24 | +import Effect.Class (liftEffect) |
| 25 | +import Math (pow) |
| 26 | +import Setup.Data.Key (Key) |
| 27 | +import Setup.Data.Key as Key |
| 28 | +import Setup.Data.Tool (Tool(..)) |
| 29 | +import Setup.Data.Tool as Tool |
| 30 | +import Text.Parsing.Parser (parseErrorMessage) |
| 31 | +import Text.Parsing.Parser as ParseError |
| 32 | + |
| 33 | +-- | The list of tools that should be downloaded and cached by the action |
| 34 | +type BuildPlan = Array { tool :: Tool, version :: Version } |
| 35 | + |
| 36 | +-- | Construct the list of tools that sholud be downloaded and cached by the action |
| 37 | +buildPlan :: Aff BuildPlan |
| 38 | +buildPlan = do |
| 39 | + let resolve' t = delay (Milliseconds 250.0) *> resolve t |
| 40 | + map Array.catMaybes $ traverse resolve' [ PureScript, Spago, Purty, Zephyr ] |
| 41 | + |
| 42 | +-- Tools that are required in the toolchain |
| 43 | +required :: Tool -> Boolean |
| 44 | +required tool = elem tool [ PureScript, Spago ] |
| 45 | + |
| 46 | +-- | The parsed value of an input field that specifies a version |
| 47 | +data VersionField = Latest | Exact Version |
| 48 | + |
| 49 | +-- | Attempt to read the value of an input specifying a tool version |
| 50 | +getVersionField :: Key -> Effect (Maybe (Either String VersionField)) |
| 51 | +getVersionField = map (map parse) <<< Core.getInput |
| 52 | + where |
| 53 | + parse = case _ of |
| 54 | + "latest" -> pure Latest |
| 55 | + value -> bimap ParseError.parseErrorMessage Exact (Version.parseVersion value) |
| 56 | + |
| 57 | +-- | Resolve the exact version to provide for a tool in the environment, based |
| 58 | +-- | on the action.yml file. |
| 59 | +resolve :: Tool -> Aff (Maybe { tool :: Tool, version :: Version }) |
| 60 | +resolve tool = do |
| 61 | + let key = Key.fromTool tool |
| 62 | + liftEffect (getVersionField key) >>= case _ of |
| 63 | + Nothing | required tool -> throwError $ error "No input received for required key." |
| 64 | + Nothing -> pure Nothing |
| 65 | + Just field -> map Just $ getVersion field |
| 66 | + |
| 67 | + where |
| 68 | + getVersion :: Either String VersionField -> Aff { tool :: Tool, version :: Version } |
| 69 | + getVersion = case _ of |
| 70 | + Left err -> do |
| 71 | + liftEffect $ Core.setFailed $ fold [ "Unable to parse version: ", err ] |
| 72 | + throwError $ error "Unable to complete fetching version." |
| 73 | + |
| 74 | + Right (Exact v) -> do |
| 75 | + liftEffect $ Core.info "Found exact version" |
| 76 | + pure { tool, version: v } |
| 77 | + |
| 78 | + Right Latest -> do |
| 79 | + liftEffect $ Core.info $ fold [ "Fetching latest tag for ", Tool.name tool ] |
| 80 | + v <- fetchLatestReleaseVersion |
| 81 | + pure { tool, version: v } |
| 82 | + |
| 83 | + -- Find the latest release version for a given tool. Prefers explicit releases |
| 84 | + -- as listed in GitHub releases, but for tools which don't support GitHub |
| 85 | + -- releases, falls back to the highest valid semantic version tag for the tool. |
| 86 | + fetchLatestReleaseVersion :: Aff Version |
| 87 | + fetchLatestReleaseVersion = Tool.repository tool # case tool of |
| 88 | + PureScript -> fetchFromGitHubReleases |
| 89 | + Spago -> fetchFromGitHubReleases |
| 90 | + -- Technically, Purty is hosted on Gitlab. But without an accessible way to |
| 91 | + -- fetch the latest release tag from Gitlab via an API, it seems better to fetch |
| 92 | + -- from the GitHub mirror. |
| 93 | + Purty -> fetchFromGitHubTags |
| 94 | + Zephyr -> fetchFromGitHubReleases |
| 95 | + where |
| 96 | + -- TODO: These functions really ought to be in ExceptT to avoid all the |
| 97 | + -- nested branches. |
| 98 | + fetchFromGitHubReleases repo = recover do |
| 99 | + let url = "https://api.github.com/repos/" <> repo.owner <> "/" <> repo.name <> "/releases/latest" |
| 100 | + |
| 101 | + AX.get RF.json url >>= case _ of |
| 102 | + Left err -> do |
| 103 | + throwError (error $ AX.printError err) |
| 104 | + |
| 105 | + Right { body } -> case (_ .: "tag_name") =<< decodeJson body of |
| 106 | + Left e -> do |
| 107 | + throwError $ error $ fold |
| 108 | + [ "Failed to decode GitHub response. This is most likely due to a timeout.\n\n" |
| 109 | + , printJsonDecodeError e |
| 110 | + , stringify body |
| 111 | + ] |
| 112 | + |
| 113 | + Right tagStr -> do |
| 114 | + let tag = fromMaybe tagStr (String.stripPrefix (String.Pattern "v") tagStr) |
| 115 | + case Version.parseVersion tag of |
| 116 | + Left e -> |
| 117 | + throwError $ error $ fold |
| 118 | + [ "Failed to decode tag from GitHub response: ", parseErrorMessage e ] |
| 119 | + |
| 120 | + Right v -> |
| 121 | + pure v |
| 122 | + |
| 123 | + -- If a tool doesn't use GitHub releases and instead only tags versions, then |
| 124 | + -- we have to fetch the tags, parse them as appropriate versions, and then sort |
| 125 | + -- them according to their semantic version to get the latest one. |
| 126 | + fetchFromGitHubTags repo = recover do |
| 127 | + let url = "https://api.github.com/repos/" <> repo.owner <> "/" <> repo.name <> "/tags" |
| 128 | + |
| 129 | + AX.get RF.json url >>= case _ of |
| 130 | + Left err -> do |
| 131 | + throwError (error $ AX.printError err) |
| 132 | + |
| 133 | + Right { body } -> case traverse (_ .: "name") =<< decodeJson body of |
| 134 | + Left e -> do |
| 135 | + throwError $ error $ fold |
| 136 | + [ "Failed to decode GitHub response. This is most likely due to a timeout.\n\n" |
| 137 | + , printJsonDecodeError e |
| 138 | + , stringify body |
| 139 | + ] |
| 140 | + |
| 141 | + Right arr -> do |
| 142 | + let |
| 143 | + tags = Array.catMaybes $ map (\t -> hush $ Version.parseVersion $ fromMaybe t $ String.stripPrefix (String.Pattern "v") t) arr |
| 144 | + sorted = Array.reverse $ Array.sort tags |
| 145 | + |
| 146 | + case Array.head sorted of |
| 147 | + Nothing -> |
| 148 | + throwError $ error "Could not download latest release version." |
| 149 | + |
| 150 | + Just v -> |
| 151 | + pure v |
| 152 | + |
| 153 | + -- Attempt to recover from a failed request by re-attempting according to an |
| 154 | + -- exponential backoff strategy. |
| 155 | + recover :: Aff ~> Aff |
| 156 | + recover action = Retry.recovering policy checks \_ -> action |
| 157 | + where |
| 158 | + policy :: RetryPolicyM Aff |
| 159 | + policy = exponentialBackoff (Milliseconds 5000.0) <> Retry.limitRetries 3 |
| 160 | + |
| 161 | + checks :: Array (RetryStatus -> Error -> Aff Boolean) |
| 162 | + checks = [ \_ -> \_ -> pure true ] |
| 163 | + |
| 164 | + exponentialBackoff :: Milliseconds -> RetryPolicy |
| 165 | + exponentialBackoff (Milliseconds base) = |
| 166 | + Retry.retryPolicy |
| 167 | + \(RetryStatus { iterNumber: n }) -> |
| 168 | + Just $ Milliseconds $ base * pow 3.0 (toNumber n) |
0 commit comments