Bump hasql-listen notify and get more things compiling

Author: ChrisPenner

share-api/src/Share/Notifications/Types.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE RecordWildCards #-}
 
@@ -74,7 +75,7 @@ data NotificationTopic
   deriving (Eq, Show, Ord, Enum, Bounded)
 
 instance PG.EncodeValue NotificationTopic where
-  encodeValue = HasqlEncoders.enum \case
+  encodeValue = HasqlEncoders.enum Nothing "notification_topic" \case
     ProjectBranchUpdated -> "project:branch:updated"
     ProjectContributionCreated -> "project:contribution:created"
     ProjectContributionStatusUpdated -> "project:contribution:updated"
@@ -85,7 +86,7 @@ instance PG.EncodeValue NotificationTopic where
     ProjectReleaseCreated -> "project:release:created"
 
 instance PG.DecodeValue NotificationTopic where
-  decodeValue = HasqlDecoders.enum \case
+  decodeValue = HasqlDecoders.enum Nothing "notification_topic" \case
     "project:branch:updated" -> Just ProjectBranchUpdated
     "project:contribution:created" -> Just ProjectContributionCreated
     "project:contribution:updated" -> Just ProjectContributionStatusUpdated
@@ -125,12 +126,12 @@ data NotificationTopicGroup
   deriving (Eq, Show, Ord)
 
 instance PG.EncodeValue NotificationTopicGroup where
-  encodeValue = HasqlEncoders.enum \case
+  encodeValue = HasqlEncoders.enum Nothing "notification_topic_group" \case
     WatchProject -> "watch_project"
     AllProjectTopics -> "all_project_topics"
 
 instance PG.DecodeValue NotificationTopicGroup where
-  decodeValue = HasqlDecoders.enum \case
+  decodeValue = HasqlDecoders.enum Nothing "notification_topic_group" \case
     "watch_project" -> Just WatchProject
     "all_project_topics" -> Just AllProjectTopics
     _ -> Nothing
@@ -179,13 +180,13 @@ instance Aeson.FromJSON NotificationStatus where
     s -> fail $ "Invalid notification status: " <> Text.unpack s
 
 instance PG.EncodeValue NotificationStatus where
-  encodeValue = HasqlEncoders.enum \case
+  encodeValue = HasqlEncoders.enum Nothing "notification_status" \case
     Unread -> "unread"
     Read -> "read"
     Archived -> "archived"
 
 instance PG.DecodeValue NotificationStatus where
-  decodeValue = HasqlDecoders.enum \case
+  decodeValue = HasqlDecoders.enum Nothing "notification_status" \case
     "unread" -> Just Unread
     "read" -> Just Read
     "archived" -> Just Archived
@@ -395,36 +396,39 @@ instance PG.EncodeValue NotificationEventData where
 instance Hasql.DecodeRow NotificationEventData where
   decodeRow = do
     topic <- PG.decodeField
-    Hasql.Jsonb jsonData <- PG.decodeField
-    case topic of
-      ProjectBranchUpdated -> do
-        (project :++ branch) <- parseJsonData jsonData
-        pure $ ProjectBranchUpdatedData project branch
-      ProjectContributionCreated -> do
-        (project :++ contr) <- parseJsonData jsonData
-        pure $ ProjectContributionCreatedData project contr
-      ProjectContributionStatusUpdated -> do
-        (project :++ contr :++ status) <- parseJsonData jsonData
-        pure $ ProjectContributionStatusUpdatedData project contr status
-      ProjectContributionComment -> do
-        (project :++ contr :++ comm) <- parseJsonData jsonData
-        pure $ ProjectContributionCommentData project contr comm
-      ProjectTicketCreated -> do
-        (project :++ ticket) <- parseJsonData jsonData
-        pure $ ProjectTicketCreatedData project ticket
-      ProjectTicketStatusUpdated -> do
-        (project :++ ticket :++ status) <- parseJsonData jsonData
-        pure $ ProjectTicketStatusUpdatedData project ticket status
-      ProjectTicketComment -> do
-        (project :++ ticket :++ comm) <- parseJsonData jsonData
-        pure $ ProjectTicketCommentData project ticket comm
-      ProjectReleaseCreated -> do
-        (project :++ release) <- parseJsonData jsonData
-        pure $ ProjectReleaseCreatedData project release
+    jsonb <- PG.decodeField
+    pure $
+      -- ApplicativeDo isn't very smart, therefore, nested lets.
+      let Hasql.Jsonb jsonData = jsonb
+       in case topic of
+            ProjectBranchUpdated ->
+              let (project :++ branch) = parseJsonData jsonData
+               in ProjectBranchUpdatedData project branch
+            ProjectContributionCreated -> do
+              let (project :++ contr) = parseJsonData jsonData
+               in ProjectContributionCreatedData project contr
+            ProjectContributionStatusUpdated -> do
+              let (project :++ contr :++ status) = parseJsonData jsonData
+               in ProjectContributionStatusUpdatedData project contr status
+            ProjectContributionComment -> do
+              let (project :++ contr :++ comm) = parseJsonData jsonData
+               in ProjectContributionCommentData project contr comm
+            ProjectTicketCreated -> do
+              let (project :++ ticket) = parseJsonData jsonData
+               in ProjectTicketCreatedData project ticket
+            ProjectTicketStatusUpdated -> do
+              let (project :++ ticket :++ status) = parseJsonData jsonData
+               in ProjectTicketStatusUpdatedData project ticket status
+            ProjectTicketComment -> do
+              let (project :++ ticket :++ comm) = parseJsonData jsonData
+               in ProjectTicketCommentData project ticket comm
+            ProjectReleaseCreated -> do
+              let (project :++ release) = parseJsonData jsonData
+               in ProjectReleaseCreatedData project release
     where
       parseJsonData v = case Aeson.fromJSON v of
