Support pre-release versions for PureScript tool

src/Main.purs

@@ -5,7 +5,7 @@ import Prelude
 import Affjax (printError)
 import Affjax as AX
 import Affjax.ResponseFormat as RF
-import Control.Monad.Except.Trans (ExceptT(..), mapExceptT, runExceptT)
+import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
 import Data.Bifunctor (lmap)
 import Data.Either (Either(..))
 import Data.Foldable (traverse_)
@@ -21,7 +21,7 @@ import Setup.UpdateVersions (updateVersions)
 main :: Effect Unit
 main = runAff_ go $ runExceptT do
   versionsJson <- ExceptT $ map (lmap (error <<< printError)) $ AX.get RF.json versionsFile
-  tools <- mapExceptT liftEffect $ constructBuildPlan versionsJson.body
+  tools <- constructBuildPlan versionsJson.body
   liftEffect $ Core.info "Constructed build plan."
   traverse_ getTool tools
   liftEffect $ Core.info "Fetched tools."

src/Setup/BuildPlan.purs

@@ -2,58 +2,81 @@ module Setup.BuildPlan (constructBuildPlan, BuildPlan) where
 
 import Prelude
 
-import Control.Monad.Except.Trans (ExceptT)
+import Control.Monad.Except.Trans (ExceptT, mapExceptT)
 import Data.Argonaut.Core (Json)
 import Data.Argonaut.Decode (decodeJson, printJsonDecodeError, (.:))
 import Data.Array as Array
 import Data.Bifunctor (lmap)
 import Data.Either (Either(..))
 import Data.Foldable (fold)
 import Data.Maybe (Maybe(..))
+import Data.String (Pattern(..))
+import Data.String as String
 import Data.Traversable (traverse)
 import Data.Version (Version)
 import Data.Version as Version
-import Effect (Effect)
-import Effect.Aff (error, throwError)
+import Effect.Aff (Aff, error, throwError)
+import Effect.Aff.Class (liftAff)
 import Effect.Class (liftEffect)
 import Effect.Exception (Error)
 import GitHub.Actions.Core as Core
 import Setup.Data.Key (Key)
 import Setup.Data.Key as Key
 import Setup.Data.Tool (Tool)
 import Setup.Data.Tool as Tool
+import Setup.UpdateVersions (ReleaseType(..), fetchFromGitHubReleases)
 import Text.Parsing.Parser (parseErrorMessage)
 import Text.Parsing.Parser as ParseError
 
 -- | The list of tools that should be downloaded and cached by the action
 type BuildPlan = Array { tool :: Tool, version :: Version }
 
 -- | Construct the list of tools that sholud be downloaded and cached by the action
-constructBuildPlan :: Json -> ExceptT Error Effect BuildPlan
+constructBuildPlan :: Json -> ExceptT Error Aff BuildPlan
 constructBuildPlan json = map Array.catMaybes $ traverse (resolve json) Tool.allTools
 
 -- | The parsed value of an input field that specifies a version
-data VersionField = Latest | Exact Version
+data VersionField
+  -- | Pre-releases for versions matching the given version
+  = Unstable Version
+  -- | Lookup the latest release that is not a pre-release
+  | Latest
+  -- | Use the given version
+  | Exact Version
 
 -- | Attempt to read the value of an input specifying a tool version
-getVersionField :: Key -> ExceptT Error Effect (Maybe VersionField)
+getVersionField :: Key -> ExceptT Error Aff (Maybe VersionField)
 getVersionField key = do
-  value <- Core.getInput' (Key.toString key)
+  value <- mapExceptT liftEffect $ Core.getInput' (Key.toString key)
   case value of
     "" ->
       pure Nothing
     "latest" ->
       pure (pure Latest)
