485d583 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Flesh out the examples a bit more

485d583Ryan Trinkle8 years ago

skeleton/backend/src/Backend.hs+36−15

compare with master

unifiedsplit

@@ -85,11 +85,11 @@ backend = Backend

85 Right _ -> pure ()

86 let onNotify :: forall a. VS (Id Task) Task a -> Transaction -> ReadDb (V (Id Task) Task a)

87 onNotify (VS requested) txn = do

88− traceM "Hello"

89 decoded <- ReadDb $ do

88 decoded <- ReadDb $ do

90 conn <- ask

89 conn <- ask

91 lift $ decodeTransaction conn txn

90 lift $ decodeTransaction conn txn

92 traceM $ show $ _db_tasks decoded

91 traceM $ show $ _db_tasks decoded

92+ traceM $ show $ _db_users decoded

93 tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db

94 pure $ V $ Map.intersectionWith (,) requested $ Map.fromList $ fmap (\x -> (TaskId $ _task_id x, First $ Just x)) tasks

95 onSubscribe :: forall a. VS (Id Task) Task a -> ReadDb (V (Id Task) Task a)

@@ -103,6 +103,7 @@ backend = Backend

103 { _task_id = default_

104 , _task_description = val_ a

105 , _task_completed = val_ False

106+ , _task_assignee = val_ undefined

106 }

107 }

107 pure $ TaskId taskId

108 pure $ TaskId taskId

108 withApiHandler dbUri onRequest onNotify onSubscribe $ \handler -> do

109 withApiHandler dbUri onRequest onNotify onSubscribe $ \handler -> do

