git.iko.soy/obelisk
on master help sign in
A bit more functionality
commitf24e04ac31709bf8bdc10777c33ea56e52465b6f authorRyan Trinkle <ryan.trinkle@gmail.com> dateMon 26 Nov 2018, 15:26 (8 years ago) parent6866887
4 files changed+73−39
compare with master
unifiedsplit
skeleton/backend/src/Backend.hs+17−16 skeleton/backend/src/Backend/Schema.hs+2−22 skeleton/common/src/Common/Api.hs+6−1 skeleton/common/src/Common/Schema.hs+48
skeleton/backend/src/Backend.hs+17−16
@@ -19,21 +19,24 @@
1919module Backend where
2020
2121import Common.Api
22+import Common.Schema
2223import Backend.Schema
2324import Common.Route
24−import Data.Text (Text)
2525import Data.Map.Monoidal (MonoidalMap (..))
26+import qualified Data.Map.Monoidal as Map
2627import Data.Pool
28+import Data.Semigroup
2729import Obelisk.Backend
2830import Obelisk.Route
2931import Obelisk.Api
3032import Obelisk.Db
3133import Obelisk.Postgres.LogicalDecoding.Plugins.TestDecoding
32−import qualified Data.Map as Map
34+import qualified Data.Map as OldMap
3335import Data.Sequence (Seq)
3436
3537import Database.Beam
3638import Database.Beam.Postgres
39+import Database.Beam.Postgres.Full (PgInsertReturning, returning, runPgInsertReturningList)
3740import Database.Beam.Postgres.Migrate
3841import Database.Beam.Migrate.Simple
3942import Database.Beam.Schema.Tables
@@ -55,27 +58,23 @@ backend = Backend
5558 withConnectionPool dbUri $ \pool -> do
5659 withResource pool $ \conn -> do
5760 runBeamPostgres conn $ autoMigrate migrationBackend checkedDb
58− let onNotify :: forall a. VS Int Text a -> Transaction -> ReadDb (V Int Text a)
59− onNotify (VS _) txn = do
60− traceM $ show txn
61− traceM $ show $ decodeTransaction txn
61+ let onNotify :: forall a. VS (Id Task) Task a -> Transaction -> ReadDb (V (Id Task) Task a)
62+ onNotify (VS requested) txn = do
6263 tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db
63− traceM $ show tasks
64− pure $ V $ MonoidalMap mempty
65− onSubscribe :: forall a. VS Int Text a -> ReadDb (V Int Text a)
66− onSubscribe (VS _) = do
64+ pure $ V $ Map.intersectionWith (,) requested $ Map.fromList $ fmap (\x -> (TaskId $ _task_id x, First $ Just x)) tasks
65+ onSubscribe :: forall a. VS (Id Task) Task a -> ReadDb (V (Id Task) Task a)
66+ onSubscribe (VS requested) = do
6767 tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db
68− traceM $ show tasks
69− pure $ V $ MonoidalMap mempty
68+ pure $ V $ Map.intersectionWith (,) requested $ Map.fromList $ fmap (\x -> (TaskId $ _task_id x, First $ Just x)) tasks
7069 onRequest :: forall a. MyRequest a -> WriteDb a
7170 onRequest = \case
72− MyRequest_Echo a -> do
73− runInsert' $ insert (_db_tasks db) $ insertExpressions $ (:[]) $ Task
71+ MyRequest_Add a -> do
72+ [taskId] <- runInsertReturningList' $ flip returning _task_id $ insert (_db_tasks db) $ insertExpressions $ (:[]) $ Task
7473 { _task_id = default_
7574 , _task_description = val_ a
7675 , _task_completed = val_ False
7776 }
78− pure a
77+ pure $ TaskId taskId
7978 withApiHandler dbUri onRequest onNotify onSubscribe $ \handler -> do
8079 serve $ \case
8180 BackendRoute_Api :/ () -> handler
@@ -107,11 +106,13 @@ instance MonadBeamRead ReadDb where
107106
108107class MonadBeamWrite m where
109108 runInsert' :: SqlInsert Postgres table -> m ()
109+ runInsertReturningList' :: FromBackendRow Postgres a => PgInsertReturning a -> m [a]
110110 runUpdate' :: SqlUpdate Postgres table -> m ()
111111 runDelete' :: SqlDelete Postgres table -> m ()
112112
113113instance MonadBeamWrite WriteDb where
114114 runInsert' = unsafeRunPgWriteDb . runInsert
115+ runInsertReturningList' = unsafeRunPgWriteDb . runPgInsertReturningList
115116 runUpdate' = unsafeRunPgWriteDb . runUpdate
116117 runDelete' = unsafeRunPgWriteDb . runDelete
117118
@@ -122,4 +123,4 @@ decodeTransaction (_, tableChanges) = runIdentity $ zipTables (Proxy :: Proxy Po
122123 f (DatabaseEntity descriptor) _ = pure $ Const $
123124 let n = view dbEntityName descriptor
124125 s = Just "public" -- view dbEntitySchema descriptor --TODO: Beam has 'Nothing' while the replication connection reports 'Just "public"'
125− in trace (show (s, n)) $ Map.findWithDefault mempty (QualifiedIdentifier s n) tableChanges
126+ in trace (show (s, n)) $ OldMap.findWithDefault mempty (QualifiedIdentifier s n) tableChanges
skeleton/backend/src/Backend/Schema.hs+2−22
@@ -8,33 +8,13 @@
88{-# LANGUAGE TypeSynonymInstances #-}
99module Backend.Schema where
1010
11−import Data.Int
12−import Data.Text (Text)
11+import Common.Schema
12+
1313import Database.Beam
14−import Database.Beam.Backend.SQL.Types
1514import Database.Beam.Migrate.Simple
1615import Database.Beam.Migrate
1716import Database.Beam.Postgres
1817
19−data TaskT f = Task
20− { _task_id :: Columnar f (SqlSerial Int64)
21− , _task_description :: Columnar f Text
22− , _task_completed :: Columnar f Bool
23− }
24− deriving (Generic)
25−type Task = TaskT Identity
26−
27−deriving instance Show Task
28−deriving instance Eq Task
29−
30−instance Beamable TaskT
31−
32−instance Table TaskT where
33− data PrimaryKey TaskT f = TaskId (Columnar f (SqlSerial Int64)) deriving (Generic)
34− primaryKey = TaskId . _task_id
35−
36−instance Beamable (PrimaryKey TaskT)
37−
3818data Db f = Db
3919 { _db_tasks :: f (TableEntity TaskT)
4020 }
skeleton/common/src/Common/Api.hs+6−1
@@ -16,8 +16,10 @@
1616{-# LANGUAGE TypeFamilies #-}
1717module Common.Api where
1818
19+import Common.Schema
1920import Data.Aeson
2021import Data.AppendMap ()
22+import Data.Functor.Identity
2123import Data.Map.Monoidal (MonoidalMap (..))
2224import qualified Data.Map.Monoidal as Map
2325import Data.Semigroup
@@ -39,7 +41,10 @@ instance (Ord k, Semigroup a) => Query (VS k v a) where
3941 type QueryResult (VS k v a) = V k v a
4042 crop _ = id
4143
44+type family Id t where
45+ Id (f Identity) = PrimaryKey f Identity
46+
4247data MyRequest a where
43− MyRequest_Echo :: Text -> MyRequest Text
48+ MyRequest_Add :: Text -> MyRequest (Id Task)
4449
4550makeRequestForData ''MyRequest
skeleton/common/src/Common/Schema.hsnew file+48
@@ -0,0 +1,48 @@
1+{-# LANGUAGE StandaloneDeriving #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE UndecidableInstances #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE DeriveGeneric #-}
9+{-# LANGUAGE TypeSynonymInstances #-}
10+module Common.Schema where
11+
12+import Data.Aeson
13+import Data.Int
14+import Data.Text (Text)
15+import Database.Beam
16+import Database.Beam.Backend.SQL.Types
17+
18+data TaskT f = Task
19+ { _task_id :: Columnar f (SqlSerial Int64)
20+ , _task_description :: Columnar f Text
21+ , _task_completed :: Columnar f Bool
22+ }
23+ deriving (Generic)
24+type Task = TaskT Identity
25+
26+deriving instance Show Task
27+deriving instance Eq Task
28+
29+instance Beamable TaskT
30+
31+instance Table TaskT where
32+ newtype PrimaryKey TaskT f = TaskId (Columnar f (SqlSerial Int64))
33+ deriving (Generic)
34+ primaryKey = TaskId . _task_id
35+
36+deriving instance ToJSONKey a => ToJSONKey (SqlSerial a)
37+deriving instance FromJSONKey a => FromJSONKey (SqlSerial a)
38+
39+deriving instance Eq (PrimaryKey TaskT Identity)
40+deriving instance Ord (PrimaryKey TaskT Identity)
41+deriving instance ToJSON (PrimaryKey TaskT Identity)
42+deriving instance FromJSON (PrimaryKey TaskT Identity)
43+deriving instance ToJSONKey (PrimaryKey TaskT Identity)
44+deriving instance FromJSONKey (PrimaryKey TaskT Identity)
45+instance ToJSON (TaskT Identity)
46+instance FromJSON (TaskT Identity)
47+
48+instance Beamable (PrimaryKey TaskT)