-    val -> case Version.parseVersion val of
-      Left msg -> do
-        liftEffect $ Core.error $ fold [ "Failed to parse version ", val ]
-        throwError (error (ParseError.parseErrorMessage msg))
-      Right version ->
-        pure (pure (Exact version))
+    val
+      | Just versionStr <- String.stripPrefix (Pattern "unstable-") val -> do
+          if Key.toString key /= "purescript" then do
+            liftEffect $ Core.error $
+              fold [ "Pre-release versions only work for the PureScript tool" ]
+            throwError (error $ fold [ "Could not get version for key ", Key.toString key ])
+          else case Version.parseVersion versionStr of
+            Left msg -> do
+              liftEffect $ Core.error $
+                fold [ "Failed to parse pre-release version ", versionStr ]
+              throwError (error (ParseError.parseErrorMessage msg))
+            Right v -> do
+              pure (pure (Unstable v))
+
+      | otherwise -> case Version.parseVersion val of
+          Left msg -> do
+            liftEffect $ Core.error $ fold [ "Failed to parse version ", val ]
+            throwError (error (ParseError.parseErrorMessage msg))
+          Right version ->
+            pure (pure (Exact version))
 
 -- | Resolve the exact version to provide for a tool in the environment, based
 -- | on the action.yml file.
-resolve :: Json -> Tool -> ExceptT Error Effect (Maybe { tool :: Tool, version :: Version })
+resolve :: Json -> Tool -> ExceptT Error Aff (Maybe { tool :: Tool, version :: Version })
 resolve versionsContents tool = do
   let key = Key.fromTool tool
   field <- getVersionField key
@@ -78,3 +101,9 @@ resolve versionsContents tool = do
 
         Right v -> do
           pure (pure { tool, version: v })
+
+    Just (Unstable v) -> do
+      liftEffect do
+        Core.info $ fold [ "Fetching most recent pre-release for ", Tool.name tool, "@", Version.showVersion v ]
+      version <- liftAff $ fetchFromGitHubReleases (OnlyPreReleases v) (Tool.repository tool)
+      pure (pure { tool, version })

src/Setup/UpdateVersions.purs

@@ -1,6 +1,10 @@
 -- | The source used to fetch and update the latest versions in the versions.json
 -- | file, which records the latest version of each tool.
-module Setup.UpdateVersions (updateVersions) where
+module Setup.UpdateVersions
+  ( updateVersions
+  , fetchFromGitHubReleases
+  , ReleaseType(..)
+  ) where
 
 import Prelude
 
@@ -19,7 +23,7 @@ import Data.Maybe (Maybe(..), fromMaybe, isNothing)
 import Data.String as String
 import Data.Traversable (for, traverse)
 import Data.Tuple (Tuple(..))
-import Data.Version (Version)
+import Data.Version (Version, showVersion)
 import Data.Version as Version
 import Effect (Effect)
 import Effect.Aff (Aff, Error, Milliseconds(..), delay, error, throwError)
@@ -34,6 +38,13 @@ import Node.FS.Sync (writeTextFile)
 import Node.Path (FilePath)
 import Setup.Data.Tool (Tool(..))
 import Setup.Data.Tool as Tool
+import Text.Parsing.Parser (ParseError)
+
+data ReleaseType
+  = OnlyPreReleases Version
+  | OnlyRealReleases
+
+derive instance Eq ReleaseType
 
 -- | Write the latest version of each supported tool
 updateVersions :: Aff Unit
@@ -60,115 +71,131 @@ updateVersions = do
 -- | releases, falls back to the highest valid semantic version tag for the tool.
 fetchLatestReleaseVersion :: Tool -> Aff Version
 fetchLatestReleaseVersion tool = Tool.repository tool # case tool of
-  PureScript -> fetchFromGitHubReleases
-  Spago -> fetchFromGitHubReleases
+  PureScript -> fetchFromGitHubReleases OnlyRealReleases
+  Spago -> fetchFromGitHubReleases OnlyRealReleases
   Psa -> fetchFromGitHubTags
   PursTidy -> fetchFromGitHubTags