@@ -159,22 +160,42 @@ instance (GPatchDatabase (x p), GPatchDatabase (y p)) => GPatchDatabase ((x :*:

159 gDatabasePatchDecoder = gDatabasePatchDecoder :*: gDatabasePatchDecoder

160 gDatabasePatchDecoder = gDatabasePatchDecoder :*: gDatabasePatchDecoder

160

161

161instance PatchEntity be a => GPatchDatabase (S1 f (K1 Generic.R (EntityPatchDecoder be a)) p) where

162instance PatchEntity be a => GPatchDatabase (S1 f (K1 Generic.R (EntityPatchDecoder be a)) p) where

162− gDatabasePatchDecoder = M1 (K1 patchEntity)

163+ gDatabasePatchDecoder = M1 $ K1 patchEntity

163

164

164−class GPatchFields x where

165+type family FieldPatches be x where

165− gPatchFields :: x

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

166

172

167−instance GPatchFields (x p) => GPatchFields (D1 f x p) where

173+class GPatchFields be exposedRep where

168− gPatchFields = M1 gPatchFields

174+ gPatchFields :: FieldPatches be exposedRep ()

169

175

170−instance GPatchFields (x p) => GPatchFields (C1 f x p) where

176+instance GPatchFields be x => GPatchFields be (D1 f x) where

171− gPatchFields = M1 gPatchFields

177+ gPatchFields = M1 $ gPatchFields @be @x

172

178

173−instance (GPatchFields (x p), GPatchFields (y p)) => GPatchFields ((x :*: y) p) where

179+instance GPatchFields be x => GPatchFields be (C1 f x) where

174− gPatchFields = gPatchFields :*: gPatchFields

180+ gPatchFields = M1 $ gPatchFields @be @x

175

181

182+instance (GPatchFields be x, GPatchFields be y) => GPatchFields be (x :*: y) where

183+ gPatchFields = gPatchFields @be @x :*: gPatchFields @be @y

184+

176−instance BackendFromField be a => GPatchFields (S1 f (K1 Generic.R (FieldDecoder be a)) p) where

185+instance BackendFromField be a => GPatchFields be (S1 f (K1 Generic.R (Exposed a))) where

177− gPatchFields = M1 (K1 FieldDecoder)

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

178

199

179class PatchEntity be e where

200class PatchEntity be e where

180 patchEntity :: EntityPatchDecoder be e

201 patchEntity :: EntityPatchDecoder be e

@@ -186,12 +207,13 @@ to' :: Generic x => Rep x () -> x

186to' = Generic.to

207to' = Generic.to

187

208

188instance ( Generic (tbl (FieldDecoder be))

209instance ( Generic (tbl (FieldDecoder be))

210+ , GPatchFields be (Rep (tbl Exposed))

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

211+ , FieldPatches be (Rep (tbl Exposed)) ~ Rep (tbl (FieldDecoder be))

190 , Table tbl

212 , Table tbl

191 , Ord (PrimaryKey tbl Identity)

213 , Ord (PrimaryKey tbl Identity)

192 , Eq (tbl Maybe)

214 , Eq (tbl Maybe)

193 ) => PatchEntity be (TableEntity tbl) where

215 ) => PatchEntity be (TableEntity tbl) where

194− patchEntity = EntityPatchDecoder_Table $ to' gPatchFields

216+ patchEntity = EntityPatchDecoder_Table $ to' $ gPatchFields @be @(Rep (tbl Exposed))

195

217

196defaultDatabasePatchDecoder

218defaultDatabasePatchDecoder

197 :: forall be db

219 :: forall be db

@@ -274,7 +296,6 @@ instance Beamable tbl => Patch (PartialUpdate tbl) where

274 type PatchTarget (PartialUpdate tbl) = tbl Identity

296 type PatchTarget (PartialUpdate tbl) = tbl Identity

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

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

276

298

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

278decodeChange

299decodeChange

279 :: forall tbl

300 :: forall tbl

280 . Table tbl

301 . Table tbl

skeleton/common/src/Common/Schema.hs+49−8

@@ -1,4 +1,6 @@

1{-# LANGUAGE StandaloneDeriving #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE UndecidableInstances #-}

5{-# LANGUAGE UndecidableInstances #-}

4{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ScopedTypeVariables #-}

@@ -12,6 +14,7 @@

12module Common.Schema where

14module Common.Schema where

14import Data.Aeson

16import Data.Aeson

17+import Data.Constraint

15import Data.Int

18import Data.Int

16import Data.Text (Text)

19import Data.Text (Text)

17import Database.Beam

20import Database.Beam

@@ -21,14 +24,17 @@ data TaskT f = Task

21 { _task_id :: Columnar f (SqlSerial Int64)

24 { _task_id :: Columnar f (SqlSerial Int64)

22 , _task_description :: Columnar f Text

25 , _task_description :: Columnar f Text

23 , _task_completed :: Columnar f Bool

26 , _task_completed :: Columnar f Bool

27+ , _task_assignee :: PrimaryKey UserT (Nullable f)

24 }

28 }

25 deriving (Generic)

29 deriving (Generic)

26type Task = TaskT Identity

30type Task = TaskT Identity

28−deriving instance (Show (Columnar f (SqlSerial Int64)), Show (Columnar f Text), Show (Columnar f Bool)) => Show (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)))

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

33+

34+deriving instance AllTaskColumns Show f => Show (TaskT f)

35+deriving instance AllTaskColumns Read f => Read (TaskT f)

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

36+deriving instance AllTaskColumns Eq f => Eq (TaskT f)

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

37+deriving instance AllTaskColumns Ord f => Ord (TaskT f)

33instance Beamable TaskT

39instance Beamable TaskT

@@ -39,9 +45,6 @@ instance Table TaskT where

40deriving instance Show (Columnar f (SqlSerial Int64)) => Show (PrimaryKey TaskT f)

46deriving instance Show (Columnar f (SqlSerial Int64)) => Show (PrimaryKey TaskT f)

42−deriving instance ToJSONKey a => ToJSONKey (SqlSerial a)

43−deriving instance FromJSONKey a => FromJSONKey (SqlSerial a)

44−

45deriving instance Eq (PrimaryKey TaskT Identity)

48deriving instance Eq (PrimaryKey TaskT Identity)

46deriving instance Ord (PrimaryKey TaskT Identity)

49deriving instance Ord (PrimaryKey TaskT Identity)

47deriving instance ToJSON (PrimaryKey TaskT Identity)

50deriving instance ToJSON (PrimaryKey TaskT Identity)

@@ -53,9 +56,47 @@ instance FromJSON (TaskT Identity)

54instance Beamable (PrimaryKey TaskT)

57instance Beamable (PrimaryKey TaskT)

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+

56data Db f = Db

96data Db f = Db

57 { _db_tasks :: f (TableEntity TaskT)

97 { _db_tasks :: f (TableEntity TaskT)

98+ , _db_users :: f (TableEntity UserT)

58 }

99 }

59 deriving (Generic)

100 deriving (Generic)

101

61−deriving instance Show (f (TableEntity TaskT)) => Show (Db f)

102+deriving instance (Show (f (TableEntity TaskT)), Show (f (TableEntity UserT))) => Show (Db f)