diff --git a/app/Curator.hs b/app/Curator.hs index 8d97d28f7..33ea68bb8 100644 --- a/app/Curator.hs +++ b/app/Curator.hs @@ -185,13 +185,13 @@ main = withBinaryFile "curator.log" AppendMode $ \configHandle -> do getLatestRelease :: GitHub.AuthMethod am => am -> GitHubAddress -> Curator (Either GitHub.Error GitHub.Release) getLatestRelease token address@(Address owner repo) = do logInfo $ "Getting latest release for " <> displayShow address - liftIO $ GitHub.executeRequest token $ GitHub.latestReleaseR owner repo + liftIO $ GitHub.github token $ GitHub.latestReleaseR owner repo getTags :: GitHub.AuthMethod am => am -> GitHubAddress -> Curator (Either GitHub.Error (Maybe Tag, (Map Tag CommitHash))) getTags token address@(Address owner repo) = do logInfo $ "Getting tags for " <> displayShow address - res <- liftIO $ GitHub.executeRequest token $ GitHub.tagsForR owner repo GitHub.FetchAll + res <- liftIO $ GitHub.github token $ GitHub.tagsForR owner repo GitHub.FetchAll let f vec = ( (Tag . GitHub.tagName) <$> vec Vector.!? 0 , Map.fromList @@ -208,18 +208,18 @@ getTags token address@(Address owner repo) = do getCommits :: GitHub.AuthMethod am => am -> GitHubAddress -> Curator (Either GitHub.Error [CommitHash]) getCommits token address@(Address owner repo) = do logInfo $ "Getting commits for " <> displayShow address - res <- liftIO $ GitHub.executeRequest token $ GitHub.commitsForR owner repo GitHub.FetchAll + res <- liftIO $ GitHub.github token $ GitHub.commitsForR owner repo GitHub.FetchAll pure $ fmap (Vector.toList . fmap (CommitHash . GitHub.untagName . GitHub.commitSha)) res getPullRequestForUser :: GitHub.AuthMethod am => am -> GitHub.Name GitHub.User -> GitHubAddress -> IO (Maybe GitHub.PullRequest) getPullRequestForUser token user Address{..} = do - maybePRs <- fmap hush $ GitHub.executeRequest token + maybePRs <- fmap hush $ GitHub.github token $ GitHub.pullRequestsForR owner repo GitHub.stateOpen GitHub.FetchAll let findPRbyUser = Vector.find (\GitHub.SimplePullRequest{ simplePullRequestUser = GitHub.SimpleUser{..}} -> simpleUserLogin == user) - let fetchFullPR GitHub.SimplePullRequest{..} = fmap hush $ GitHub.executeRequest token $ GitHub.pullRequestR owner repo simplePullRequestNumber + let fetchFullPR GitHub.SimplePullRequest{..} = fmap hush $ GitHub.github token $ GitHub.pullRequestR owner repo simplePullRequestNumber -- TODO: there must be a nice way to lift this instead of casing case (findPRbyUser =<< maybePRs :: Maybe GitHub.SimplePullRequest) of Nothing -> pure Nothing @@ -228,8 +228,7 @@ getPullRequestForUser token user Address{..} = do getCommentsOnPR :: GitHub.AuthMethod am => am -> GitHubAddress -> GitHub.IssueNumber -> IO [GitHub.IssueComment] getCommentsOnPR token Address{..} issueNumber = do - eitherComments <- GitHub.executeRequest token - $ GitHub.commentsR owner repo issueNumber GitHub.FetchAll + eitherComments <- GitHub.github token $ GitHub.commentsR owner repo issueNumber GitHub.FetchAll pure $ case eitherComments of Left _ -> [] Right comments -> Vector.toList comments @@ -238,7 +237,7 @@ getCommentsOnPR token Address{..} issueNumber = do updatePullRequestBody :: GitHub.AuthMethod am => am -> GitHubAddress -> GitHub.IssueNumber -> Text -> IO () updatePullRequestBody token Address{..} pullRequestNumber newBody = do void - $ GitHub.executeRequest token + $ GitHub.github token $ GitHub.updatePullRequestR owner repo pullRequestNumber $ GitHub.EditPullRequest Nothing (Just newBody) Nothing Nothing Nothing @@ -269,7 +268,7 @@ persistState = \case -- When there's a new one and we don't have it in our state we send a message on the bus checkLatestRelease :: GitHub.Auth -> GitHubAddress -> Message -> Curator () checkLatestRelease token address RefreshState = getLatestRelease token address >>= \case - Left _ -> pure () -- TODO: error out here? + Left err -> logWarn $ "Could not check the latest release for " <> displayShow address <> ". Error: " <> displayShow err Right GitHub.Release {..} -> do State{..} <- liftIO $ Concurrent.readMVar state case Map.lookup address latestReleases of @@ -434,7 +433,7 @@ packageSetCommenter token (NewVerification result) = do , "

" ] let (Address owner repo) = packageSetsRepo - (liftIO $ GitHub.executeRequest token $ GitHub.createCommentR owner repo pullRequestNumber commentBody) >>= \case + (liftIO $ GitHub.github token $ GitHub.createCommentR owner repo pullRequestNumber commentBody) >>= \case Left err -> logError $ "Something went wrong while commenting. Error: " <> displayShow err Right _ -> logInfo "Commented on the open PR" packageSetCommenter _ _ = pure () @@ -632,7 +631,7 @@ runAndOpenPR token PullRequest{ prAddress = address@Address{..}, ..} preAction c openPR :: Curator () openPR = do logInfo "Pushed a new commit, opening PR.." - response <- liftIO $ GitHub.executeRequest token + response <- liftIO $ GitHub.github token $ GitHub.createPullRequestR owner repo $ GitHub.CreatePullRequest prTitle prBody prBranchName "master" case response of @@ -644,7 +643,7 @@ runAndOpenPR token PullRequest{ prAddress = address@Address{..}, ..} preAction c logInfo $ "Checking if we ever opened a PR " <> displayShow prTitle oldPRs <- liftIO - $ GitHub.executeRequest token + $ GitHub.github token $ GitHub.pullRequestsForR owner repo (GitHub.optionsHead (GitHub.untagName owner <> ":" <> prBranchName) <> GitHub.stateAll) GitHub.FetchAll diff --git a/package.yaml b/package.yaml index 6106a7921..e904d3ac1 100644 --- a/package.yaml +++ b/package.yaml @@ -56,7 +56,7 @@ library: - bytestring - Cabal - containers - - dhall + - dhall >= 1.29.0 - directory >= 1.3.4.0 - either - exceptions diff --git a/src/Spago/Config.hs b/src/Spago/Config.hs index b2c79ebc0..9c01a90da 100644 --- a/src/Spago/Config.hs +++ b/src/Spago/Config.hs @@ -72,13 +72,13 @@ isLocationType (Dhall.Union kvs) | locationUnionMap == Dhall.Map.toMap kvs = Tru isLocationType _ = False -dependenciesType :: Dhall.Type [PackageName] -dependenciesType = Dhall.list (Dhall.auto :: Dhall.Type PackageName) +dependenciesType :: Dhall.Decoder [PackageName] +dependenciesType = Dhall.list (Dhall.auto :: Dhall.Decoder PackageName) parsePackage :: (MonadIO m, MonadThrow m, MonadReader env m, HasLogFunc env) => ResolvedExpr -> m Package parsePackage (Dhall.RecordLit ks) = do - repo <- Dhall.requireTypedKey ks "repo" (Dhall.auto :: Dhall.Type PackageSet.Repo) + repo <- Dhall.requireTypedKey ks "repo" (Dhall.auto :: Dhall.Decoder PackageSet.Repo) version <- Dhall.requireTypedKey ks "version" Dhall.strictText dependencies <- Dhall.requireTypedKey ks "dependencies" dependenciesType let location = PackageSet.Remote{..} @@ -130,7 +130,7 @@ parseConfig = do expr <- liftIO $ Dhall.inputExpr $ "./" <> path case expr of Dhall.RecordLit ks -> do - let sourcesType = Dhall.list (Dhall.auto :: Dhall.Type Purs.SourcePath) + let sourcesType = Dhall.list (Dhall.auto :: Dhall.Decoder Purs.SourcePath) name <- Dhall.requireTypedKey ks "name" Dhall.strictText dependencies <- Dhall.requireTypedKey ks "dependencies" dependenciesType configSourcePaths <- Dhall.requireTypedKey ks "sources" sourcesType diff --git a/src/Spago/Dhall.hs b/src/Spago/Dhall.hs index 101e346cb..9da251d93 100644 --- a/src/Spago/Dhall.hs +++ b/src/Spago/Dhall.hs @@ -11,7 +11,7 @@ import qualified Data.Text as Text import qualified Data.Text.Prettyprint.Doc as Pretty import qualified Data.Text.Prettyprint.Doc.Render.Text as PrettyText import Dhall -import Dhall.Core as Dhall hiding (Type, pretty) +import Dhall.Core as Dhall hiding (pretty) import qualified Dhall.Format import qualified Dhall.Import import qualified Dhall.Map @@ -30,7 +30,8 @@ type DhallExpr a = Dhall.Expr Parser.Src a format :: MonadIO m => Text -> m () format pathText = liftIO $ try (f $ Dhall.Format.Check path) >>= \case - Left (_e :: SomeException) -> f $ Dhall.Format.Modify path + Left (_e :: SomeException) -> + f $ Dhall.Format.Modify path Right _ -> pure () where f = Dhall.Format.format . Dhall.Format.Format Dhall.Pretty.ASCII Dhall.NoCensor @@ -38,8 +39,8 @@ format pathText = liftIO $ -- | Prettyprint a Dhall expression adding a comment on top -prettyWithHeader :: Pretty.Pretty a => Text -> DhallExpr a -> Dhall.Text -prettyWithHeader header expr = do +prettyWithHeader :: Pretty.Pretty a => Dhall.Header -> DhallExpr a -> Dhall.Text +prettyWithHeader (Header header) expr = do let doc = Pretty.pretty header <> Pretty.pretty expr PrettyText.renderStrict $ Pretty.layoutSmart Pretty.defaultLayoutOptions doc @@ -77,7 +78,7 @@ readImports pathText = do -readRawExpr :: Text -> IO (Maybe (Text, DhallExpr Dhall.Import)) +readRawExpr :: Text -> IO (Maybe (Dhall.Header, DhallExpr Dhall.Import)) readRawExpr pathText = do exists <- testfile pathText if exists @@ -87,13 +88,13 @@ readRawExpr pathText = do else pure Nothing -writeRawExpr :: Text -> (Text, DhallExpr Dhall.Import) -> IO () +writeRawExpr :: Text -> (Dhall.Header, DhallExpr Dhall.Import) -> IO () writeRawExpr pathText (header, expr) = do -- After modifying the expression, we have to check if it still typechecks -- if it doesn't we don't write to file. resolvedExpr <- Dhall.Import.load expr - throws (Dhall.TypeCheck.typeOf resolvedExpr) - writeTextFile pathText $ prettyWithHeader header expr <> "\n" + _ <- throws (Dhall.TypeCheck.typeOf resolvedExpr) + writeTextFile pathText $ prettyWithHeader header expr format pathText @@ -124,12 +125,12 @@ requireKey ks name f = case Dhall.Map.lookup name ks of Nothing -> throwM (RequiredKeyMissing name ks) --- | Same as `requireKey`, but we give it a Dhall.Type to automagically decode from +-- | Same as `requireKey`, but we give it a Dhall.Decoder to automagically decode from requireTypedKey :: (MonadIO m, MonadThrow m) => Dhall.Map.Map Text (DhallExpr Void) -> Text - -> Dhall.Type a + -> Dhall.Decoder a -> m a requireTypedKey ks name typ = requireKey ks name $ \expr -> case Dhall.extract typ expr of Success v -> pure v @@ -141,7 +142,7 @@ maybeTypedKey :: (MonadIO m, MonadThrow m) => Dhall.Map.Map Text (DhallExpr Void) -> Text - -> Dhall.Type a + -> Dhall.Decoder a -> m (Maybe a) maybeTypedKey ks name typ = typify `mapM` Dhall.Map.lookup name ks where @@ -157,7 +158,7 @@ maybeTypedKey ks name typ = typify `mapM` Dhall.Map.lookup name ks -- result of the normalization (we need to normalize so that extract can work) -- and return a `Right` only if both typecheck and normalization succeeded. coerceToType - :: Type a -> DhallExpr Void -> Either (ReadError Void) a + :: Dhall.Decoder a -> DhallExpr Void -> Either (ReadError Void) a coerceToType typ expr = do let annot = Dhall.Annot expr $ Dhall.expected typ let checkedType = typeOf annot @@ -169,7 +170,7 @@ coerceToType typ expr = do -- | Spago configuration cannot be read data ReadError a where -- | a package has the wrong type - WrongType :: Typeable a => Dhall.Type b -> DhallExpr a -> ReadError a + WrongType :: Typeable a => Dhall.Decoder b -> DhallExpr a -> ReadError a -- | the toplevel value is not a record ConfigIsNotRecord :: Typeable a => DhallExpr a -> ReadError a -- | the "packages" key is not a record diff --git a/stack.yaml b/stack.yaml index 25f66bb0d..4ce331d50 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,8 +2,10 @@ resolver: lts-12.21 packages: - . extra-deps: -- dhall-1.27.0 -- github-0.23 +- dhall-1.29.0 +- atomic-write-0.2.0.7 +- prettyprinter-1.5.1 +- github-0.24 - async-pool-0.9.0.2@sha256:3aca5861a7b839d02a3f5c52ad6d1ce368631003f68c3d9cb6d711c29e9618db,1599 - binary-instances-1@sha256:cdef50410f2797de38f021d328d38c32b2f4abeaab86bfaf78e0657150863090,2613 - directory-1.3.4.0@sha256:500019f04494324d1df16cf83eefeb3f809b2b20b32a32ccd755ee0439c18bfd,2829 diff --git a/stack.yaml.lock b/stack.yaml.lock index 626235c4e..ec2d30757 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,19 +5,33 @@ packages: - completed: - hackage: dhall-1.27.0@sha256:b522d6b534949e65771ed0179afc1488e4de2b185af5ed38e4806a6720db51bf,30519 + hackage: dhall-1.29.0@sha256:ca96ca294b7e642407524b09b5e2baf572c6b13be166bdceb66cccb957a108ba,32755 pantry-tree: - size: 232998 - sha256: 3f79ba6a3eeb0f59c1cf41663d65eebe71f5780f5765169e3d52406789a6f286 + size: 244291 + sha256: ef036b14977551a84bbfa6bf88263faa6fe0daf808a2837fbc88d558ab89dda2 original: - hackage: dhall-1.27.0 + hackage: dhall-1.29.0 - completed: - hackage: github-0.23@sha256:07671c92da7142668ecdeaa5669ddda629ae85f25acd2ecadd49f9a119a5eac6,6965 + hackage: atomic-write-0.2.0.7@sha256:3b626dfbc288cd070f1ac31b1c15ddd49822a923778ffe21f92b2116ffc72dc3,4584 pantry-tree: - size: 7113 - sha256: 90337bce40541903a3f151210499e3fbfa3e9fafbba4b1067641698cc6ee3921 + size: 2237 + sha256: b49d642f11c9eade41fac2c52dc34aadb093fd48139418c001e19d7ab1ae6696 original: - hackage: github-0.23 + hackage: atomic-write-0.2.0.7 +- completed: + hackage: prettyprinter-1.5.1@sha256:fca87c3e2611d3499a0341a59857e9b424a23f31646e4737d535a18582284f96,5375 + pantry-tree: + size: 2106 + sha256: 86fd583112db41bac5ac9ecf258ec402ad615253e9c5eabc56ec127bfb94c096 + original: + hackage: prettyprinter-1.5.1 +- completed: + hackage: github-0.24@sha256:4bf5a06289d36f78bf347b6a4f9906f659be7335cde78386a6c95568714a730b,6955 + pantry-tree: + size: 7105 + sha256: e0f84d7a3cdd76c6bd5395c8c72d24a1dda9616f857291820b08947c8290f042 + original: + hackage: github-0.24 - completed: hackage: async-pool-0.9.0.2@sha256:3aca5861a7b839d02a3f5c52ad6d1ce368631003f68c3d9cb6d711c29e9618db,1599 pantry-tree: diff --git a/test/fixtures/spago-bower-import.dhall b/test/fixtures/spago-bower-import.dhall index c392226cb..2c0713ace 100644 --- a/test/fixtures/spago-bower-import.dhall +++ b/test/fixtures/spago-bower-import.dhall @@ -4,22 +4,22 @@ You can edit this file as you like. -} { name = "simple-json" , dependencies = - [ "arrays" - , "assert" - , "console" - , "effect" - , "exceptions" - , "foreign" - , "foreign-object" - , "generics-rep" - , "globals" - , "nullable" - , "prelude" - , "psci-support" - , "record" - , "typelevel-prelude" - , "variant" - ] + [ "arrays" + , "assert" + , "console" + , "effect" + , "exceptions" + , "foreign" + , "foreign-object" + , "generics-rep" + , "globals" + , "nullable" + , "prelude" + , "psci-support" + , "record" + , "typelevel-prelude" + , "variant" + ] , packages = ./packages.dhall , sources = [ "src/**/*.purs", "test/**/*.purs" ] } diff --git a/test/fixtures/spago-configV1.dhall b/test/fixtures/spago-configV1.dhall index 0faa496b2..26c0f90e2 100644 --- a/test/fixtures/spago-configV1.dhall +++ b/test/fixtures/spago-configV1.dhall @@ -4,6 +4,6 @@ You can edit this file as you like. -} { name = "aaa" , dependencies = - [ "console", "effect", "foreign", "prelude", "psci-support", "simple-json" ] + [ "console", "effect", "foreign", "prelude", "psci-support", "simple-json" ] , packages = ./packages.dhall } diff --git a/test/fixtures/spago-configV2.dhall b/test/fixtures/spago-configV2.dhall index eaf36b839..82e5b5829 100644 --- a/test/fixtures/spago-configV2.dhall +++ b/test/fixtures/spago-configV2.dhall @@ -5,6 +5,6 @@ You can edit this file as you like. { sources = [ "src/**/*.purs", "test/**/*.purs" ] , name = "aaa" , dependencies = - [ "console", "effect", "foreign", "prelude", "psci-support", "simple-json" ] + [ "console", "effect", "foreign", "prelude", "psci-support", "simple-json" ] , packages = ./packages.dhall } diff --git a/test/fixtures/spago-install-success.dhall b/test/fixtures/spago-install-success.dhall index a39d6efdb..8151bdebe 100644 --- a/test/fixtures/spago-install-success.dhall +++ b/test/fixtures/spago-install-success.dhall @@ -4,7 +4,7 @@ You can edit this file as you like. -} { name = "aaa" , dependencies = - [ "console", "effect", "foreign", "prelude", "psci-support", "simple-json" ] + [ "console", "effect", "foreign", "prelude", "psci-support", "simple-json" ] , packages = ./packages.dhall , sources = [ "src/**/*.purs", "test/**/*.purs" ] }