1e4bd98 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Decode transactions into patches

1e4bd98Ryan Trinkle8 years ago

skeleton/backend/src/Backend.hs+38−30

compare with master

unifiedsplit

@@ -30,6 +30,7 @@ import Common.Api

30import Common.Schema

31import Backend.Schema

32import Common.Route

33+import Data.Foldable

33import qualified Data.Map.Monoidal as Map

34import qualified Data.Map.Monoidal as Map

34import Data.Maybe

35import Data.Maybe

35import Data.Pool

36import Data.Pool

@@ -40,8 +41,6 @@ import Obelisk.Api

40import Obelisk.Db

41import Obelisk.Db

41import Obelisk.Postgres.LogicalDecoding.Plugins.TestDecoding

42import Obelisk.Postgres.LogicalDecoding.Plugins.TestDecoding

42import qualified Data.Map as OldMap

43import qualified Data.Map as OldMap

43−import Data.Sequence (Seq)

44−import Data.These

45import Data.Text.Encoding

44import Data.Text.Encoding

46import Data.HashMap.Strict (HashMap)

45import Data.HashMap.Strict (HashMap)

47import qualified Data.HashMap.Strict as HashMap

46import qualified Data.HashMap.Strict as HashMap

@@ -189,6 +188,8 @@ to' = Generic.to

189instance ( Generic (tbl (FieldDecoder be))

188instance ( Generic (tbl (FieldDecoder be))

190 , GPatchFields (Rep (tbl (FieldDecoder be)) ())

189 , GPatchFields (Rep (tbl (FieldDecoder be)) ())

191 , Table tbl

190 , Table tbl

191+ , Ord (PrimaryKey tbl Identity)

192+ , Eq (tbl Maybe)

192 ) => PatchEntity be (TableEntity tbl) where

193 ) => PatchEntity be (TableEntity tbl) where

193 patchEntity = EntityPatchDecoder_Table $ to' gPatchFields

194 patchEntity = EntityPatchDecoder_Table $ to' gPatchFields

194

195

@@ -205,16 +206,16 @@ class PatchableEntity be e where

205

206

206data EntityPatchDecoder be e where

207data EntityPatchDecoder be e where

207 EntityPatchDecoder_NotDecodable :: EntityPatchDecoder be e

208 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)

209

210

210data FieldDecoder be a where

211data FieldDecoder be a where

211 FieldDecoder :: BackendFromField be a => FieldDecoder be a

212 FieldDecoder :: BackendFromField be a => FieldDecoder be a

212

213

213data EntityPatch e where

214data EntityPatch e where

214 EntityPatch_NotPatchable :: EntityPatch e

215 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)

216

217

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))

218

219

219deriving instance FromField a => FromField (SqlSerial a)

220deriving instance FromField a => FromField (SqlSerial a)

220

221

@@ -259,26 +260,20 @@ sequenceMaybeBeamable t = zipBeamFieldsM (\(Columnar' a) _ -> Columnar' <$> a) t

259

260

260newtype PartialUpdate tbl = PartialUpdate (tbl Maybe)

261newtype PartialUpdate tbl = PartialUpdate (tbl Maybe)

261

262

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+

262instance Beamable tbl => Patch (PartialUpdate tbl) where

273instance Beamable tbl => Patch (PartialUpdate tbl) where

263 type PatchTarget (PartialUpdate tbl) = tbl Identity

274 type PatchTarget (PartialUpdate tbl) = tbl Identity

264 apply (PartialUpdate new) old = zipBeamFieldsM (\(Columnar' newField) (Columnar' oldField) -> pure $ Columnar' $ fromMaybe oldField newField) new old

275 apply (PartialUpdate new) old = zipBeamFieldsM (\(Columnar' newField) (Columnar' oldField) -> pure $ Columnar' $ fromMaybe oldField newField) new old

265

276

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

277--TODO: Inserts should always be complete; deletes should always have a key

283decodeChange

278decodeChange

284 :: forall tbl

279 :: forall tbl

@@ -287,7 +282,7 @@ decodeChange

287 -> tbl (TableField tbl)

282 -> tbl (TableField tbl)

288 -> tbl (FieldDecoder Postgres)

283 -> tbl (FieldDecoder Postgres)

289 -> Change

284 -> Change

290− -> IO (These (Maybe (PrimaryKey tbl Identity)) (tbl Maybe))

285+ -> IO (PatchMapWithMove2 (PrimaryKey tbl Identity) (PartialUpdate tbl))

291decodeChange conn settings decoders =

286decodeChange conn settings decoders =

292 let decodeRecord = decodeRow conn settings decoders

287 let decodeRecord = decodeRow conn settings decoders

293 decodeKey k = do

288 decodeKey k = do

@@ -296,13 +291,26 @@ decodeChange conn settings decoders =

296 Nothing -> fail "Got partial key"

291 Nothing -> fail "Got partial key"

297 Just a -> pure a

292 Just a -> pure a

298 in \case

293 in \case

299− Change_Insert r -> That

294+ Change_Insert rRaw -> do

300− <$> decodeRecord r

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

301− Change_Update mk r -> These

299+ Change_Update mkRaw rRaw -> do

302− <$> traverse decodeKey mk

300+ mk <- traverse decodeKey mkRaw

303− <*> decodeRecord r

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+ }

304− Change_Delete k -> This . Just

308+ Change_Delete kRaw -> do

305− <$> decodeKey k

309+ k <- decodeKey kRaw

310+ pure $ PatchMapWithMove2 $ OldMap.singleton k $ NodeInfo

311+ { _nodeInfo_from = From_Delete

312+ , _nodeInfo_to = Nothing

313+ }

306

314

307decodeTransaction :: Connection -> Transaction -> IO (Db EntityPatch)

315decodeTransaction :: Connection -> Transaction -> IO (Db EntityPatch)

308decodeTransaction conn (_, tableChanges) = zipTables (Proxy :: Proxy Postgres) f db (defaultDatabasePatchDecoder @Postgres @Db)

316decodeTransaction conn (_, tableChanges) = zipTables (Proxy :: Proxy Postgres) f db (defaultDatabasePatchDecoder @Postgres @Db)

@@ -315,5 +323,5 @@ decodeTransaction conn (_, tableChanges) = zipTables (Proxy :: Proxy Postgres) f

315 x :: IO (EntityPatch entityType)

323 x :: IO (EntityPatch entityType)

316 x = case decoder of

324 x = case decoder of

317 EntityPatchDecoder_NotDecodable -> pure EntityPatch_NotPatchable

325 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

319 in x

327 in x

skeleton/common/src/Common/Schema.hs+3−2

@@ -26,8 +26,9 @@ data TaskT f = Task

26type Task = TaskT Identity

28deriving instance (Show (Columnar f (SqlSerial Int64)), Show (Columnar f Text), Show (Columnar f Bool)) => Show (TaskT f)

29−

29+deriving instance (Read (Columnar f (SqlSerial Int64)), Read (Columnar f Text), Read (Columnar f Bool)) => Read (TaskT f)

30−deriving instance Eq Task

30+deriving instance (Eq (Columnar f (SqlSerial Int64)), Eq (Columnar f Text), Eq (Columnar f Bool)) => Eq (TaskT f)

31+deriving instance (Ord (Columnar f (SqlSerial Int64)), Ord (Columnar f Text), Ord (Columnar f Bool)) => Ord (TaskT f)

32instance Beamable TaskT

33instance Beamable TaskT