@@ -24,12 +24,14 @@
2424module Backend where
2525
2626import Control.Exception
27+import Control.Applicative
2728import Control.Concurrent
2829import Common.Api
2930import Common.Schema
3031import Backend.Schema
3132import Common.Route
3233import qualified Data.Map.Monoidal as Map
34+import Data.Maybe
3335import Data.Pool
3436import Data.Semigroup
3537import Obelisk.Backend
@@ -59,6 +61,8 @@ import Database.Beam.Migrate.Simple
5961import Database.Beam.Schema.Tables
6062import Database.PostgreSQL.Simple.Types
6163import Control.Monad.Reader
64+import Reflex.Patch
65+import Reflex.Patch.MapWithMove2
6266
6367import Data.Proxy
6468
@@ -76,9 +80,9 @@ backend = Backend
7680 withConnectionPool dbUri $ \pool -> do
7781 withResource pool $ \conn -> do
7882 try (runBeamPostgres conn $ autoMigrate migrationBackend checkedDb) >>= \case
79− Left (_ :: SomeException) -> do
80− putStrLn "Required migration is unsafe; refusing to start"
81− forever $ threadDelay maxBound
83+ Left (e :: SomeException) -> do
84+ print e
85+ forever $ threadDelay maxBound --TODO: Probably not necessary once we have `ob psql`
8286 Right _ -> pure ()
8387 let onNotify :: forall a. VS (Id Task) Task a -> Transaction -> ReadDb (V (Id Task) Task a)
8488 onNotify (VS requested) txn = do
@@ -208,9 +212,9 @@ data FieldDecoder be a where
208212
209213data EntityPatch e where
210214 EntityPatch_NotPatchable :: EntityPatch e
211− EntityPatch_Table :: Seq (These (PrimaryKey tbl Maybe) (tbl Maybe)) -> EntityPatch (TableEntity tbl) --TODO: Add old keys / deletes
215+ EntityPatch_Table :: Seq (These (Maybe (PrimaryKey tbl Identity)) (tbl Maybe)) -> EntityPatch (TableEntity tbl) --TODO: Add old keys / deletes
212216
213−deriving instance (Show (PrimaryKey tbl Maybe), Show (tbl Maybe)) => Show (EntityPatch (TableEntity tbl))
217+deriving instance (Show (PrimaryKey tbl Identity), Show (tbl Maybe)) => Show (EntityPatch (TableEntity tbl))
214218
215219deriving instance FromField a => FromField (SqlSerial a)
216220
@@ -250,6 +254,32 @@ decodeRow conn settings decoders r = zipBeamFieldsM d settings decoders
250254 Just (Errors e) -> fail $ show e
251255 Nothing -> pure $ Columnar' Nothing
252256
257+sequenceMaybeBeamable :: (Beamable table, Applicative f, f ~ Maybe) => table f -> f (table Identity)
258+sequenceMaybeBeamable t = zipBeamFieldsM (\(Columnar' a) _ -> Columnar' <$> a) t t
259+
260+newtype PartialUpdate tbl = PartialUpdate (tbl Maybe)
261+
262+instance Beamable tbl => Patch (PartialUpdate tbl) where
263+ type PatchTarget (PartialUpdate tbl) = tbl Identity
264+ apply (PartialUpdate new) old = zipBeamFieldsM (\(Columnar' newField) (Columnar' oldField) -> pure $ Columnar' $ fromMaybe oldField newField) new old
265+
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+
282+--TODO: Inserts should always be complete; deletes should always have a key
253283decodeChange
254284 :: forall tbl
255285 . Table tbl
@@ -257,11 +287,22 @@ decodeChange
257287 -> tbl (TableField tbl)
258288 -> tbl (FieldDecoder Postgres)
259289 -> Change
260− -> IO (These (PrimaryKey tbl Maybe) (tbl Maybe))
261−decodeChange conn settings decoders = \case
262− Change_Insert r -> That <$> decodeRow conn settings decoders r
263− Change_Update k r -> These <$> decodeRow conn (primaryKey settings) (primaryKey decoders) (fmap (fmap Just) k) <*> decodeRow conn settings decoders r
264− Change_Delete k -> This <$> decodeRow conn (primaryKey settings) (primaryKey decoders) (fmap (fmap Just) k)
290+ -> IO (These (Maybe (PrimaryKey tbl Identity)) (tbl Maybe))
291+decodeChange conn settings decoders =
292+ let decodeRecord = decodeRow conn settings decoders
293+ decodeKey k = do
294+ v <- decodeRow conn (primaryKey settings) (primaryKey decoders) (fmap (fmap Just) k)
295+ case sequenceMaybeBeamable v of
296+ Nothing -> fail "Got partial key"
297+ Just a -> pure a
298+ 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
265306
266307decodeTransaction :: Connection -> Transaction -> IO (Db EntityPatch)
267308decodeTransaction conn (_, tableChanges) = zipTables (Proxy :: Proxy Postgres) f db (defaultDatabasePatchDecoder @Postgres @Db)