-        Aeson.Error e -> fail e
-        Aeson.Success a -> pure a
+        Aeson.Error e -> error e
+        Aeson.Success a -> a
 
 eventTopic :: NotificationEventData -> NotificationTopic
 eventTopic = \case
@@ -530,8 +534,10 @@ data NotificationWebhookConfig = NotificationWebhookConfig
 instance PG.DecodeRow NotificationWebhookConfig where
   decodeRow = do
     webhookDeliveryId <- PG.decodeField
-    URIParam webhookDeliveryUrl <- PG.decodeField
-    pure $ NotificationWebhookConfig {webhookDeliveryId, webhookDeliveryUrl}
+    url <- PG.decodeField
+    pure $
+      let URIParam webhookDeliveryUrl = url
+       in NotificationWebhookConfig {webhookDeliveryId, webhookDeliveryUrl}
 
 instance Aeson.ToJSON NotificationWebhookConfig where
   toJSON NotificationWebhookConfig {webhookDeliveryId, webhookDeliveryUrl} =
@@ -602,16 +608,17 @@ instance PG.DecodeRow (NotificationSubscription NotificationSubscriptionId) wher
     subscriptionScopeProject <- PG.decodeField
     subscriberUser <- PG.decodeField
     subscriberProject <- PG.decodeField
-    let subscriptionOwner = case (subscriberUser, subscriberProject) of
-          (Just uid, Nothing) -> UserSubscriptionOwner uid
-          (Nothing, Just pid) -> ProjectSubscriptionOwner pid
-          _ -> error "Invalid subscription owner in database"
     subscriptionTopics <- Set.fromList <$> PG.decodeField
     subscriptionTopicGroups <- Set.fromList <$> PG.decodeField
     subscriptionFilter <- PG.decodeField
     subscriptionCreatedAt <- PG.decodeField
     subscriptionUpdatedAt <- PG.decodeField
-    pure $ NotificationSubscription {subscriptionId, subscriptionScopeUser, subscriptionScopeProject, subscriptionOwner, subscriptionTopics, subscriptionTopicGroups, subscriptionFilter, subscriptionCreatedAt, subscriptionUpdatedAt}
+    pure $
+      let subscriptionOwner = case (subscriberUser, subscriberProject) of
+            (Just uid, Nothing) -> UserSubscriptionOwner uid
+            (Nothing, Just pid) -> ProjectSubscriptionOwner pid
+            _ -> error "Invalid subscription owner in database"
+       in NotificationSubscription {subscriptionId, subscriptionScopeUser, subscriptionScopeProject, subscriptionOwner, subscriptionTopics, subscriptionTopicGroups, subscriptionFilter, subscriptionCreatedAt, subscriptionUpdatedAt}
 
 instance Aeson.ToJSON (NotificationSubscription NotificationSubscriptionId) where
   toJSON NotificationSubscription {subscriptionId, subscriptionScopeUser, subscriptionScopeProject, subscriptionOwner, subscriptionTopics, subscriptionTopicGroups, subscriptionFilter, subscriptionCreatedAt, subscriptionUpdatedAt} =

share-api/src/Share/Postgres/Definitions/Queries.hs

@@ -239,7 +239,7 @@ expectShareTermComponent (CodebaseEnv {codebaseOwner}) componentHashId = do
         -- Ensure we get at least one index, and that we have bytes saved for each part of the
         -- component.
         <&> checkElements
-      )
+    )
       `whenNothingM` do
         unrecoverableError $ InternalServerError "expected-term-component" (ExpectedTermComponentNotFound componentHashId)
   second (Hash32.fromHash . unComponentHash) . Share.TermComponent . toList <$> for componentElements \(termId, LocalTermBytes bytes) ->
@@ -1076,7 +1076,7 @@ saveTypeComponent (codebase@CodebaseEnv {codebaseOwner}) componentHash maySerial
       constructorsTableWithIds <-
         ( HashQ.ensureComponentHashIdsOf (traversed . _4 . _Just) constructorsTable
             >>= ensureTextIdsOf (traversed . _3 . _Just)
-          )
+        )
 
       whenNonEmpty constructorsTableWithIds $
         execute_
@@ -1372,7 +1372,7 @@ data ReferenceIdTuple = ReferenceIdTuple
   deriving (Eq, Show)
 
 instance Hasql.DecodeValue ReferenceIdTuple where
