git.iko.soy/obelisk
on master help sign in
A bit more functionality
f24e04aRyan Trinkle
skeleton/backend/src/Backend.hs+17−16
compare with master
unifiedsplit
@@ -19,21 +19,24 @@
19module Backend where
19module Backend where
20
20
21import Common.Api
21import Common.Api
22+import Common.Schema
22import Backend.Schema
23import Backend.Schema
23import Common.Route
24import Common.Route
24−import Data.Text (Text)
25import Data.Map.Monoidal (MonoidalMap (..))
25import Data.Map.Monoidal (MonoidalMap (..))
26+import qualified Data.Map.Monoidal as Map
26import Data.Pool
27import Data.Pool
28+import Data.Semigroup
27import Obelisk.Backend
29import Obelisk.Backend
28import Obelisk.Route
30import Obelisk.Route
29import Obelisk.Api
31import Obelisk.Api
30import Obelisk.Db
32import Obelisk.Db
31import Obelisk.Postgres.LogicalDecoding.Plugins.TestDecoding
33import Obelisk.Postgres.LogicalDecoding.Plugins.TestDecoding
32−import qualified Data.Map as Map
34+import qualified Data.Map as OldMap
33import Data.Sequence (Seq)
35import Data.Sequence (Seq)
34
36
35import Database.Beam
37import Database.Beam
36import Database.Beam.Postgres
38import Database.Beam.Postgres
39+import Database.Beam.Postgres.Full (PgInsertReturning, returning, runPgInsertReturningList)
37import Database.Beam.Postgres.Migrate
40import Database.Beam.Postgres.Migrate
38import Database.Beam.Migrate.Simple
41import Database.Beam.Migrate.Simple
39import Database.Beam.Schema.Tables
42import Database.Beam.Schema.Tables
@@ -55,27 +58,23 @@ backend = Backend
55 withConnectionPool dbUri $ \pool -> do
58 withConnectionPool dbUri $ \pool -> do
56 withResource pool $ \conn -> do
59 withResource pool $ \conn -> do
57 runBeamPostgres conn $ autoMigrate migrationBackend checkedDb
60 runBeamPostgres conn $ autoMigrate migrationBackend checkedDb
58− let onNotify :: forall a. VS Int Text a -> Transaction -> ReadDb (V Int Text a)
61+ let onNotify :: forall a. VS (Id Task) Task a -> Transaction -> ReadDb (V (Id Task) Task a)
59− onNotify (VS _) txn = do
62+ onNotify (VS requested) txn = do
60− traceM $ show txn
61− traceM $ show $ decodeTransaction txn
62 tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db
63 tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db
63− traceM $ show tasks
64+ pure $ V $ Map.intersectionWith (,) requested $ Map.fromList $ fmap (\x -> (TaskId $ _task_id x, First $ Just x)) tasks
64− pure $ V $ MonoidalMap mempty
65− onSubscribe :: forall a. VS Int Text a -> ReadDb (V Int Text a)
65+ onSubscribe :: forall a. VS (Id Task) Task a -> ReadDb (V (Id Task) Task a)
66− onSubscribe (VS _) = do
66+ onSubscribe (VS requested) = do
67 tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db
67 tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db
68− traceM $ show tasks
68+ pure $ V $ Map.intersectionWith (,) requested $ Map.fromList $ fmap (\x -> (TaskId $ _task_id x, First $ Just x)) tasks
69− pure $ V $ MonoidalMap mempty
70 onRequest :: forall a. MyRequest a -> WriteDb a
69 onRequest :: forall a. MyRequest a -> WriteDb a
71 onRequest = \case
70 onRequest = \case
72− MyRequest_Echo a -> do
71+ MyRequest_Add a -> do
73− runInsert' $ insert (_db_tasks db) $ insertExpressions $ (:[]) $ Task
72+ [taskId] <- runInsertReturningList' $ flip returning _task_id $ insert (_db_tasks db) $ insertExpressions $ (:[]) $ Task
74 { _task_id = default_
73 { _task_id = default_
75 , _task_description = val_ a
74 , _task_description = val_ a
76 , _task_completed = val_ False
75 , _task_completed = val_ False
77 }
76 }
78− pure a
77+ pure $ TaskId taskId
79 withApiHandler dbUri onRequest onNotify onSubscribe $ \handler -> do
78 withApiHandler dbUri onRequest onNotify onSubscribe $ \handler -> do
80 serve $ \case
79 serve $ \case
81 BackendRoute_Api :/ () -> handler
80 BackendRoute_Api :/ () -> handler
@@ -107,11 +106,13 @@ instance MonadBeamRead ReadDb where
107
106
108class MonadBeamWrite m where
107class MonadBeamWrite m where
109 runInsert' :: SqlInsert Postgres table -> m ()
108 runInsert' :: SqlInsert Postgres table -> m ()
109+ runInsertReturningList' :: FromBackendRow Postgres a => PgInsertReturning a -> m [a]
110 runUpdate' :: SqlUpdate Postgres table -> m ()
110 runUpdate' :: SqlUpdate Postgres table -> m ()
111 runDelete' :: SqlDelete Postgres table -> m ()
111 runDelete' :: SqlDelete Postgres table -> m ()
112
112
113instance MonadBeamWrite WriteDb where
113instance MonadBeamWrite WriteDb where
114 runInsert' = unsafeRunPgWriteDb . runInsert
114 runInsert' = unsafeRunPgWriteDb . runInsert
115+ runInsertReturningList' = unsafeRunPgWriteDb . runPgInsertReturningList
115 runUpdate' = unsafeRunPgWriteDb . runUpdate
116 runUpdate' = unsafeRunPgWriteDb . runUpdate
116 runDelete' = unsafeRunPgWriteDb . runDelete
117 runDelete' = unsafeRunPgWriteDb . runDelete
117
118
@@ -122,4 +123,4 @@ decodeTransaction (_, tableChanges) = runIdentity $ zipTables (Proxy :: Proxy Po
122 f (DatabaseEntity descriptor) _ = pure $ Const $
123 f (DatabaseEntity descriptor) _ = pure $ Const $
123 let n = view dbEntityName descriptor
124 let n = view dbEntityName descriptor
124 s = Just "public" -- view dbEntitySchema descriptor --TODO: Beam has 'Nothing' while the replication connection reports 'Just "public"'
125 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 @@
8{-# LANGUAGE TypeSynonymInstances #-}
8{-# LANGUAGE TypeSynonymInstances #-}
9module Backend.Schema where
9module Backend.Schema where
10
10
11−import Data.Int
11+import Common.Schema
12−import Data.Text (Text)
12+
13import Database.Beam
13import Database.Beam
14−import Database.Beam.Backend.SQL.Types
15import Database.Beam.Migrate.Simple
14import Database.Beam.Migrate.Simple
16import Database.Beam.Migrate
15import Database.Beam.Migrate
17import Database.Beam.Postgres
16import Database.Beam.Postgres
18
17
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−
38data Db f = Db
18data Db f = Db
39 { _db_tasks :: f (TableEntity TaskT)
19 { _db_tasks :: f (TableEntity TaskT)
40 }
20 }
skeleton/common/src/Common/Api.hs+6−1
@@ -16,8 +16,10 @@
16{-# LANGUAGE TypeFamilies #-}
16{-# LANGUAGE TypeFamilies #-}
17module Common.Api where
17module Common.Api where
18
18
19+import Common.Schema
19import Data.Aeson
20import Data.Aeson
20import Data.AppendMap ()
21import Data.AppendMap ()
22+import Data.Functor.Identity
21import Data.Map.Monoidal (MonoidalMap (..))
23import Data.Map.Monoidal (MonoidalMap (..))
22import qualified Data.Map.Monoidal as Map
24import qualified Data.Map.Monoidal as Map
23import Data.Semigroup
25import Data.Semigroup
@@ -39,7 +41,10 @@ instance (Ord k, Semigroup a) => Query (VS k v a) where
39 type QueryResult (VS k v a) = V k v a
41 type QueryResult (VS k v a) = V k v a
40 crop _ = id
42 crop _ = id
41
43
44+type family Id t where
45+ Id (f Identity) = PrimaryKey f Identity
46+
42data MyRequest a where
47data MyRequest a where
43− MyRequest_Echo :: Text -> MyRequest Text
48+ MyRequest_Add :: Text -> MyRequest (Id Task)
44
49
45makeRequestForData ''MyRequest
50makeRequestForData ''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)