Merge branch 'master' into trh/s3

app/fixtures/github-packages/type-equality-4.0.1/LICENSE

@@ -0,0 +1,26 @@
+Copyright 2018 PureScript
+
+Redistribution and use in source and binary forms, with or without modification,
+are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the documentation and/or
+other materials provided with the distribution.
+
+3. Neither the name of the copyright holder nor the names of its contributors
+may be used to endorse or promote products derived from this software without
+specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

app/fixtures/github-packages/type-equality-4.0.1/bower.json

@@ -0,0 +1,22 @@
+{
+  "name": "purescript-type-equality",
+  "homepage": "https://github.com/purescript/purescript-type-equality",
+  "license": "BSD-3-Clause",
+  "repository": {
+    "type": "git",
+    "url": "https://github.com/purescript/purescript-type-equality.git"
+  },
+  "ignore": [
+    "**/.*",
+    "bower_components",
+    "node_modules",
+    "output",
+    "test",
+    "bower.json",
+    "package.json"
+  ],
+  "devDependencies": {
+    "purescript-console": "^6.0.0",
+    "purescript-newtype": "^5.0.0"
+  }
+}

app/fixtures/github-packages/type-equality-4.0.1/src/Type/Equality.purs

@@ -0,0 +1,35 @@
+module Type.Equality
+  ( class TypeEquals
+  , proof
+  , to
+  , from
+  ) where
+
+import Prim.Coerce (class Coercible)
+
+-- | This type class asserts that types `a` and `b`
+-- | are equal.
+-- |
+-- | The functional dependencies and the single
+-- | instance below will force the two type arguments
+-- | to unify when either one is known.
+-- |
+-- | Note: any instance will necessarily overlap with
+-- | `refl` below, so instances of this class should
+-- | not be defined in libraries.
+class TypeEquals :: forall k. k -> k -> Constraint
+class Coercible a b <= TypeEquals a b | a -> b, b -> a where
+  proof :: forall p. p a -> p b
+
+instance refl :: TypeEquals a a where
+  proof a = a
+
+newtype To a b = To (a -> b)
+
+to :: forall a b. TypeEquals a b => a -> b
+to = case proof (To (\a -> a)) of To f -> f
+
+newtype From a b = From (b -> a)
+
+from :: forall a b. TypeEquals a b => b -> a
+from = case proof (From (\a -> a)) of From f -> f

app/src/App/Server.purs

@@ -10,7 +10,7 @@ import Data.String as String
 import Data.UUID.Random as UUID
 import Effect.Aff as Aff
 import Effect.Class.Console as Console
-import Fetch as Fetch
+import Fetch.Retry as Fetch.Retry
 import HTTPurple (JsonDecoder(..), JsonEncoder(..), Method(..), Request, Response)
 import HTTPurple as HTTPurple
 import HTTPurple.Status as Status
@@ -234,15 +234,41 @@ main = do
     Right env -> do
       _healthcheck <- Aff.launchAff do
         let
