@@ -24,12 +24,14 @@
24module Backend where
24module Backend where
26import Control.Exception
26import Control.Exception
27+import Control.Applicative
27import Control.Concurrent
28import Control.Concurrent
28import Common.Api
29import Common.Api
29import Common.Schema
30import Common.Schema
30import Backend.Schema
31import Backend.Schema
31import Common.Route
32import Common.Route
32import qualified Data.Map.Monoidal as Map
33import qualified Data.Map.Monoidal as Map
33import Data.Pool
35import Data.Pool
34import Data.Semigroup
36import Data.Semigroup
35import Obelisk.Backend
37import Obelisk.Backend
@@ -59,6 +61,8 @@ import Database.Beam.Migrate.Simple
59import Database.Beam.Schema.Tables
61import Database.Beam.Schema.Tables
60import Database.PostgreSQL.Simple.Types
62import Database.PostgreSQL.Simple.Types
61import Control.Monad.Reader
63import Control.Monad.Reader
65+import Reflex.Patch.MapWithMove2
63import Data.Proxy
67import Data.Proxy
@@ -76,9 +80,9 @@ backend = Backend
76 withConnectionPool dbUri $ \pool -> do
80 withConnectionPool dbUri $ \pool -> do
77 withResource pool $ \conn -> do
81 withResource pool $ \conn -> do
78 try (runBeamPostgres conn $ autoMigrate migrationBackend checkedDb) >>= \case
82 try (runBeamPostgres conn $ autoMigrate migrationBackend checkedDb) >>= \case
79− Left (_ :: SomeException) -> do
83+ Left (e :: SomeException) -> do
80− putStrLn "Required migration is unsafe; refusing to start"
84+ print e
81− forever $ threadDelay maxBound
85+ forever $ threadDelay maxBound --TODO: Probably not necessary once we have `ob psql`
82 Right _ -> pure ()
86 Right _ -> pure ()
83 let onNotify :: forall a. VS (Id Task) Task a -> Transaction -> ReadDb (V (Id Task) Task a)
87 let onNotify :: forall a. VS (Id Task) Task a -> Transaction -> ReadDb (V (Id Task) Task a)
84 onNotify (VS requested) txn = do
88 onNotify (VS requested) txn = do
@@ -208,9 +212,9 @@ data FieldDecoder be a where
209data EntityPatch e where
213data EntityPatch e where
210 EntityPatch_NotPatchable :: EntityPatch e
214 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
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))
215deriving instance FromField a => FromField (SqlSerial a)
219deriving instance FromField a => FromField (SqlSerial a)
@@ -250,6 +254,32 @@ decodeRow conn settings decoders r = zipBeamFieldsM d settings decoders
250 Just (Errors e) -> fail $ show e
254 Just (Errors e) -> fail $ show e
251 Nothing -> pure $ Columnar' Nothing
255 Nothing -> pure $ Columnar' Nothing
257+sequenceMaybeBeamable :: (Beamable table, Applicative f, f ~ Maybe) => table f -> f (table Identity)
258+sequenceMaybeBeamable t = zipBeamFieldsM (\(Columnar' a) _ -> Columnar' <$> a) t t
260+newtype PartialUpdate tbl = PartialUpdate (tbl Maybe)
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
266+theseToPatch :: Table tbl => These (Maybe (PrimaryKey tbl Identity)) (tbl Maybe) -> PatchMapWithMove2 (PrimaryKey tbl Identity) (PartialUpdate tbl)
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
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
282+--TODO: Inserts should always be complete; deletes should always have a key
253decodeChange
283decodeChange
254 :: forall tbl
284 :: forall tbl
255 . Table tbl
285 . Table tbl
@@ -257,11 +287,22 @@ decodeChange
257 -> tbl (TableField tbl)
287 -> tbl (TableField tbl)
258 -> tbl (FieldDecoder Postgres)
288 -> tbl (FieldDecoder Postgres)
259 -> Change
289 -> Change
260− -> IO (These (PrimaryKey tbl Maybe) (tbl Maybe))
290+ -> IO (These (Maybe (PrimaryKey tbl Identity)) (tbl Maybe))
261−decodeChange conn settings decoders = \case
291+decodeChange conn settings decoders =
292+ let decodeRecord = decodeRow conn settings decoders
294+ v <- decodeRow conn (primaryKey settings) (primaryKey decoders) (fmap (fmap Just) k)
295+ case sequenceMaybeBeamable v of
296+ Nothing -> fail "Got partial key"
262− Change_Insert r -> That <$> decodeRow conn settings decoders r
299+ Change_Insert r -> That
263− Change_Update k r -> These <$> decodeRow conn (primaryKey settings) (primaryKey decoders) (fmap (fmap Just) k) <*> decodeRow conn settings decoders r
300+ <$> decodeRecord r
264− Change_Delete k -> This <$> decodeRow conn (primaryKey settings) (primaryKey decoders) (fmap (fmap Just) k)
301+ Change_Update mk r -> These
302+ <$> traverse decodeKey mk
304+ Change_Delete k -> This . Just
266decodeTransaction :: Connection -> Transaction -> IO (Db EntityPatch)
307decodeTransaction :: Connection -> Transaction -> IO (Db EntityPatch)
267decodeTransaction conn (_, tableChanges) = zipTables (Proxy :: Proxy Postgres) f db (defaultDatabasePatchDecoder @Postgres @Db)
308decodeTransaction conn (_, tableChanges) = zipTables (Proxy :: Proxy Postgres) f db (defaultDatabasePatchDecoder @Postgres @Db)