-  Zephyr -> fetchFromGitHubReleases
-  where
-  -- TODO: These functions really ought to be in ExceptT to avoid all the
-  -- nested branches.
-  fetchFromGitHubReleases repo = recover do
-    page <- liftEffect (Ref.new 1)
-    untilJust do
-      versions <- liftEffect (Ref.read page) >>= toolVersions repo
-      case versions of
-        Just versions' -> do
-          let version = Array.find (not <<< Version.isPreRelease) versions'
-          when (isNothing version) do
-            liftEffect $ void $ Ref.modify (_ + 1) page
-          pure version
-
-        Nothing ->
-          throwError $ error "Could not find version that is not a pre-release version"
-
-  toolVersions :: Tool.ToolRepository -> Int -> Aff (Maybe (Array Version))
-  toolVersions repo page = do
-    let
-      url =
-        "https://api.github.com/repos/"
-          <> repo.owner
-          <> "/"
-          <> repo.name
-          <> "/releases?per_page=10&page="
-          <> show page
-
-    AX.get RF.json url >>= case _ of
-      Left err -> throwError (error $ AX.printError err)
-      Right { body } -> case decodeJson body of
-        Left e -> do
-          throwError $ error
-            $ fold
+  Zephyr -> fetchFromGitHubReleases OnlyRealReleases
+
+-- TODO: These functions really ought to be in ExceptT to avoid all the
+-- nested branches.
+fetchFromGitHubReleases :: ReleaseType -> Tool.ToolRepository -> Aff Version
+fetchFromGitHubReleases releaseType repo = recover do
+  page <- liftEffect (Ref.new 1)
+  let
+    releaseFilter = case releaseType of
+      OnlyRealReleases ->
+        not <<< Version.isPreRelease
+      OnlyPreReleases expectedV -> do
+        let
+          equating f a b = (f a) == (f b)
+          majorMinorMatch v = equating Version.major expectedV v && equating Version.minor expectedV v
+        majorMinorMatch && Version.isPreRelease
+  untilJust do
+    versions <- liftEffect (Ref.read page) >>= toolVersions repo
+    case versions of
+      Just versions' -> do
+        let version = Array.find releaseFilter versions'
+        when (isNothing version) do
+          liftEffect $ void $ Ref.modify (_ + 1) page
+        pure version
+
+      Nothing ->
+        case releaseType of
+          OnlyRealReleases ->
+            throwError $ error "Could not find version that is not a pre-release version"
+          OnlyPreReleases v ->
+            throwError $ error $ "Could not find a pre-release version of version, " <> showVersion v
+
+toolVersions :: Tool.ToolRepository -> Int -> Aff (Maybe (Array Version))
+toolVersions repo page = do
+  let
+    url =
+      "https://api.github.com/repos/"
+        <> repo.owner
+        <> "/"
+        <> repo.name
+        <> "/releases?per_page=10&page="
+        <> show page
+
+  AX.get RF.json url >>= case _ of
+    Left err -> throwError (error $ AX.printError err)
+    Right { body } -> case decodeJson body of
+      Left e -> do
+        throwError $ error
+          $ fold
               [ "Failed to decode GitHub response. This is most likely due to a timeout.\n\n"
               , printJsonDecodeError e
               , stringifyWithIndent 2 body
               ]
