git.iko.soy/obelisk
on master help sign in
Flesh out the examples a bit more
commit485d583074dd87e19429528f88b181fbaa89dcc0 authorRyan Trinkle <ryan.trinkle@gmail.com> dateWed 28 Nov 2018, 15:52 (8 years ago) parent1e4bd98
2 files changed+85−23
compare with master
unifiedsplit
skeleton/backend/src/Backend.hs+36−15 skeleton/common/src/Common/Schema.hs+49−8
skeleton/backend/src/Backend.hs+36−15
@@ -85,11 +85,11 @@ backend = Backend
8585 Right _ -> pure ()
8686 let onNotify :: forall a. VS (Id Task) Task a -> Transaction -> ReadDb (V (Id Task) Task a)
8787 onNotify (VS requested) txn = do
88− traceM "Hello"
8988 decoded <- ReadDb $ do
9089 conn <- ask
9190 lift $ decodeTransaction conn txn
9291 traceM $ show $ _db_tasks decoded
92+ traceM $ show $ _db_users decoded
9393 tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db
9494 pure $ V $ Map.intersectionWith (,) requested $ Map.fromList $ fmap (\x -> (TaskId $ _task_id x, First $ Just x)) tasks
9595 onSubscribe :: forall a. VS (Id Task) Task a -> ReadDb (V (Id Task) Task a)
@@ -103,6 +103,7 @@ backend = Backend
103103 { _task_id = default_
104104 , _task_description = val_ a
105105 , _task_completed = val_ False
106+ , _task_assignee = val_ undefined
106107 }
107108 pure $ TaskId taskId
108109 withApiHandler dbUri onRequest onNotify onSubscribe $ \handler -> do
@@ -159,22 +160,42 @@ instance (GPatchDatabase (x p), GPatchDatabase (y p)) => GPatchDatabase ((x :*:
159160 gDatabasePatchDecoder = gDatabasePatchDecoder :*: gDatabasePatchDecoder
160161
161162instance PatchEntity be a => GPatchDatabase (S1 f (K1 Generic.R (EntityPatchDecoder be a)) p) where
162− gDatabasePatchDecoder = M1 (K1 patchEntity)
163+ gDatabasePatchDecoder = M1 $ K1 patchEntity
163164
164−class GPatchFields x where
165− gPatchFields :: x
165+type family FieldPatches be x where
166+ FieldPatches be (D1 f x) = D1 f (FieldPatches be x)
167+ FieldPatches be (C1 f x) = C1 f (FieldPatches be x)
168+ FieldPatches be (x :*: y) = FieldPatches be x :*: FieldPatches be y
169+ FieldPatches be (S1 f (K1 Generic.R (Exposed a))) = S1 f (K1 Generic.R (FieldDecoder be a))
170+ FieldPatches be (S1 f (K1 Generic.R (tbl Exposed))) = S1 f (K1 Generic.R (tbl (FieldDecoder be)))
171+ FieldPatches be (S1 f (K1 Generic.R (tbl (Nullable Exposed)))) = S1 f (K1 Generic.R (tbl (Nullable (FieldDecoder be))))
166172
167−instance GPatchFields (x p) => GPatchFields (D1 f x p) where
168− gPatchFields = M1 gPatchFields
173+class GPatchFields be exposedRep where
174+ gPatchFields :: FieldPatches be exposedRep ()
169175
170−instance GPatchFields (x p) => GPatchFields (C1 f x p) where
171− gPatchFields = M1 gPatchFields
176+instance GPatchFields be x => GPatchFields be (D1 f x) where
177+ gPatchFields = M1 $ gPatchFields @be @x
172178
173−instance (GPatchFields (x p), GPatchFields (y p)) => GPatchFields ((x :*: y) p) where
174− gPatchFields = gPatchFields :*: gPatchFields
179+instance GPatchFields be x => GPatchFields be (C1 f x) where
180+ gPatchFields = M1 $ gPatchFields @be @x
175181
176−instance BackendFromField be a => GPatchFields (S1 f (K1 Generic.R (FieldDecoder be a)) p) where
177− gPatchFields = M1 (K1 FieldDecoder)
182+instance (GPatchFields be x, GPatchFields be y) => GPatchFields be (x :*: y) where
183+ gPatchFields = gPatchFields @be @x :*: gPatchFields @be @y
184+
185+instance BackendFromField be a => GPatchFields be (S1 f (K1 Generic.R (Exposed a))) where
186+ gPatchFields = M1 $ K1 FieldDecoder
187+
188+instance ( GPatchFields be (Rep (tbl Exposed))
189+ , FieldPatches be (Rep (tbl Exposed)) ~ Rep (tbl (FieldDecoder be))
190+ , Generic (tbl (FieldDecoder be))
191+ ) => GPatchFields be (S1 f (K1 Generic.R (tbl Exposed))) where
192+ gPatchFields = M1 $ K1 $ to' $ gPatchFields @be @(Rep (tbl Exposed))
193+
194+instance ( GPatchFields be (Rep (tbl (Nullable Exposed)))
195+ , FieldPatches be (Rep (tbl (Nullable Exposed))) ~ Rep (tbl (Nullable (FieldDecoder be)))
196+ , Generic (tbl (Nullable (FieldDecoder be)))
197+ ) => GPatchFields be (S1 f (K1 Generic.R (tbl (Nullable Exposed)))) where
198+ gPatchFields = M1 $ K1 $ to' $ gPatchFields @be @(Rep (tbl (Nullable Exposed)))
178199
179200class PatchEntity be e where
180201 patchEntity :: EntityPatchDecoder be e
@@ -186,12 +207,13 @@ to' :: Generic x => Rep x () -> x
186207to' = Generic.to
187208
188209instance ( Generic (tbl (FieldDecoder be))
189− , GPatchFields (Rep (tbl (FieldDecoder be)) ())
210+ , GPatchFields be (Rep (tbl Exposed))
211+ , FieldPatches be (Rep (tbl Exposed)) ~ Rep (tbl (FieldDecoder be))
190212 , Table tbl
191213 , Ord (PrimaryKey tbl Identity)
192214 , Eq (tbl Maybe)
193215 ) => PatchEntity be (TableEntity tbl) where
194− patchEntity = EntityPatchDecoder_Table $ to' gPatchFields
216+ patchEntity = EntityPatchDecoder_Table $ to' $ gPatchFields @be @(Rep (tbl Exposed))
195217
196218defaultDatabasePatchDecoder
197219 :: forall be db
@@ -274,7 +296,6 @@ instance Beamable tbl => Patch (PartialUpdate tbl) where
274296 type PatchTarget (PartialUpdate tbl) = tbl Identity
275297 apply (PartialUpdate new) old = zipBeamFieldsM (\(Columnar' newField) (Columnar' oldField) -> pure $ Columnar' $ fromMaybe oldField newField) new old
276298
277−--TODO: Inserts should always be complete; deletes should always have a key
278299decodeChange
279300 :: forall tbl
280301 . Table tbl
skeleton/common/src/Common/Schema.hs+49−8
@@ -1,4 +1,6 @@
11{-# LANGUAGE StandaloneDeriving #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
24{-# LANGUAGE GeneralizedNewtypeDeriving #-}
35{-# LANGUAGE UndecidableInstances #-}
46{-# LANGUAGE ScopedTypeVariables #-}
@@ -12,6 +14,7 @@
1214module Common.Schema where
1315
1416import Data.Aeson
17+import Data.Constraint
1518import Data.Int
1619import Data.Text (Text)
1720import Database.Beam
@@ -21,14 +24,17 @@ data TaskT f = Task
2124 { _task_id :: Columnar f (SqlSerial Int64)
2225 , _task_description :: Columnar f Text
2326 , _task_completed :: Columnar f Bool
27+ , _task_assignee :: PrimaryKey UserT (Nullable f)
2428 }
2529 deriving (Generic)
2630type Task = TaskT Identity
2731
28−deriving instance (Show (Columnar f (SqlSerial Int64)), Show (Columnar f Text), Show (Columnar f Bool)) => Show (TaskT f)
29−deriving instance (Read (Columnar f (SqlSerial Int64)), Read (Columnar f Text), Read (Columnar f Bool)) => Read (TaskT f)
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)
32+type AllTaskColumns (c :: * -> Constraint) f = (c (Columnar f (SqlSerial Int64)), c (Columnar f Text), c (Columnar f Bool), c (PrimaryKey UserT (Nullable f)))
33+
34+deriving instance AllTaskColumns Show f => Show (TaskT f)
35+deriving instance AllTaskColumns Read f => Read (TaskT f)
36+deriving instance AllTaskColumns Eq f => Eq (TaskT f)
37+deriving instance AllTaskColumns Ord f => Ord (TaskT f)
3238
3339instance Beamable TaskT
3440
@@ -39,9 +45,6 @@ instance Table TaskT where
3945
4046deriving instance Show (Columnar f (SqlSerial Int64)) => Show (PrimaryKey TaskT f)
4147
42−deriving instance ToJSONKey a => ToJSONKey (SqlSerial a)
43−deriving instance FromJSONKey a => FromJSONKey (SqlSerial a)
44−
4548deriving instance Eq (PrimaryKey TaskT Identity)
4649deriving instance Ord (PrimaryKey TaskT Identity)
4750deriving instance ToJSON (PrimaryKey TaskT Identity)
@@ -53,9 +56,47 @@ instance FromJSON (TaskT Identity)
5356
5457instance Beamable (PrimaryKey TaskT)
5558
59+data UserT f = User
60+ { _user_id :: Columnar f (SqlSerial Int64)
61+ , _user_name :: Columnar f Text
62+ }
63+ deriving (Generic)
64+type User = UserT Identity
65+
66+type AllUserColumns (c :: * -> Constraint) f = (c (Columnar f (SqlSerial Int64)), c (Columnar f Text))
67+
68+deriving instance AllUserColumns Show f => Show (UserT f)
69+deriving instance AllUserColumns Read f => Read (UserT f)
70+deriving instance AllUserColumns Eq f => Eq (UserT f)
71+deriving instance AllUserColumns Ord f => Ord (UserT f)
72+
73+instance Beamable UserT
74+
75+instance Table UserT where
76+ newtype PrimaryKey UserT f = UserId (Columnar f (SqlSerial Int64))
77+ deriving (Generic)
78+ primaryKey = UserId . _user_id
79+
80+deriving instance Show (Columnar f (SqlSerial Int64)) => Show (PrimaryKey UserT f)
81+
82+deriving instance Eq (Columnar f (SqlSerial Int64)) => Eq (PrimaryKey UserT f)
83+deriving instance Ord (Columnar f (SqlSerial Int64)) => Ord (PrimaryKey UserT f)
84+deriving instance ToJSON (Columnar f (SqlSerial Int64)) => ToJSON (PrimaryKey UserT f)
85+deriving instance FromJSON (Columnar f (SqlSerial Int64)) => FromJSON (PrimaryKey UserT f)
86+deriving instance ToJSONKey (Columnar f (SqlSerial Int64)) => ToJSONKey (PrimaryKey UserT f)
87+deriving instance FromJSONKey (Columnar f (SqlSerial Int64)) => FromJSONKey (PrimaryKey UserT f)
88+instance ToJSON (UserT Identity)
89+instance FromJSON (UserT Identity)
90+
91+instance Beamable (PrimaryKey UserT)
92+
93+deriving instance ToJSONKey a => ToJSONKey (SqlSerial a)
94+deriving instance FromJSONKey a => FromJSONKey (SqlSerial a)
95+
5696data Db f = Db
5797 { _db_tasks :: f (TableEntity TaskT)
98+ , _db_users :: f (TableEntity UserT)
5899 }
59100 deriving (Generic)
60101
61−deriving instance Show (f (TableEntity TaskT)) => Show (Db f)
102+deriving instance (Show (f (TableEntity TaskT)), Show (f (TableEntity UserT))) => Show (Db f)