-  decodeValue = Decoders.composite $ do
+  decodeValue = Decoders.record $ do
     tupleComponentHash <- Decoders.field $ Hasql.decodeField
     tupleComponentIndex <- Decoders.field $ Hasql.decodeField
     pure ReferenceIdTuple {tupleComponentHash, tupleComponentIndex}

share-api/src/Share/Postgres/NameLookups/Queries.hs

@@ -168,7 +168,7 @@ newtype NamedReferentResult = NamedReferentResult (NamedRef (PGReferent, (Maybe
   deriving (Show)
 
 instance Hasql.DecodeValue NamedReferentResult where
-  decodeValue = Decoders.composite $ do
+  decodeValue = Decoders.record $ do
     name <- Decoders.field $ Hasql.decodeField @ReversedName
     ref <- decodeComposite
     ct <- (Decoders.field $ Hasql.decodeField @(Maybe ConstructorType))
@@ -177,7 +177,7 @@ instance Hasql.DecodeValue NamedReferentResult where
 newtype NamedReferenceResult = NamedReferenceResult (NamedRef PGReference)
 
 instance Hasql.DecodeValue NamedReferenceResult where
-  decodeValue = Decoders.composite $ do
+  decodeValue = Decoders.record $ do
     name <- Decoders.field $ Hasql.decodeField @ReversedName
     ref <- decodeComposite
     pure $ NamedReferenceResult (NamedRef name ref)
@@ -498,8 +498,7 @@ projectTermsWithinRootV1 !_nlReceipt bhId = do
         WHERE root_branch_hash_id = #{bhId}
     |]
     <&> fmap
-      ( \NamedRef {reversedSegments, ref} -> (reversedNameToName reversedSegments, referent2to1 ref)
-      )
+      (\NamedRef {reversedSegments, ref} -> (reversedNameToName reversedSegments, referent2to1 ref))
 
 -- | Get a cursor over all non-lib terms within the given root branch.
 projectTermsWithinRoot :: (QueryM m) => NameLookupReceipt -> BranchHashId -> m (PGCursor (Name, V2.Referent))

share-api/src/Share/Postgres/NameLookups/Types.hs

@@ -57,7 +57,7 @@ data NameWithSuffix = NameWithSuffix
   deriving stock (Eq, Ord, Show, Generic)
 
 instance PG.DecodeValue NameWithSuffix where
-  decodeValue = Decoders.composite nameWithSuffixComposite
+  decodeValue = Decoders.record nameWithSuffixComposite
 
 nameWithSuffixComposite :: Decoders.Composite NameWithSuffix
 nameWithSuffixComposite = do

share-api/src/Share/Postgres/Notifications.hs

@@ -45,7 +45,7 @@ initialize scope = Ki.fork_ scope $ forever do
   result <- UnliftIO.try $ do
     PG.runSession $ do
       for_ allChannels \kind -> do
-        PG.statement () $ Hasql.listen (Hasql.Identifier . Text.encodeUtf8 $ toChannelText kind)
+        PG.statement () $ Hasql.listen (Hasql.Identifier $ toChannelText kind)
       -- Wait for notifications
       let loop = do
             Hasql.Notification {channel} <- PG.Session . lift . lift . lift $ Hasql.await

stack.yaml

@@ -87,7 +87,7 @@ extra-deps:
 # Updated to work against hasql-1.10
 # Unfortunately hasql-1.10 makes its libpq dependencies more private
 - github: ChrisPenner/hasql-listen-notify
-  commit: d75951239f1b8f2d87425769bc1aa29dc17b5ce8
+  commit: 9bd6fcf058faf36d3bf9aea2a09acdd112490106
 
 ghc-options:
  # All packages

stack.yaml.lock

@@ -197,14 +197,14 @@ packages:
 - completed:
     name: hasql-listen-notify
     pantry-tree:
-      sha256: 4b1f48dc8015debc556f6fc77d903891905f5b56f855c7d26d11a55444147cc3
+      sha256: fc73475fc9fcae1102afbd981927bc66a4499ffe57bf432b952a16b9bb06e917
       size: 610
-    sha256: 9e1128de5650d45a126b45d63a6dc27c23b53782d33283c5304eea094e4ec68c
-    size: 8687
-    url: https://github.com/ChrisPenner/hasql-listen-notify/archive/d75951239f1b8f2d87425769bc1aa29dc17b5ce8.tar.gz
+    sha256: d040a58f9cec7ca260e5bd8c37cce2879b02476d28e7f276f81d44e0fe20d68a
+    size: 8838
+    url: https://github.com/ChrisPenner/hasql-listen-notify/archive/9bd6fcf058faf36d3bf9aea2a09acdd112490106.tar.gz
     version: 0.1.0.1
   original:
-    url: https://github.com/ChrisPenner/hasql-listen-notify/archive/d75951239f1b8f2d87425769bc1aa29dc17b5ce8.tar.gz
+    url: https://github.com/ChrisPenner/hasql-listen-notify/archive/9bd6fcf058faf36d3bf9aea2a09acdd112490106.tar.gz
 snapshots:
 - completed:
     sha256: 4b787f53036611a03edbf438dd5412daa03fb3da5d938ae8865ec471fe3f9632