@@ -1,4 +1,6 @@
11{-# LANGUAGE EmptyCase #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE AllowAmbiguousTypes #-}
24{-# LANGUAGE TemplateHaskell #-}
35{-# LANGUAGE GADTs #-}
46{-# LANGUAGE TupleSections #-}
@@ -16,58 +18,108 @@
1618{-# LANGUAGE TypeFamilies #-}
1719module Backend where
1820
21+import Common.Api
22+import Backend.Schema
1923import Common.Route
20−import Data.Aeson
2124import Data.Text (Text)
22−import Data.Functor.Identity
2325import Data.Map.Monoidal (MonoidalMap (..))
24−import qualified Data.Map.Monoidal as Map
25−import Data.Semigroup
26+import Data.Pool
2627import Obelisk.Backend
2728import Obelisk.Route
2829import Obelisk.Api
29−import Obelisk.Api.Pipeline --TODO: Move Request to Obelisk.Api
3030import Obelisk.Db
3131import Obelisk.Postgres.LogicalDecoding.Plugins.TestDecoding
32−import Obelisk.Request.TH
33−import Reflex.Class
34−import Reflex.Query.Class
35−
36−import Debug.Trace
37−
38−newtype VS k v a = VS (MonoidalMap k a)
39− deriving (Semigroup, Monoid, Functor, Foldable, Traversable, Group, ToJSON, FromJSON, Eq)
32+import qualified Data.Map as Map
33+import Data.Sequence (Seq)
4034
41−newtype V k v a = V (MonoidalMap k (a, First (Maybe v)))
42− deriving (Semigroup, Monoid, Functor, Foldable, Traversable, ToJSON, FromJSON, Eq)
35+import Database.Beam
36+import Database.Beam.Postgres
37+import Database.Beam.Postgres.Migrate
38+import Database.Beam.Migrate.Simple
39+import Database.Beam.Schema.Tables
40+import Database.PostgreSQL.Simple.Types
41+import Control.Monad.Reader
4342
44−instance FunctorMaybe (V k v) where
45− fmapMaybe f (V m) = V $ Map.mapMaybe (\(a, v) -> (,v) <$> f a) m
43+import Data.Proxy
4644
47−instance (Ord k, Semigroup a) => Query (VS k v a) where
48− type QueryResult (VS k v a) = V k v a
49− crop _ = id
50−
51−data MyRequest a where
52− MyRequest_Echo :: Text -> MyRequest Text
45+import Data.Functor.Identity
46+import Data.Functor.Const
47+import Control.Lens
5348
54−makeRequestForData ''MyRequest
49+import Debug.Trace
5550
5651backend :: Backend BackendRoute FrontendRoute
5752backend = Backend
5853 { _backend_run = \serve -> do
5954 withDbUri "db" $ \dbUri -> do
60− print dbUri
55+ withConnectionPool dbUri $ \pool -> do
56+ withResource pool $ \conn -> do
57+ runBeamPostgres conn $ autoMigrate migrationBackend checkedDb
6158 let onNotify :: forall a. VS Int Text a -> Transaction -> ReadDb (V Int Text a)
6259 onNotify (VS _) txn = do
6360 traceM $ show txn
61+ traceM $ show $ decodeTransaction txn
62+ tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db
63+ traceM $ show tasks
6464 pure $ V $ MonoidalMap mempty
6565 onSubscribe :: forall a. VS Int Text a -> ReadDb (V Int Text a)
6666 onSubscribe (VS _) = do
67+ tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db
68+ traceM $ show tasks
6769 pure $ V $ MonoidalMap mempty
68− withApiHandler dbUri (\(MyRequest_Echo a) -> pure a) onNotify onSubscribe $ \handler -> do
70+ onRequest :: forall a. MyRequest a -> WriteDb a
71+ onRequest = \case
72+ MyRequest_Echo a -> do
73+ runInsert' $ insert (_db_tasks db) $ insertExpressions $ (:[]) $ Task
74+ { _task_id = default_
75+ , _task_description = val_ a
76+ , _task_completed = val_ False
77+ }
78+ pure a
79+ withApiHandler dbUri onRequest onNotify onSubscribe $ \handler -> do
6980 serve $ \case
7081 BackendRoute_Api :/ () -> handler
7182 _ -> return ()
7283 , _backend_routeEncoder = backendRouteEncoder
7384 }
85+
86+class MonadBeamRead m where
87+ runSelectReturningList' :: FromBackendRow Postgres a => SqlSelect Postgres a -> m [a]
88+ runSelectReturningOne' :: FromBackendRow Postgres a => SqlSelect Postgres a -> m (Maybe a)
89+
90+unsafeRunPgReadDb :: Pg a -> ReadDb a
91+unsafeRunPgReadDb a = ReadDb $ do
92+ conn <- ask
93+ lift $ runBeamPostgres conn a
94+
95+unsafeRunPgWriteDb :: Pg a -> WriteDb a
96+unsafeRunPgWriteDb a = WriteDb $ do
97+ conn <- ask
98+ lift $ runBeamPostgres conn a
99+
100+instance MonadBeamRead WriteDb where
101+ runSelectReturningList' = unsafeRunPgWriteDb . runSelectReturningList
102+ runSelectReturningOne' = unsafeRunPgWriteDb . runSelectReturningOne
103+
104+instance MonadBeamRead ReadDb where
105+ runSelectReturningList' = unsafeRunPgReadDb . runSelectReturningList
106+ runSelectReturningOne' = unsafeRunPgReadDb . runSelectReturningOne
107+
108+class MonadBeamWrite m where
109+ runInsert' :: SqlInsert Postgres table -> m ()
110+ runUpdate' :: SqlUpdate Postgres table -> m ()
111+ runDelete' :: SqlDelete Postgres table -> m ()
112+
113+instance MonadBeamWrite WriteDb where
114+ runInsert' = unsafeRunPgWriteDb . runInsert
115+ runUpdate' = unsafeRunPgWriteDb . runUpdate
116+ runDelete' = unsafeRunPgWriteDb . runDelete
117+
118+decodeTransaction :: Transaction -> Db (Const (Seq Change))
119+decodeTransaction (_, tableChanges) = runIdentity $ zipTables (Proxy :: Proxy Postgres) f db db
120+ where
121+ f :: IsDatabaseEntity Postgres entityType => DatabaseEntity Postgres Db entityType -> DatabaseEntity Postgres Db entityType -> Identity (Const (Seq Change) entityType)
122+ f (DatabaseEntity descriptor) _ = pure $ Const $
123+ let n = view dbEntityName descriptor
124+ 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