From a0b8d18f172daf62f6070ef63508b46dd2484770 Mon Sep 17 00:00:00 2001 From: Phil Hazelden Date: Wed, 28 Feb 2024 13:04:28 +0000 Subject: [PATCH 1/3] Support GHC 9.6. --- cloud-pubsub.cabal | 4 +++- default.nix | 6 +++--- package.yaml | 1 + shell.nix | 4 ++-- src/Cloud/PubSub/Auth/Token.hs | 10 ++++------ stack.yaml | 2 +- stack.yaml.lock | 12 ++++++------ test/Cloud/PubSub/SnapshotSpec.hs | 6 ++++-- test/Cloud/PubSub/SubscriptionSpec.hs | 11 +++++++---- test/Cloud/PubSub/TestHelpers.hs | 22 +++++++++++++++------- test/Cloud/PubSub/TopicSpec.hs | 4 +++- 11 files changed, 49 insertions(+), 33 deletions(-) diff --git a/cloud-pubsub.cabal b/cloud-pubsub.cabal index b47bdd8..fe916bd 100644 --- a/cloud-pubsub.cabal +++ b/cloud-pubsub.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -56,6 +56,7 @@ library DuplicateRecordFields GeneralizedNewtypeDeriving LambdaCase + OverloadedRecordDot OverloadedStrings ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-deprecations build-depends: @@ -113,6 +114,7 @@ test-suite cloud-pubsub-test DuplicateRecordFields GeneralizedNewtypeDeriving LambdaCase + OverloadedRecordDot OverloadedStrings ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-deprecations -threaded -rtsopts -with-rtsopts=-N build-depends: diff --git a/default.nix b/default.nix index c352ecd..8d0cdf1 100644 --- a/default.nix +++ b/default.nix @@ -2,15 +2,15 @@ let sources = { haskellNix = (builtins.fetchTarball { - url = "https://github.com/input-output-hk/haskell.nix/archive/6cbb6390ae49b6d7983d00f3db7d21ba078f2c96.tar.gz"; - sha256 = "0qj82l72qpnzrxc8rbfklk038ybgfb1s56rnmigjnx3s417a37iv"; + url = "https://github.com/input-output-hk/haskell.nix/archive/256e8da232ea566d08575f57b339d0a1f1e29f2d.tar.gz"; + sha256 = "0wsbjgrkba6rdyz99jyr4rwgwgck7ayc0ja1ghmmbp6l6jg34p21"; }); }; haskellNix = import sources.haskellNix { }; pkgs = import - haskellNix.sources.nixpkgs-2105 + haskellNix.sources.nixpkgs-2405 haskellNix.nixpkgsArgs; out = pkgs.haskell-nix.project diff --git a/package.yaml b/package.yaml index 4905587..d310e0d 100644 --- a/package.yaml +++ b/package.yaml @@ -22,6 +22,7 @@ default-extensions: - DuplicateRecordFields - GeneralizedNewtypeDeriving - LambdaCase + - OverloadedRecordDot - OverloadedStrings ghc-options: diff --git a/shell.nix b/shell.nix index f04bef4..d9c5b11 100644 --- a/shell.nix +++ b/shell.nix @@ -8,8 +8,8 @@ hsPkgs.shellFor { exactDeps = true; buildInputs = [ pkgs.docker-compose ]; tools = { - cabal = "3.4.0.0"; - hpack = "0.34.4"; + cabal = "3.12.1.0"; + hpack = "0.37.0"; }; shellHook = '' diff --git a/src/Cloud/PubSub/Auth/Token.hs b/src/Cloud/PubSub/Auth/Token.hs index 6868f2a..f9818a2 100644 --- a/src/Cloud/PubSub/Auth/Token.hs +++ b/src/Cloud/PubSub/Auth/Token.hs @@ -25,10 +25,8 @@ fetchAndUpdateToken resources manager scope = do let serviceAccount = HttpT.ctrServiceAccount resources tokenResponse <- Auth.fetchToken manager serviceAccount scope now <- Time.getCurrentTime - let accessToken = - Auth.accessToken (tokenResponse :: Auth.AccessTokenResponse) - expiresIn = Auth.expiresIn (tokenResponse :: Auth.AccessTokenResponse) - expiresAt = Time.addUTCTime expiresIn now + let accessToken = tokenResponse.accessToken + expiresAt = Time.addUTCTime tokenResponse.expiresIn now cachedToken = Auth.CachedToken accessToken expiresAt MVar.putMVar (HttpT.ctrCachedTokenMVar resources) (HttpT.Available cachedToken) @@ -64,7 +62,7 @@ getToken = do HttpT.Available cachedToken -> do now <- liftIO Time.getCurrentTime let renewThreshold = HttpT.ctrRenewThreshold cloudResources - if Time.diffUTCTime (Auth.expiresAt cachedToken) now < renewThreshold + if Time.diffUTCTime cachedToken.expiresAt now < renewThreshold then do Logger.logWithContext ML.LevelDebug Nothing @@ -73,4 +71,4 @@ getToken = do else do liftIO $ MVar.putMVar tokenMVar (HttpT.Available cachedToken) Logger.logWithContext ML.LevelDebug Nothing "Using cached token" - return $ Auth.accessToken (cachedToken :: Auth.CachedToken) + return cachedToken.accessToken diff --git a/stack.yaml b/stack.yaml index cb689e0..eda7dbb 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-18.10 +resolver: lts-22.41 packages: - . extra-deps: diff --git a/stack.yaml.lock b/stack.yaml.lock index 777c3ee..e9e5967 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,10 +3,10 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -snapshots: -- original: lts-18.10 - completed: - sha256: 88b4f81e162ba3adc230a9fcccc4d19ac116377656bab56c7382ca88598b257a - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/10.yaml - size: 587546 packages: [] +snapshots: +- completed: + sha256: 1e32b51d9082fdf6f3bd92accc9dfffd4ddaf406404427fb10bf76d2bc03cbbb + size: 720263 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/41.yaml + original: lts-22.41 diff --git a/test/Cloud/PubSub/SnapshotSpec.hs b/test/Cloud/PubSub/SnapshotSpec.hs index 7a0e342..2ac8fe5 100644 --- a/test/Cloud/PubSub/SnapshotSpec.hs +++ b/test/Cloud/PubSub/SnapshotSpec.hs @@ -4,6 +4,8 @@ import Cloud.PubSub.Core.Types ( UpdateMask(..) ) import qualified Cloud.PubSub.Http.Types as HttpT import qualified Cloud.PubSub.Snapshot as Snapshot import qualified Cloud.PubSub.Snapshot.Types as SnapshotT +import qualified Cloud.PubSub.Snapshot.Types as SnapshotT.Snapshot + ( Snapshot(..) ) import Cloud.PubSub.TestHelpers ( TestEnv , mkTestPubSubEnv , runTest @@ -38,8 +40,8 @@ snapshotUpdateTest = let snapshotPatch = SnapshotT.SnapshotPatch { snapshot = initialSnap - { SnapshotT.labels = Just - $ HM.fromList [("patched", "successful")] + { SnapshotT.Snapshot.labels = + Just $ HM.fromList [("patched", "successful")] } , updateMask = UpdateMask "labels" } diff --git a/test/Cloud/PubSub/SubscriptionSpec.hs b/test/Cloud/PubSub/SubscriptionSpec.hs index 683f439..72f5d79 100644 --- a/test/Cloud/PubSub/SubscriptionSpec.hs +++ b/test/Cloud/PubSub/SubscriptionSpec.hs @@ -7,6 +7,9 @@ import qualified Cloud.PubSub.Http.Types as HttpT import qualified Cloud.PubSub.Subscription as Subscription import qualified Cloud.PubSub.Subscription.Types as SubscriptionT +import qualified Cloud.PubSub.Subscription.Types + as SubscriptionT.Subscription + ( Subscription(..) ) import Cloud.PubSub.TestHelpers ( TestEnv , mkTestPubSubEnv , runTest @@ -33,11 +36,11 @@ testMessage = Topic.PublishPubsubMessage { ppmOrderingKey = Just "constant-key" resetPublishConfigAttributes :: SubscriptionT.Subscription -> SubscriptionT.Subscription resetPublishConfigAttributes sub = sub - { SubscriptionT.pushConfig = Just pushConfig + { SubscriptionT.Subscription.pushConfig = Just pushConfig } where pushConfig = - (fromJust $ SubscriptionT.pushConfig (sub :: SubscriptionT.Subscription)) + (fromJust sub.pushConfig) { SubscriptionT.attributes = Nothing } @@ -60,8 +63,8 @@ subscriptionUpdateTest = let subPatch = SubscriptionT.SubscriptionPatch { subscription = initialSub - { SubscriptionT.labels = Just - $ HM.fromList [("patched", "successful")] + { SubscriptionT.Subscription.labels = + Just $ HM.fromList [("patched", "successful")] } , updateMask = Core.UpdateMask "labels" } diff --git a/test/Cloud/PubSub/TestHelpers.hs b/test/Cloud/PubSub/TestHelpers.hs index 66f7c30..0c5cf5d 100644 --- a/test/Cloud/PubSub/TestHelpers.hs +++ b/test/Cloud/PubSub/TestHelpers.hs @@ -9,11 +9,18 @@ import qualified Cloud.PubSub.Http.Types as HttpT import qualified Cloud.PubSub.Logger as Logger import qualified Cloud.PubSub.Snapshot as Snapshot import qualified Cloud.PubSub.Snapshot.Types as SnapshotT +import qualified Cloud.PubSub.Snapshot.Types as SnapshotT.NewSnapshot + ( NewSnapshot(..) ) import qualified Cloud.PubSub.Subscription as Subscription import qualified Cloud.PubSub.Subscription.Types as SubscriptionT +import qualified Cloud.PubSub.Subscription.Types + as SubscriptionT.NewSubscription + ( NewSubscription(..) ) import qualified Cloud.PubSub.Topic as Topic import qualified Cloud.PubSub.Topic.Types as TopicT +import qualified Cloud.PubSub.Topic.Types as TopicT.NewTopic + ( NewTopic(..) ) import qualified Cloud.PubSub.Trans as PubSubTrans import Control.Monad.Catch ( Exception , MonadMask @@ -29,7 +36,7 @@ import qualified System.IO as SystemIO import Test.Hspec ( pendingWith ) newtype TestEnv = TestEnv - { pubSubEnv :: PubSubTrans.PubSubEnv + { pubSubEnv :: PubSubTrans.PubSubEnv } isEmulated :: TestEnv -> Bool @@ -48,7 +55,8 @@ createTestTopic topicName = Topic.create topicName newTopic >>= \case error $ "unexpected existing topic " <> show topicName where newTopic :: TopicT.NewTopic - newTopic = TopicT.minimalNewTopic { TopicT.labels = Just testLabels } + newTopic = TopicT.minimalNewTopic { TopicT.NewTopic.labels = Just testLabels + } withTestTopic :: (HttpT.PubSubHttpClientM m, MonadMask m) => TopicName -> m a -> m a @@ -64,7 +72,7 @@ createTestSub subName topicName = do let qualifiedTopic = Core.qualifyTopicName projectId topicName newSub :: SubscriptionT.NewSubscription newSub = (SubscriptionT.minimalNewSubscription qualifiedTopic) - { SubscriptionT.labels = Just testLabels + { SubscriptionT.NewSubscription.labels = Just testLabels } Subscription.create subName newSub >>= \case Right _ -> return () @@ -92,7 +100,7 @@ createSnapshot snapshotName subName = do let qualifiedSub = SubscriptionT.qualifySubName projectId subName newSnap :: SnapshotT.NewSnapshot newSnap = (SnapshotT.minimalNewSnapshot qualifiedSub) - { SnapshotT.labels = Just testLabels + { SnapshotT.NewSnapshot.labels = Just testLabels } Snapshot.create snapshotName newSnap >>= \case Right _ -> return () @@ -152,9 +160,9 @@ getPubSubTarget renewThreshold = do return $ PubSub.EmulatorTarget $ PubSub.HostAndPort hostAndPortStr (Nothing, Just saFile) -> let authMethod = PubSub.ServiceAccountFile saFile - in return $ PubSub.CloudServiceTarget $ PubSub.CloudConfig - renewThreshold - authMethod + in return + $ PubSub.CloudServiceTarget + $ PubSub.CloudConfig renewThreshold authMethod (_, _) -> error "Please specify either \"PUBSUB_EMULATOR_HOST\" or \ diff --git a/test/Cloud/PubSub/TopicSpec.hs b/test/Cloud/PubSub/TopicSpec.hs index f207da3..695bcf9 100644 --- a/test/Cloud/PubSub/TopicSpec.hs +++ b/test/Cloud/PubSub/TopicSpec.hs @@ -12,6 +12,8 @@ import Cloud.PubSub.TestHelpers ( TestEnv ) import qualified Cloud.PubSub.Topic as Topic import qualified Cloud.PubSub.Topic.Types as TopicT +import qualified Cloud.PubSub.Topic.Types as TopicT.Topic + ( Topic(..) ) import Control.Monad.IO.Class ( liftIO ) import Data.Functor ( void ) import qualified Data.HashMap.Strict as HM @@ -31,7 +33,7 @@ topicUpdateTest = runTestIfNotEmulator $ withTestTopic topic $ do initialTopic <- Topic.get topic let topicPatch = TopicT.TopicPatch { topic = initialTopic - { TopicT.labels = Just $ HM.fromList [("patched", "successful")] + { TopicT.Topic.labels = Just $ HM.fromList [("patched", "successful")] } , updateMask = Core.UpdateMask "labels" } From 3ad1a0372ffbbcbc7117275edbb7d08f997a43c4 Mon Sep 17 00:00:00 2001 From: Phil Hazelden Date: Mon, 30 Dec 2024 16:58:36 +0000 Subject: [PATCH 2/3] Update stack workflow action. --- .github/workflows/stack-cloud.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/stack-cloud.yaml b/.github/workflows/stack-cloud.yaml index 1260615..5def093 100644 --- a/.github/workflows/stack-cloud.yaml +++ b/.github/workflows/stack-cloud.yaml @@ -6,11 +6,11 @@ jobs: runs-on: ubuntu-latest steps: - uses: actions/checkout@v2 - - uses: haskell/actions/setup@v1 + - uses: haskell-actions/setup@v2 with: enable-stack: true stack-no-global: true - stack-version: "2.7.1" + stack-version: "3.3.1" - name: Cache Stack Dependencies uses: actions/cache@v2 with: From 9b7f8bb653f9bd7223e17eb88752daf6fb50b396 Mon Sep 17 00:00:00 2001 From: Stefan Fehrenbach Date: Fri, 20 Jun 2025 15:05:03 +0100 Subject: [PATCH 3/3] Tolerate empty pull response object Fixes #10. --- src/Cloud/PubSub/Subscription.hs | 5 +++-- src/Cloud/PubSub/Subscription/Types.hs | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Cloud/PubSub/Subscription.hs b/src/Cloud/PubSub/Subscription.hs index 18cc9ad..36067e7 100644 --- a/src/Cloud/PubSub/Subscription.hs +++ b/src/Cloud/PubSub/Subscription.hs @@ -20,6 +20,7 @@ import qualified Cloud.PubSub.HttpClient as HttpClient import qualified Cloud.PubSub.Subscription.Types as SubscriptionT import Control.Monad.Catch ( throwM ) +import Data.Maybe ( fromMaybe ) import qualified Data.Text as Text getSubStr @@ -107,8 +108,8 @@ pull pull subName batchSize = do path <- getSubOpPath subName "pull" let body = SubscriptionT.PullRequest batchSize - SubscriptionT.receivedMessages - <$> (HttpClient.authedJsonPostRequest path body >>= either throwM return) + response <- HttpClient.authedJsonPostRequest path body >>= either throwM return + pure $ fromMaybe [] $ SubscriptionT.receivedMessages response acknowledge :: HttpT.PubSubHttpClientM m diff --git a/src/Cloud/PubSub/Subscription/Types.hs b/src/Cloud/PubSub/Subscription/Types.hs index a8fdb09..432671e 100644 --- a/src/Cloud/PubSub/Subscription/Types.hs +++ b/src/Cloud/PubSub/Subscription/Types.hs @@ -74,7 +74,7 @@ instance Aeson.FromJSON ReceivedMessage where parseJSON = Aeson.genericParseJSON Json.options newtype PullResponse = PullResponse - { receivedMessages :: [ReceivedMessage] + { receivedMessages :: Maybe [ReceivedMessage] } deriving stock (Show, Eq, Generic) deriving anyclass Aeson.FromJSON