-          loop =
-            Aff.attempt (Fetch.fetch env.vars.resourceEnv.healthchecksUrl {}) >>=
-              case _ of
-                Left _ -> pure unit
-                Right { status } | status /= 200 -> pure unit
-                Right _ -> do
-                  Aff.delay (Aff.Milliseconds (1000.0 * 60.0 * 5.0))
-                  loop
-        loop
+          limit = 10
+          oneMinute = Aff.Milliseconds (1000.0 * 60.0)
+          fiveMinutes = Aff.Milliseconds (1000.0 * 60.0 * 5.0)
+
+          loop n =
+            Fetch.Retry.withRetryRequest env.vars.resourceEnv.healthchecksUrl {} >>= case _ of
+              Succeeded { status } | status == 200 -> do
+                Aff.delay fiveMinutes
+                loop n
+
+              Cancelled | n >= 0 -> do
+                Console.warn $ "Healthchecks cancelled, will retry..."
+                Aff.delay oneMinute
+                loop (n - 1)
+
+              Failed error | n >= 0 -> do
+                Console.warn $ "Healthchecks failed, will retry: " <> Fetch.Retry.printRetryRequestError error
+                Aff.delay oneMinute
+                loop (n - 1)
+
+              Succeeded { status } | status /= 200, n >= 0 -> do
+                Console.error $ "Healthchecks returned non-200 status, will retry: " <> show status
+                Aff.delay oneMinute
+                loop (n - 1)
+
+              Cancelled ->
+                Console.error "Healthchecks cancelled and failure limit reached, will not retry."
+
+              Failed error -> do
+                Console.error $ "Healthchecks failed and failure limit reached, will not retry: " <> Fetch.Retry.printRetryRequestError error
+
+              Succeeded _ -> do
+                Console.error $ "Healthchecks returned non-200 status and failure limit reached, will not retry."
+
+        loop limit
 
       _close <- HTTPurple.serve
         { hostname: "0.0.0.0"

app/src/Fetch/Retry.purs

@@ -1,7 +1,8 @@
 module Fetch.Retry
-  ( withRetryRequest
-  , RetryRequestError(..)
+  ( RetryRequestError(..)
   , module ReExport
+  , printRetryRequestError
+  , withRetryRequest
   ) where
 
 import Registry.App.Prelude
@@ -21,6 +22,11 @@ data RetryRequestError
   = FetchError Error
   | StatusError Response
 
+printRetryRequestError :: RetryRequestError -> String
+printRetryRequestError = case _ of
+  FetchError error -> "Fetch Error: " <> Aff.message error
+  StatusError response -> "Status Error (" <> show response.status <> "): " <> response.statusText
+
 withRetryRequest
   :: forall input output thruIn thruOut headers body
    . Union input thruIn (HighlevelRequestOptions headers body)
@@ -29,14 +35,8 @@ withRetryRequest
   => String
   -> { | input }
   -> Aff (RetryResult RetryRequestError Response)
-withRetryRequest url r =
-  withRetry retry
-    $ (Aff.attempt $ fetch @thruIn url r)
-    <#>
-      ( either
-          (Left <<< FetchError)
-          onFetchResponse
-      )
+withRetryRequest url opts = withRetry retry do
+  (Aff.attempt $ fetch @thruIn url opts) <#> either (Left <<< FetchError) onFetchResponse
   where
   onFetchResponse :: Response -> Either RetryRequestError Response
   onFetchResponse response =

app/test/App/API.purs

@@ -70,7 +70,17 @@ spec = do
 
   Spec.describe "API pipelines run correctly" $ Spec.around withCleanEnv do
     Spec.it "Publish a legacy-converted package with unused deps" \{ workdir, index, metadata, storageDir, githubDir } -> do
-      let testEnv = { workdir, index, metadata, username: "jon", storage: storageDir, github: githubDir }
+      let
+        testEnv =
+          { workdir
+          , index
+          , metadata
+          , pursuitExcludes: Set.singleton (Utils.unsafePackageName "type-equality")
+          , username: "jon"
+          , storage: storageDir
+          , github: githubDir
+          }
+
       Assert.Run.runTestEffects testEnv do
         -- We'll publish [email protected] from the fixtures/github-packages
         -- directory, which has an unnecessary dependency on 'type-equality'
@@ -123,6 +133,19 @@ spec = do
           Left _ -> pure unit
           Right _ -> Except.throw $ "Expected publishing " <> formatPackageVersion name version <> " twice to fail."
 
+        -- If we got here then the new published package is fine. There is one
+        -- other successful code path: publishing a package that already exists
+        -- but did not have documentation make it to Pursuit.
+        let
+          pursuitOnlyPublishArgs =
+            { compiler: Utils.unsafeVersion "0.15.9"
+            , location: Just $ GitHub { owner: "purescript", repo: "purescript-type-equality", subdir: Nothing }
+            , name: Utils.unsafePackageName "type-equality"
+            , ref: "v4.0.1"
+            , resolutions: Nothing
+            }
+        API.publish CurrentPackage pursuitOnlyPublishArgs
+
   where
   withCleanEnv :: (PipelineEnv -> Aff Unit) -> Aff Unit
   withCleanEnv action = do

app/test/Test/Assert/Run.purs

@@ -95,6 +95,7 @@ type TestEnv =
   { workdir :: FilePath
   , metadata :: Ref (Map PackageName Metadata)
   , index :: Ref ManifestIndex
+  , pursuitExcludes :: Set PackageName
   , storage :: FilePath
   , github :: FilePath
   , username :: String
@@ -106,7 +107,7 @@ runTestEffects env operation = do
   githubCache <- liftEffect Cache.newCacheRef
   legacyCache <- liftEffect Cache.newCacheRef
   operation
-    # Pursuit.interpret (handlePursuitMock env.metadata)
+    # Pursuit.interpret (handlePursuitMock { metadataRef: env.metadata, excludes: env.pursuitExcludes })
     # Registry.interpret (handleRegistryMock { metadataRef: env.metadata, indexRef: env.index })
     # PackageSets.interpret handlePackageSetsMock
     # Storage.interpret (handleStorageMock { storage: env.storage })
@@ -140,10 +141,25 @@ runLegacyCacheMemory = Cache.interpret Legacy.Manifest._legacyCache <<< Cache.ha
 runGitHubCacheMemory :: forall r a. CacheRef -> Run (GITHUB_CACHE + LOG + EFFECT + r) a -> Run (LOG + EFFECT + r) a
 runGitHubCacheMemory = Cache.interpret GitHub._githubCache <<< Cache.handleMemory
 
-handlePursuitMock :: forall r a. Ref (Map PackageName Metadata) -> Pursuit a -> Run (EFFECT + r) a
-handlePursuitMock metadataRef = case _ of
+type PursuitMockEnv =
+  { excludes :: Set PackageName
+  , metadataRef :: Ref (Map PackageName Metadata)
+  }
+
+-- | A mock implementation for Pursuit, which assumes a shared metadata ref with
+-- | the REGISTRY effect handler. All packages present in the metadata ref are
+-- | considered published, so 'Publish' is a no-op and 'GetPublishedVersions'
+-- | reads the metadata ref.
+-- |
+-- | The is 'excludes' option allows us to manually choose packages that should
+-- | NOT have their docs "published", so that we can test things like retrying
+-- | the publish pipeline for Pursuit publishing only.
+handlePursuitMock :: forall r a. PursuitMockEnv -> Pursuit a -> Run (EFFECT + r) a
+handlePursuitMock { excludes, metadataRef } = case _ of
   Publish _json reply ->
     pure $ reply $ Right unit
+  GetPublishedVersions name reply | Set.member name excludes ->
+    pure $ reply $ Right Map.empty
   GetPublishedVersions name reply -> do
     metadata <- Run.liftEffect (Ref.read metadataRef)
     pure $ reply $ Right $ fromMaybe Map.empty do