From 6b7dc4be8b571b48ac57f30fbc6c97b8ffc4de93 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Tue, 6 Aug 2019 13:28:52 +0300 Subject: [PATCH 01/11] Tweak some logging --- src/Spago/FetchPackage.hs | 2 +- src/Spago/Messages.hs | 1 + src/Spago/Watch.hs | 14 +++++++------- 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Spago/FetchPackage.hs b/src/Spago/FetchPackage.hs index fb6b613a2..4afcbd36d 100644 --- a/src/Spago/FetchPackage.hs +++ b/src/Spago/FetchPackage.hs @@ -125,7 +125,7 @@ fetchPackage metadata pair@(packageName'@PackageName{..}, Package{ location = Re assertDirectory resultDir2 cptree resultDir resultDir2 catch (mv resultDir packageGlobalCacheDir) $ \(err :: SomeException) -> - echo $ Messages.failedToCopyToGlobalCache err + echoDebug $ Messages.failedToCopyToGlobalCache err mv resultDir2 packageLocalCacheDir -- * if not, run a series of git commands to get the code, and move it to local cache diff --git a/src/Spago/Messages.hs b/src/Spago/Messages.hs index 0f388ccac..3973313d3 100644 --- a/src/Spago/Messages.hs +++ b/src/Spago/Messages.hs @@ -44,6 +44,7 @@ failedToParseRepoString repo = makeMessage , "" , "- you're trying to use a URL which doesn't conform to RFC 3986, e.g. in the form of `git@foo.com:bar/baz.git`." , " The above example can be rewritten in a valid form as \"ssh://git@foo.com/bar/baz.git\"" + , "" ] cannotFindConfig :: Text diff --git a/src/Spago/Watch.hs b/src/Spago/Watch.hs index 3850aae27..27e91b574 100644 --- a/src/Spago/Watch.hs +++ b/src/Spago/Watch.hs @@ -25,7 +25,7 @@ data ClearScreen = DoClear | NoClear watch :: Spago m => Set.Set Glob.Pattern -> ClearScreen -> m () -> m () watch globs shouldClear action = do - let config = Watch.defaultConfig { Watch.confDebounce = Watch.Debounce 0.1 } -- in seconds + let config = Watch.defaultConfig { Watch.confDebounce = Watch.Debounce 1 } fileWatchConf config shouldClear $ \getGlobs -> do getGlobs globs action @@ -56,14 +56,14 @@ fileWatchConf watchConfig shouldClear inner = withManagerConf watchConfig $ \man mapM_ echoStr maybeMsg let onChange event = do - globsUnsafe <- liftIO $ readTVarIO allGlobs - let shouldRebuild globs = or $ fmap (\glob -> Glob.match glob $ Watch.eventPath event) $ Set.toList globs - when (shouldRebuild globsUnsafe) $ do - redisplay $ Just $ "File changed, rebuilding: " <> show (Watch.eventPath event) - liftIO $ atomically $ do + rebuilding <- liftIO $ atomically $ do globs <- readTVar allGlobs - when (shouldRebuild globs) + let shouldRebuild = or $ fmap (\glob -> Glob.match glob $ Watch.eventPath event) $ Set.toList globs + when shouldRebuild (writeTVar dirtyVar True) + pure shouldRebuild + when rebuilding $ do + redisplay $ Just $ "File changed, triggered a build: " <> show (Watch.eventPath event) setWatched :: Spago m => Set.Set Glob.Pattern -> m () setWatched globs = do From 8154deaec9a1376b215aa56a10fe2f64a268b55e Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Thu, 8 Aug 2019 22:31:03 +0300 Subject: [PATCH 02/11] Retry fetching from GitHub if it fails --- package.yaml | 1 + src/Spago/PackageSet.hs | 5 +++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index f96f2e713..17a982a67 100644 --- a/package.yaml +++ b/package.yaml @@ -83,6 +83,7 @@ library: - semver-range - ansi-terminal - unordered-containers + - retry executables: spago: diff --git a/src/Spago/PackageSet.hs b/src/Spago/PackageSet.hs index c842b0fd7..1a621fa64 100644 --- a/src/Spago/PackageSet.hs +++ b/src/Spago/PackageSet.hs @@ -14,6 +14,7 @@ module Spago.PackageSet import Spago.Prelude +import qualified Control.Retry as Retry import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Versions as Version @@ -21,8 +22,8 @@ import qualified Dhall import Dhall.Binary (defaultStandardVersion) import qualified Dhall.Freeze import qualified Dhall.Pretty -import qualified Network.HTTP.Simple as Http import qualified Network.HTTP.Client as Http +import qualified Network.HTTP.Simple as Http import Network.URI (parseURI) import qualified Spago.Dhall as Dhall @@ -113,7 +114,7 @@ makePackageSetFile force = do upgradePackageSet :: Spago m => m () upgradePackageSet = do echoDebug "Running `spago upgrade-set`" - try getLatestRelease >>= \case + try (Retry.recoverAll (Retry.fullJitterBackoff 50000 <> Retry.limitRetries 5) $ \_ -> getLatestRelease) >>= \case Left (err :: SomeException) -> echoDebug $ Messages.failedToReachGitHub err Right releaseTagName -> do let quotedTag = surroundQuote releaseTagName From bf03c3dafe1eb6acec80512bd0b0a07937a70042 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Thu, 8 Aug 2019 22:33:05 +0300 Subject: [PATCH 03/11] Tweak appveyor config to try to improve the caching time --- appveyor.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/appveyor.yml b/appveyor.yml index bed65706d..af1f130bb 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -30,8 +30,8 @@ install: - chmod a+x purescript cache: - - C:\sr -> '%STACK_YAML%' - - .stack-work -> '%STACK_YAML%' + - '%STACK_ROOT% -> %STACK_YAML%, appveyor.yml' + - '.stack-work -> %STACK_YAML%, appveyor.yml' build_script: - stack build From 99cc7fd7d53c51e219d7305f212da74c90a22858 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Thu, 8 Aug 2019 22:56:28 +0300 Subject: [PATCH 04/11] Have travis print errors --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index ea2e42314..9da046f4c 100644 --- a/.travis.yml +++ b/.travis.yml @@ -83,7 +83,7 @@ script: - | echo "Running tests" export PATH="${PATH}:$(pwd)/artifacts" - set -e + # set -e if [ `uname` = "Darwin" ] then stack build --test --no-run-tests --copy-bins --local-bin-path ./artifacts; From 19f99ad8c04ff7d86282ddb43d23162110bab9f5 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Thu, 8 Aug 2019 22:59:45 +0300 Subject: [PATCH 05/11] Disable psa tests on travis --- .travis.yml | 5 ----- 1 file changed, 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 9da046f4c..8ed485a86 100644 --- a/.travis.yml +++ b/.travis.yml @@ -83,7 +83,6 @@ script: - | echo "Running tests" export PATH="${PATH}:$(pwd)/artifacts" - # set -e if [ `uname` = "Darwin" ] then stack build --test --no-run-tests --copy-bins --local-bin-path ./artifacts; @@ -105,10 +104,6 @@ script: # run the test suite executable ./.stack-work/dist/*/*/build/spec/spec - - # install psa and rerun tests that exercise it - npm install -g purescript-psa - ./.stack-work/dist/*/*/build/spec/spec --match "/Spago/spago run" before_deploy: From 1badc09a3905f8b224b51773a7b703be2dbc31e7 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Thu, 8 Aug 2019 23:21:14 +0300 Subject: [PATCH 06/11] Add some debug logs --- test/SpagoSpec.hs | 2 +- test/Utils.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/test/SpagoSpec.hs b/test/SpagoSpec.hs index 4540b6e6f..a15c741f5 100644 --- a/test/SpagoSpec.hs +++ b/test/SpagoSpec.hs @@ -233,7 +233,7 @@ spec = around_ setup $ do $ filter (not . null . Text.breakOnAll "https://github.com/purescript/package-sets") $ Text.lines packages writeTextFile "packages.dhall" "https://raw.githubusercontent.com/purescript/package-sets/psc-0.13.0-20190713/src/packages.dhall sha256:906af79ba3aec7f429b107fd8d12e8a29426db8229d228c6f992b58151e2308e" - spago ["upgrade-set"] >>= shouldBeSuccess + spago ["-v", "upgrade-set"] >>= shouldBeSuccess newPackages <- fmap Text.strip $ readTextFile "packages.dhall" newPackages `shouldBe` packageSetUrl diff --git a/test/Utils.hs b/test/Utils.hs index 4bbbbd01e..1c458f167 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -50,8 +50,8 @@ runFor us cmd args = do shouldBeSuccess :: HasCallStack => (ExitCode, Text, Text) -> IO () shouldBeSuccess result@(_code, _stdout, _stderr) = do - -- print $ "STDOUT: " <> _stdout - -- print $ "STDERR: " <> _stderr + print $ "STDOUT: " <> _stdout + print $ "STDERR: " <> _stderr result `shouldSatisfy` (\(code, _, _) -> code == ExitSuccess) shouldBeSuccessOutput :: HasCallStack => FilePath -> (ExitCode, Text, Text) -> IO () From 3eebc9d5a900fb9d897d1fd61740ed8638d0c4f3 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Fri, 9 Aug 2019 10:24:00 +0300 Subject: [PATCH 07/11] Restore debounce time --- src/Spago/Watch.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Spago/Watch.hs b/src/Spago/Watch.hs index 27e91b574..7554c2000 100644 --- a/src/Spago/Watch.hs +++ b/src/Spago/Watch.hs @@ -25,7 +25,7 @@ data ClearScreen = DoClear | NoClear watch :: Spago m => Set.Set Glob.Pattern -> ClearScreen -> m () -> m () watch globs shouldClear action = do - let config = Watch.defaultConfig { Watch.confDebounce = Watch.Debounce 1 } + let config = Watch.defaultConfig { Watch.confDebounce = Watch.Debounce 0.1 } fileWatchConf config shouldClear $ \getGlobs -> do getGlobs globs action From 8afec76936066a479e894e8586285076aa647a0c Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Sun, 11 Aug 2019 19:23:23 +0300 Subject: [PATCH 08/11] Fallback on old github API call --- package.yaml | 1 + src/Spago/PackageSet.hs | 17 +++++++++++++---- 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/package.yaml b/package.yaml index 17a982a67..4e48f118f 100644 --- a/package.yaml +++ b/package.yaml @@ -84,6 +84,7 @@ library: - ansi-terminal - unordered-containers - retry + - github executables: spago: diff --git a/src/Spago/PackageSet.hs b/src/Spago/PackageSet.hs index 1a621fa64..be97b1fe6 100644 --- a/src/Spago/PackageSet.hs +++ b/src/Spago/PackageSet.hs @@ -25,6 +25,7 @@ import qualified Dhall.Pretty import qualified Network.HTTP.Client as Http import qualified Network.HTTP.Simple as Http import Network.URI (parseURI) +import qualified GitHub import qualified Spago.Dhall as Dhall import Spago.Messages as Messages @@ -114,7 +115,7 @@ makePackageSetFile force = do upgradePackageSet :: Spago m => m () upgradePackageSet = do echoDebug "Running `spago upgrade-set`" - try (Retry.recoverAll (Retry.fullJitterBackoff 50000 <> Retry.limitRetries 5) $ \_ -> getLatestRelease) >>= \case + try (Retry.recoverAll (Retry.fullJitterBackoff 50000 <> Retry.limitRetries 5) $ \_ -> getLatestRelease1 <|> getLatestRelease2) >>= \case Left (err :: SomeException) -> echoDebug $ Messages.failedToReachGitHub err Right releaseTagName -> do let quotedTag = surroundQuote releaseTagName @@ -139,14 +140,22 @@ upgradePackageSet = do -- to the latest release. So we search for the `Location` header which should contain -- the URL we get redirected to, and strip the release name from there (it's the -- last segment of the URL) - getLatestRelease :: Spago m => m Text - getLatestRelease = do + getLatestRelease1 :: Spago m => m Text + getLatestRelease1 = do request <- Http.parseRequest "https://github.com/purescript/package-sets/releases/latest" - response <- Http.httpBS $ request { Http.redirectCount = 0 } + response <- Http.httpBS + $ Http.addRequestHeader "User-Agent" "Mozilla/5.0" + $ request { Http.redirectCount = 0 } redirectUrl <- (\case [u] -> pure u; _ -> error ("Error following GitHub redirect, response:\n\n" <> show response)) $ Http.getResponseHeader "Location" response pure $ last $ Text.splitOn "/" $ Text.decodeUtf8 redirectUrl + getLatestRelease2 :: Spago m => m Text + getLatestRelease2 = do + result <- liftIO $ GitHub.executeRequest' $ GitHub.latestReleaseR "purescript" "package-sets" + GitHub.Release{..} <- throws result + pure releaseTagName + getCurrentTag :: Dhall.Import -> [Text] getCurrentTag Dhall.Import { importHashed = Dhall.ImportHashed From 69710a130aec61de87235d8414fbe39973dcb1ea Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Sun, 11 Aug 2019 19:32:26 +0300 Subject: [PATCH 09/11] Remove verbosity from tests --- test/Utils.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/Utils.hs b/test/Utils.hs index 1c458f167..4bbbbd01e 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -50,8 +50,8 @@ runFor us cmd args = do shouldBeSuccess :: HasCallStack => (ExitCode, Text, Text) -> IO () shouldBeSuccess result@(_code, _stdout, _stderr) = do - print $ "STDOUT: " <> _stdout - print $ "STDERR: " <> _stderr + -- print $ "STDOUT: " <> _stdout + -- print $ "STDERR: " <> _stderr result `shouldSatisfy` (\(code, _, _) -> code == ExitSuccess) shouldBeSuccessOutput :: HasCallStack => FilePath -> (ExitCode, Text, Text) -> IO () From 8e181d5293b2f2e2a0e06bf51d473fd76d2591a5 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Mon, 12 Aug 2019 23:51:09 +0300 Subject: [PATCH 10/11] Oh, so the problem was that call to error going unnoticed --- src/Spago/PackageSet.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Spago/PackageSet.hs b/src/Spago/PackageSet.hs index be97b1fe6..62e24391b 100644 --- a/src/Spago/PackageSet.hs +++ b/src/Spago/PackageSet.hs @@ -146,15 +146,18 @@ upgradePackageSet = do response <- Http.httpBS $ Http.addRequestHeader "User-Agent" "Mozilla/5.0" $ request { Http.redirectCount = 0 } - redirectUrl <- (\case [u] -> pure u; _ -> error ("Error following GitHub redirect, response:\n\n" <> show response)) - $ Http.getResponseHeader "Location" response - pure $ last $ Text.splitOn "/" $ Text.decodeUtf8 redirectUrl + case Http.getResponseHeader "Location" response of + [redirectUrl] -> return $ last $ Text.splitOn "/" $ Text.decodeUtf8 redirectUrl + _ -> do + echoStr $ "Error following GitHub redirect, response:\n\n" <> show response + empty getLatestRelease2 :: Spago m => m Text getLatestRelease2 = do result <- liftIO $ GitHub.executeRequest' $ GitHub.latestReleaseR "purescript" "package-sets" - GitHub.Release{..} <- throws result - pure releaseTagName + case result of + Right GitHub.Release{..} -> return releaseTagName + Left _ -> empty getCurrentTag :: Dhall.Import -> [Text] getCurrentTag Dhall.Import From bf335fd86a9b0f5e8a1a83499a4e620de08e4eea Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Tue, 13 Aug 2019 00:01:40 +0300 Subject: [PATCH 11/11] Restore the watch file --- src/Spago/Watch.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Spago/Watch.hs b/src/Spago/Watch.hs index 7554c2000..3850aae27 100644 --- a/src/Spago/Watch.hs +++ b/src/Spago/Watch.hs @@ -25,7 +25,7 @@ data ClearScreen = DoClear | NoClear watch :: Spago m => Set.Set Glob.Pattern -> ClearScreen -> m () -> m () watch globs shouldClear action = do - let config = Watch.defaultConfig { Watch.confDebounce = Watch.Debounce 0.1 } + let config = Watch.defaultConfig { Watch.confDebounce = Watch.Debounce 0.1 } -- in seconds fileWatchConf config shouldClear $ \getGlobs -> do getGlobs globs action @@ -56,14 +56,14 @@ fileWatchConf watchConfig shouldClear inner = withManagerConf watchConfig $ \man mapM_ echoStr maybeMsg let onChange event = do - rebuilding <- liftIO $ atomically $ do + globsUnsafe <- liftIO $ readTVarIO allGlobs + let shouldRebuild globs = or $ fmap (\glob -> Glob.match glob $ Watch.eventPath event) $ Set.toList globs + when (shouldRebuild globsUnsafe) $ do + redisplay $ Just $ "File changed, rebuilding: " <> show (Watch.eventPath event) + liftIO $ atomically $ do globs <- readTVar allGlobs - let shouldRebuild = or $ fmap (\glob -> Glob.match glob $ Watch.eventPath event) $ Set.toList globs - when shouldRebuild + when (shouldRebuild globs) (writeTVar dirtyVar True) - pure shouldRebuild - when rebuilding $ do - redisplay $ Just $ "File changed, triggered a build: " <> show (Watch.eventPath event) setWatched :: Spago m => Set.Set Glob.Pattern -> m () setWatched globs = do