Merge pull request #2260 from digitallyinduced/add-werror-incomplete-patterns

Add -Werror=incomplete-patterns across all packages

Author: mpscholten

.ghci

@@ -46,7 +46,7 @@
 
 :set -Wno-unsafe -Wno-name-shadowing -Wno-monomorphism-restriction -Wno-safe -Wno-missing-local-signatures -Wno-missing-home-modules
 :set -Werror=missing-fields
-:set -fwarn-incomplete-patterns
+:set -Werror=incomplete-patterns
 :set -Wno-ambiguous-fields
 :set -fprefer-byte-code
 :set -fbyte-code-and-object-code

ihp-context/ihp-context.cabal

@@ -32,6 +32,7 @@ common shared-properties
         , ImplicitParams
         , BlockArguments
         , LambdaCase
+    ghc-options: -Werror=incomplete-patterns
 
 library
     import: shared-properties

ihp-datasync-typescript/ihp-datasync-typescript.cabal

@@ -36,6 +36,7 @@ common shared-properties
         , LambdaCase
         , TemplateHaskell
         , OverloadedRecordDot
+    ghc-options: -Werror=incomplete-patterns
 
 library
     import: shared-properties

ihp-datasync/IHP/DataSync/ChangeNotifications.hs

@@ -163,6 +163,7 @@ instance FromJSON ChangeSet where
         case UUID.fromText id of
             Just largePgNotificationId -> pure ExternalChangeSet { largePgNotificationId }
             Nothing -> fail "Invalid UUID"
+    parseJSON invalid = fail $ cs ("Expected Array or String for ChangeSet, got: " <> tshow invalid)
 
 instance FromJSON Change where
     parseJSON = withObject "Change" $ \values -> do

ihp-datasync/IHP/DataSync/ControllerImpl.hs

@@ -196,6 +196,15 @@ buildMessageHandler ensureRLSEnabled installTableChangeTriggers sendJSON handleC
                                     if isRecordInResultSet
                                         then sendJSON DidUpdate { subscriptionId, id, changeSet = changesToValue (renamer tableName) changes }
                                         else sendJSON DidDelete { subscriptionId, id }
+                            ChangeNotifications.DidUpdateLarge { id, payloadId } -> do
+                                isWatchingRecord <- Set.member id <$> readIORef watchedRecordIdsRef
+                                when isWatchingRecord do
+                                    [(PG.Only isRecordInResultSet)] <- sqlQueryWithRLS ("SELECT EXISTS(SELECT * FROM (" <> theQuery <> ") AS records WHERE records.id = ? LIMIT 1)") (theParams <> [PG.toField id])
+
+                                    changes <- ChangeNotifications.retrieveChanges (ChangeNotifications.ExternalChangeSet { largePgNotificationId = payloadId })
+                                    if isRecordInResultSet
+                                        then sendJSON DidUpdate { subscriptionId, id, changeSet = changesToValue (renamer tableName) changes }
+                                        else sendJSON DidDelete { subscriptionId, id }
                             ChangeNotifications.DidDelete { id } -> do
                                 -- Only send the notifcation if the deleted record was part of the initial
                                 -- results set

ihp-datasync/IHP/DataSync/DynamicQuery.hs

@@ -99,9 +99,11 @@ data SelectedColumns
 
 instance FromJSON ByteString where
     parseJSON (String v) = pure $ cs v
+    parseJSON invalid = fail $ cs ("Expected String for ByteString, got: " <> tshow invalid)
 
 instance FromJSON PG.Action where
     parseJSON (String v) = pure (PG.Escape (cs v))