-        Right [] -> pure Nothing
-        Right objects ->
-          Just
-            <$> Array.catMaybes
-            <$> for objects \obj ->
-              case obj .: "tag_name" of
-                Left e ->
-                  throwError $ error $ fold
-                    [ "Failed to get tag from GitHub response: "
-                    , printJsonDecodeError e
-                    ]
-                Right tagName ->
-                  case tagStrToVersion tagName of
-                    Left _ -> do
-                      liftEffect $ warning $ fold
-                        [ "Got invalid version"
-                        , tagName
-                        , " from "
-                        , repo.name
+      Right [] -> pure Nothing
+      Right objects ->
+        Just
+          <$> Array.catMaybes
+          <$> for objects \obj ->
+            case obj .: "tag_name" of
+              Left e ->
+                throwError $ error $ fold
+                  [ "Failed to get tag from GitHub response: "
+                  , printJsonDecodeError e
+                  ]
+              Right tagName ->
+                case tagStrToVersion tagName of
+                  Left _ -> do
+                    liftEffect $ warning $ fold
+                      [ "Got invalid version"
+                      , tagName
+                      , " from "
+                      , repo.name
+                      ]
+                    pure Nothing
+                  Right version -> case obj .: "draft" of
+                    Left e ->
+                      throwError $ error $ fold
+                        [ "Failed to get draft from GitHub response: "
+                        , printJsonDecodeError e
                         ]
-                      pure Nothing
-                    Right version -> case obj .: "draft" of
-                      Left e ->
-                        throwError $ error $ fold
-                          [ "Failed to get draft from GitHub response: "
-                          , printJsonDecodeError e
-                          ]
-                      Right isDraft ->
-                        pure
-                          if isDraft then Nothing
-                          else Just version
-
-  tagStrToVersion tagStr =
-    tagStr
-      # String.stripPrefix (String.Pattern "v")
-      # fromMaybe tagStr
-      # Version.parseVersion
-
-  -- If a tool doesn't use GitHub releases and instead only tags versions, then
-  -- we have to fetch the tags, parse them as appropriate versions, and then sort
-  -- them according to their semantic version to get the latest one.
-  fetchFromGitHubTags repo = recover do
-    let url = "https://api.github.com/repos/" <> repo.owner <> "/" <> repo.name <> "/tags"
-
-    AX.get RF.json url >>= case _ of
-      Left err -> do
-        throwError (error $ AX.printError err)
-
-      Right { body } -> case traverse (_ .: "name") =<< decodeJson body of
-        Left e -> do
-          throwError $ error $ fold
-            [ "Failed to decode GitHub response. This is most likely due to a timeout.\n\n"
-            , printJsonDecodeError e
-            , stringifyWithIndent 2 body
-            ]
-
-        Right arr -> do
-          let
-            tags = Array.mapMaybe (tagStrToVersion >>> hush) arr
-
-          case maximum tags of
-            Nothing ->
-              throwError $ error "Could not download latest release version."
-
-            Just v ->
-              pure v
+                    Right isDraft ->
+                      pure
+                        if isDraft then Nothing
+                        else Just version
+
+tagStrToVersion :: String -> Either ParseError Version
+tagStrToVersion tagStr =
+  tagStr
+    # String.stripPrefix (String.Pattern "v")
+    # fromMaybe tagStr
+    # Version.parseVersion
+
+-- If a tool doesn't use GitHub releases and instead only tags versions, then
+-- we have to fetch the tags, parse them as appropriate versions, and then sort
+-- them according to their semantic version to get the latest one.
+fetchFromGitHubTags :: Tool.ToolRepository -> Aff Version
+fetchFromGitHubTags repo = recover do
+  let url = "https://api.github.com/repos/" <> repo.owner <> "/" <> repo.name <> "/tags"
+
+  AX.get RF.json url >>= case _ of
+    Left err -> do
+      throwError (error $ AX.printError err)
+
+    Right { body } -> case traverse (_ .: "name") =<< decodeJson body of
+      Left e -> do
+        throwError $ error $ fold
+          [ "Failed to decode GitHub response. This is most likely due to a timeout.\n\n"
+          , printJsonDecodeError e
+          , stringifyWithIndent 2 body
+          ]
+
+      Right arr -> do
+        let
+          tags = Array.mapMaybe (tagStrToVersion >>> hush) arr
+
+        case maximum tags of
+          Nothing ->
+            throwError $ error "Could not download latest release version."
+
+          Just v ->
+            pure v
 
 -- Attempt to recover from a failed request by re-attempting according to an
 -- exponential backoff strategy.