Optional received messages 2

.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:

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:

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

package.yaml

@@ -22,6 +22,7 @@ default-extensions:
   - DuplicateRecordFields
   - GeneralizedNewtypeDeriving
   - LambdaCase
+  - OverloadedRecordDot
   - OverloadedStrings
 
 ghc-options:

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 = ''

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

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

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

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-18.10
+resolver: lts-22.41
 packages:
   - .
 extra-deps:

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

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"
             }

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"
         }

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 \

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"
         }