+    parseJSON invalid = fail $ cs ("Expected String for PG.Action, got: " <> tshow invalid)
 
 instance {-# OVERLAPS #-} ToJSON [Field] where
     toJSON fields = object (map (\Field { fieldName, fieldValue } -> (cs fieldName) .= (toJSON fieldValue)) fields)
@@ -184,6 +186,7 @@ transformColumnNamesToFieldNames (Object hashMap) =
                 |> Aeson.toText
                 |> function
                 |> Aeson.fromText
+transformColumnNamesToFieldNames otherwise = otherwise
 
 
 $(deriveFromJSON defaultOptions ''FunctionCall)

ihp-datasync/IHP/DataSync/DynamicQueryCompiler.hs

@@ -186,5 +186,6 @@ instance PG.ToField DynamicValue where
     toField (UUIDValue uuid) = PG.toField uuid
     toField (DateTimeValue utcTime) = PG.toField utcTime
     toField (PointValue point) = PG.toField point
+    toField (IntervalValue interval) = PG.toField interval
     toField (ArrayValue values) = PG.toField (PG.PGArray values)
     toField Null = PG.toField PG.Null

ihp-datasync/IHP/DataSync/REST/Controller.hs

@@ -87,14 +87,15 @@ instance (
                 result :: [[Field]] <- sqlQueryWithRLS query params
                 renderJson result
 
-
+            _ -> error "Expected JSON object or array"
 
     action UpdateRecordAction { table, id } = do
         ensureRLSEnabled table
 
         let payload = requestBodyJSON
                 |> \case
                     Object hashMap -> hashMap
+                    _ -> error "Expected JSON object"
 
         let columns = payload
                 |> Aeson.keys
@@ -147,6 +148,9 @@ instance (
 
         renderJson result
 
+    action GraphQLQueryAction = do
+        error "GraphQLQueryAction is handled by the GraphQL middleware"
+
 buildDynamicQueryFromRequest table = DynamicSQLQuery
     { table
     , selectedColumns = paramOrDefault SelectAll "fields"
@@ -170,6 +174,7 @@ instance ParamReader OrderByClause where
                 orderByDirection <- parseOrder order
                 pure OrderByClause { orderByColumn, orderByDirection }
             [orderByColumn] -> pure OrderByClause { orderByColumn, orderByDirection = Asc }
+            _ -> Left "Invalid order by clause"
         where
             parseOrder "asc" = Right Asc
             parseOrder "desc" = Right Desc
@@ -184,10 +189,15 @@ instance ToJSON PG.SqlError where
                 ]
         where
             fieldValueToJSON (IntValue value) = toJSON value
+            fieldValueToJSON (DoubleValue value) = toJSON value
             fieldValueToJSON (TextValue value) = toJSON value
             fieldValueToJSON (BoolValue value) = toJSON value
             fieldValueToJSON (UUIDValue value) = toJSON value
             fieldValueToJSON (DateTimeValue value) = toJSON value
+            fieldValueToJSON (PointValue value) = toJSON value
+            fieldValueToJSON (IntervalValue value) = toJSON value
+            fieldValueToJSON (ArrayValue value) = toJSON value
+            fieldValueToJSON IHP.DataSync.DynamicQuery.Null = toJSON Data.Aeson.Null
 
 instance ToJSON EnhancedSqlError where
     toJSON EnhancedSqlError { sqlError } = toJSON sqlError

ihp-datasync/IHP/DataSync/REST/Routes.hs

@@ -30,12 +30,14 @@ instance CanRoute ApiController where
                     PATCH  -> pure UpdateRecordAction { table, id }
                     GET    -> pure ShowRecordAction { table, id }
                     DELETE -> pure DeleteRecordAction { table, id }
+                    _      -> error "updateOrDeleteRecordAction: unsupported method"
 
             listRecordsAction table = do
                 endOfInput
                 method <- getMethod
                 case method of
                     GET -> pure ListRecordsAction { table }
+                    _   -> error "listRecordsAction: unsupported method"
 
             crud = do
                 table <- parseText
@@ -47,4 +49,6 @@ instance HasPath ApiController where
     pathTo CreateRecordAction { table } = "/api/" <> table
     pathTo UpdateRecordAction { table, id } = "/api/" <> table <> "/" <> tshow id
     pathTo DeleteRecordAction { table, id } = "/api/" <> table <> "/" <> tshow id
+    pathTo ShowRecordAction { table, id } = "/api/" <> table <> "/" <> tshow id
+    pathTo ListRecordsAction { table } = "/api/" <> table
     pathTo GraphQLQueryAction = "/api/graphql"

ihp-datasync/ihp-datasync.cabal

@@ -89,6 +89,7 @@ common shared-properties
             -Wmissed-specialisations
             -Wall-missed-specialisations
             -Wno-ambiguous-fields
+            -Werror=incomplete-patterns
     else
         ghc-options:
             -fstatic-argument-transformation
@@ -102,6 +103,7 @@ common shared-properties
             -Wmissed-specialisations
             -Wall-missed-specialisations
             -Wno-ambiguous-fields
+            -Werror=incomplete-patterns
 
 library
     import: shared-properties