@@ -30,6 +30,7 @@ import Common.Api
3030import Common.Schema
3131import Backend.Schema
3232import Common.Route
33+import Data.Foldable
3334import qualified Data.Map.Monoidal as Map
3435import Data.Maybe
3536import Data.Pool
@@ -40,8 +41,6 @@ import Obelisk.Api
4041import Obelisk.Db
4142import Obelisk.Postgres.LogicalDecoding.Plugins.TestDecoding
4243import qualified Data.Map as OldMap
43−import Data.Sequence (Seq)
44−import Data.These
4544import Data.Text.Encoding
4645import Data.HashMap.Strict (HashMap)
4746import qualified Data.HashMap.Strict as HashMap
@@ -189,6 +188,8 @@ to' = Generic.to
189188instance ( Generic (tbl (FieldDecoder be))
190189 , GPatchFields (Rep (tbl (FieldDecoder be)) ())
191190 , Table tbl
191+ , Ord (PrimaryKey tbl Identity)
192+ , Eq (tbl Maybe)
192193 ) => PatchEntity be (TableEntity tbl) where
193194 patchEntity = EntityPatchDecoder_Table $ to' gPatchFields
194195
@@ -205,16 +206,16 @@ class PatchableEntity be e where
205206
206207data EntityPatchDecoder be e where
207208 EntityPatchDecoder_NotDecodable :: EntityPatchDecoder be e
208− EntityPatchDecoder_Table :: Table tbl => tbl (FieldDecoder be) -> EntityPatchDecoder be (TableEntity tbl)
209+ EntityPatchDecoder_Table :: (Table tbl, Ord (PrimaryKey tbl Identity), Eq (tbl Maybe)) => tbl (FieldDecoder be) -> EntityPatchDecoder be (TableEntity tbl)
209210
210211data FieldDecoder be a where
211212 FieldDecoder :: BackendFromField be a => FieldDecoder be a
212213
213214data EntityPatch e where
214215 EntityPatch_NotPatchable :: EntityPatch e
215− EntityPatch_Table :: Seq (These (Maybe (PrimaryKey tbl Identity)) (tbl Maybe)) -> EntityPatch (TableEntity tbl) --TODO: Add old keys / deletes
216+ EntityPatch_Table :: PatchMapWithMove2 (PrimaryKey tbl Identity) (PartialUpdate tbl) -> EntityPatch (TableEntity tbl)
216217
217−deriving instance (Show (PrimaryKey tbl Identity), Show (tbl Maybe)) => Show (EntityPatch (TableEntity tbl))
218+deriving instance (Show (PrimaryKey tbl Identity), Show (tbl Maybe), Show (tbl Identity)) => Show (EntityPatch (TableEntity tbl))
218219
219220deriving instance FromField a => FromField (SqlSerial a)
220221
@@ -259,26 +260,20 @@ sequenceMaybeBeamable t = zipBeamFieldsM (\(Columnar' a) _ -> Columnar' <$> a) t
259260
260261newtype PartialUpdate tbl = PartialUpdate (tbl Maybe)
261262
263+instance Beamable tbl => Semigroup (PartialUpdate tbl) where
264+ PartialUpdate a <> PartialUpdate b = PartialUpdate $ runIdentity $ zipBeamFieldsM (\(Columnar' x) (Columnar' y) -> pure $ Columnar' $ x <|> y) a b
265+
266+instance Beamable tbl => Monoid (PartialUpdate tbl) where
267+ mempty = PartialUpdate $ runIdentity $ zipBeamFieldsM (\_ _ -> pure $ Columnar' Nothing) tblSkeleton tblSkeleton
268+ mappend = (<>)
269+
270+deriving instance Show (tbl Maybe) => Show (PartialUpdate tbl)
271+deriving instance Eq (tbl Maybe) => Eq (PartialUpdate tbl)
272+
262273instance Beamable tbl => Patch (PartialUpdate tbl) where
263274 type PatchTarget (PartialUpdate tbl) = tbl Identity
264275 apply (PartialUpdate new) old = zipBeamFieldsM (\(Columnar' newField) (Columnar' oldField) -> pure $ Columnar' $ fromMaybe oldField newField) new old
265276
266−theseToPatch :: Table tbl => These (Maybe (PrimaryKey tbl Identity)) (tbl Maybe) -> PatchMapWithMove2 (PrimaryKey tbl Identity) (PartialUpdate tbl)
267−theseToPatch = \case
268− That rm
269− | Just r <- sequenceMaybeBeamable rm
270− -> patchMapWithMove2InsertAll $ OldMap.singleton (primaryKey r) r
271− | otherwise -> error "Incomplete insert"
272− This Nothing -> error "Incomplete delete"
273− This (Just k) -> PatchMapWithMove2 $ OldMap.singleton k $ NodeInfo
274− { _nodeInfo_from = From_Delete
275− , _nodeInfo_to = Nothing
276− }
277− These mk vm -> let k = fromMaybe (error "Update without key") $ mk <|> sequenceMaybeBeamable (primaryKey vm) in PatchMapWithMove2 $ OldMap.singleton k $ NodeInfo
278− { _nodeInfo_from = From_Move k $ PartialUpdate vm
279− , _nodeInfo_to = Nothing
280− }
281−
282277--TODO: Inserts should always be complete; deletes should always have a key
283278decodeChange
284279 :: forall tbl
@@ -287,7 +282,7 @@ decodeChange
287282 -> tbl (TableField tbl)
288283 -> tbl (FieldDecoder Postgres)
289284 -> Change
290− -> IO (These (Maybe (PrimaryKey tbl Identity)) (tbl Maybe))
285+ -> IO (PatchMapWithMove2 (PrimaryKey tbl Identity) (PartialUpdate tbl))
291286decodeChange conn settings decoders =
292287 let decodeRecord = decodeRow conn settings decoders
293288 decodeKey k = do
@@ -296,13 +291,26 @@ decodeChange conn settings decoders =
296291 Nothing -> fail "Got partial key"
297292 Just a -> pure a
298293 in \case
299− Change_Insert r -> That
300− <$> decodeRecord r
301− Change_Update mk r -> These
302− <$> traverse decodeKey mk
303− <*> decodeRecord r
304− Change_Delete k -> This . Just
305− <$> decodeKey k
294+ Change_Insert rRaw -> do
295+ rm <- decodeRecord rRaw
296+ case sequenceMaybeBeamable rm of
297+ Nothing -> fail "Insert got partial row"
298+ Just r -> pure $ patchMapWithMove2InsertAll $ OldMap.singleton (primaryKey r) r
299+ Change_Update mkRaw rRaw -> do
300+ mk <- traverse decodeKey mkRaw
301+ vm <- decodeRecord rRaw
302+ case mk <|> sequenceMaybeBeamable (primaryKey vm) of
303+ Nothing -> fail "Update with no key"
304+ Just k -> pure $ PatchMapWithMove2 $ OldMap.singleton k $ NodeInfo
305+ { _nodeInfo_from = From_Move k $ PartialUpdate vm
306+ , _nodeInfo_to = Just k
307+ }
308+ Change_Delete kRaw -> do
309+ k <- decodeKey kRaw
310+ pure $ PatchMapWithMove2 $ OldMap.singleton k $ NodeInfo
311+ { _nodeInfo_from = From_Delete
312+ , _nodeInfo_to = Nothing
313+ }
306314
307315decodeTransaction :: Connection -> Transaction -> IO (Db EntityPatch)
308316decodeTransaction conn (_, tableChanges) = zipTables (Proxy :: Proxy Postgres) f db (defaultDatabasePatchDecoder @Postgres @Db)
@@ -315,5 +323,5 @@ decodeTransaction conn (_, tableChanges) = zipTables (Proxy :: Proxy Postgres) f
315323 x :: IO (EntityPatch entityType)
316324 x = case decoder of
317325 EntityPatchDecoder_NotDecodable -> pure EntityPatch_NotPatchable
318− EntityPatchDecoder_Table decoders -> EntityPatch_Table <$> traverse (decodeChange conn (dbTableSettings descriptor) decoders) vals
326+ EntityPatchDecoder_Table decoders -> EntityPatch_Table . mconcat . toList <$> traverse (decodeChange conn (dbTableSettings descriptor) decoders) vals
319327 in x