git.iko.soy/obelisk
on master help sign in
WIP
31a32dcRyan Trinkle
default.nix+3−13
compare with master
unifiedsplit
@@ -16,19 +16,9 @@ let
16 openssh
16 openssh
17 ];
17 ];
18
18
19− beam-src = pkgs.fetchFromGitHub {
19+ beam-src = hackGet ./dep/beam;
20− owner = "obsidiansystems";
21− repo = "beam";
22− rev = "6c9b08d57951083c1f7e4bd49d941619603127f4";
23− sha256 = "1k4sdz0dxjafwkwlpfcdxkgvvv591nfwc97g1fq23wrs271jr2sm";
24− };
25
20
26− gargoyle-src = pkgs.fetchFromGitHub {
21+ gargoyle-src = hackGet ./dep/gargoyle;
27− owner = "obsidiansystems";
28− repo = "gargoyle";
29− rev = "2c19c569325ad76694526e9b688ccdbf148df980";
30− sha256 = "0257p0qd8xx900ngghkjbmjnvn7pjv05g0jm5kkrm4p6alrlhfyl";
31− };
32
22
33 getReflexPlatform = getReflexPlatform' __useLegacyCompilers;
23 getReflexPlatform = getReflexPlatform' __useLegacyCompilers;
34 getReflexPlatform' = __useLegacyCompilers: sys: import ./dep/reflex-platform {
24 getReflexPlatform' = __useLegacyCompilers: sys: import ./dep/reflex-platform {
@@ -79,7 +69,7 @@ let
79 sha256 = "1v337d810d88jzfriw07pr16d34nibm6q2zkw787lc3sfn07glp5";
69 sha256 = "1v337d810d88jzfriw07pr16d34nibm6q2zkw787lc3sfn07glp5";
80 }) {};
70 }) {};
81
71
82− beam-core = self.callCabal2nix "beam-core" (beam-src + /beam-core) {};
72+ beam-core = dontCheck (self.callCabal2nix "beam-core" (beam-src + /beam-core) {});
83 beam-postgres = dontCheck (self.callCabal2nix "beam-postgres" (beam-src + /beam-postgres) {});
73 beam-postgres = dontCheck (self.callCabal2nix "beam-postgres" (beam-src + /beam-postgres) {});
84 beam-migrate = self.callCabal2nix "beam-migrate" (beam-src + /beam-migrate) {};
74 beam-migrate = self.callCabal2nix "beam-migrate" (beam-src + /beam-migrate) {};
85
75
lib/backend/src/Obelisk/Postgres/LogicalDecoding/Plugins/TestDecoding.hs+1
@@ -3,6 +3,7 @@
3module Obelisk.Postgres.LogicalDecoding.Plugins.TestDecoding
3module Obelisk.Postgres.LogicalDecoding.Plugins.TestDecoding
4 ( line
4 ( line
5 , Transaction
5 , Transaction
6+ , Change (..)
6 , LineError (..)
7 , LineError (..)
7 , linesToTransactions
8 , linesToTransactions
8 ) where
9 ) where
lib/backend/src/Obelisk/Postgres/Replication.hs−1
@@ -64,7 +64,6 @@ withLogicalDecoding dbUri pluginName opts go = bracket (PQ.connectdb $ dbUri <>
64 <*> newMVar mempty
64 <*> newMVar mempty
65 <*> newIORef 0
65 <*> newIORef 0
66 backendPid <- PQ.backendPID unwrappedConn
66 backendPid <- PQ.backendPID unwrappedConn
67− putStrLn $ "withLogicalDecoding.d" <> show backendPid
68 let slotName = PG.Identifier $ slotNamePrefix <> T.pack (show backendPid)
67 let slotName = PG.Identifier $ slotNamePrefix <> T.pack (show backendPid)
69 [(_, _, _, _) :: (Text, Text, Maybe Text, Text)] <- uncurry (PG.query pgConn) [sqlQ| CREATE_REPLICATION_SLOT ?slotName TEMPORARY LOGICAL ?pluginName NOEXPORT_SNAPSHOT |]
68 [(_, _, _, _) :: (Text, Text, Maybe Text, Text)] <- uncurry (PG.query pgConn) [sqlQ| CREATE_REPLICATION_SLOT ?slotName TEMPORARY LOGICAL ?pluginName NOEXPORT_SNAPSHOT |]
70 withConn $ \conn -> do
69 withConn $ \conn -> do
skeleton/backend/backend.cabal+3
@@ -13,6 +13,9 @@ library
13 , obelisk-backend
13 , obelisk-backend
14 , obelisk-request
14 , obelisk-request
15 , obelisk-route
15 , obelisk-route
16+ , beam-core
17+ , beam-migrate
18+ , beam-postgres
16 exposed-modules:
19 exposed-modules:
17 Backend
20 Backend
18 ghc-options: -Wall
21 ghc-options: -Wall
skeleton/backend/src/Backend.hs+78−26
@@ -1,4 +1,6 @@
1{-# LANGUAGE EmptyCase #-}
1{-# LANGUAGE EmptyCase #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE TemplateHaskell #-}
3{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GADTs #-}
4{-# LANGUAGE TupleSections #-}
6{-# LANGUAGE TupleSections #-}
@@ -16,58 +18,108 @@
16{-# LANGUAGE TypeFamilies #-}
18{-# LANGUAGE TypeFamilies #-}
17module Backend where
19module Backend where
18
20
21+import Common.Api
22+import Backend.Schema
19import Common.Route
23import Common.Route
20−import Data.Aeson
21import Data.Text (Text)
24import Data.Text (Text)
22−import Data.Functor.Identity
23import Data.Map.Monoidal (MonoidalMap (..))
25import Data.Map.Monoidal (MonoidalMap (..))
24−import qualified Data.Map.Monoidal as Map
26+import Data.Pool
25−import Data.Semigroup
26import Obelisk.Backend
27import Obelisk.Backend
27import Obelisk.Route
28import Obelisk.Route
28import Obelisk.Api
29import Obelisk.Api
29−import Obelisk.Api.Pipeline --TODO: Move Request to Obelisk.Api
30import Obelisk.Db
30import Obelisk.Db
31import Obelisk.Postgres.LogicalDecoding.Plugins.TestDecoding
31import Obelisk.Postgres.LogicalDecoding.Plugins.TestDecoding
32−import Obelisk.Request.TH
32+import qualified Data.Map as Map
33−import Reflex.Class
33+import Data.Sequence (Seq)
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)
40
34
41−newtype V k v a = V (MonoidalMap k (a, First (Maybe v)))
35+import Database.Beam
42− deriving (Semigroup, Monoid, Functor, Foldable, Traversable, ToJSON, FromJSON, Eq)
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
43
42
44−instance FunctorMaybe (V k v) where
43+import Data.Proxy
45− fmapMaybe f (V m) = V $ Map.mapMaybe (\(a, v) -> (,v) <$> f a) m
46
44
47−instance (Ord k, Semigroup a) => Query (VS k v a) where
45+import Data.Functor.Identity
48− type QueryResult (VS k v a) = V k v a
46+import Data.Functor.Const
49− crop _ = id
47+import Control.Lens
50−
51−data MyRequest a where
52− MyRequest_Echo :: Text -> MyRequest Text
53
48
54−makeRequestForData ''MyRequest
49+import Debug.Trace
55
50
56backend :: Backend BackendRoute FrontendRoute
51backend :: Backend BackendRoute FrontendRoute
57backend = Backend
52backend = Backend
58 { _backend_run = \serve -> do
53 { _backend_run = \serve -> do
59 withDbUri "db" $ \dbUri -> do
54 withDbUri "db" $ \dbUri -> do
60− print dbUri
55+ withConnectionPool dbUri $ \pool -> do
56+ withResource pool $ \conn -> do
57+ runBeamPostgres conn $ autoMigrate migrationBackend checkedDb
61 let onNotify :: forall a. VS Int Text a -> Transaction -> ReadDb (V Int Text a)
58 let onNotify :: forall a. VS Int Text a -> Transaction -> ReadDb (V Int Text a)
62 onNotify (VS _) txn = do
59 onNotify (VS _) txn = do
63 traceM $ show txn
60 traceM $ show txn
61+ traceM $ show $ decodeTransaction txn
62+ tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db
63+ traceM $ show tasks
64 pure $ V $ MonoidalMap mempty
64 pure $ V $ MonoidalMap mempty
65 onSubscribe :: forall a. VS Int Text a -> ReadDb (V Int Text a)
65 onSubscribe :: forall a. VS Int Text a -> ReadDb (V Int Text a)
66 onSubscribe (VS _) = do
66 onSubscribe (VS _) = do
67+ tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db
68+ traceM $ show tasks
67 pure $ V $ MonoidalMap mempty
69 pure $ V $ MonoidalMap mempty
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
68− withApiHandler dbUri (\(MyRequest_Echo a) -> pure a) onNotify onSubscribe $ \handler -> do
79+ withApiHandler dbUri onRequest onNotify onSubscribe $ \handler -> do
69 serve $ \case
80 serve $ \case
70 BackendRoute_Api :/ () -> handler
81 BackendRoute_Api :/ () -> handler
71 _ -> return ()
82 _ -> return ()
72 , _backend_routeEncoder = backendRouteEncoder
83 , _backend_routeEncoder = backendRouteEncoder
73 }
84 }
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
skeleton/backend/src/Backend/Schema.hsnew file+50
@@ -0,0 +1,50 @@
1+{-# LANGUAGE StandaloneDeriving #-}
2+{-# LANGUAGE UndecidableInstances #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE DeriveGeneric #-}
8+{-# LANGUAGE TypeSynonymInstances #-}
9+module Backend.Schema where
10+
11+import Data.Int
12+import Data.Text (Text)
13+import Database.Beam
14+import Database.Beam.Migrate.Simple
15+import Database.Beam.Migrate
16+import Database.Beam.Postgres
17+
18+data TaskT f = Task
19+ { _task_id :: Columnar f 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+ data PrimaryKey TaskT f = TaskId (Columnar f Int64) deriving (Generic)
33+ primaryKey = TaskId . _task_id
34+
35+instance Beamable (PrimaryKey TaskT)
36+
37+data Db f = Db
38+ { _db_tasks :: f (TableEntity TaskT)
39+ }
40+ deriving (Generic)
41+
42+deriving instance Show (f (TableEntity TaskT)) => Show (Db f)
43+
44+instance Database Postgres Db
45+
46+checkedDb :: CheckedDatabaseSettings Postgres Db
47+checkedDb = defaultMigratableDbSettings
48+
49+db :: DatabaseSettings Postgres Db
50+db = unCheckDatabase checkedDb
skeleton/common/src/Common/Api.hs+43−2
@@ -1,4 +1,45 @@
1+{-# LANGUAGE EmptyCase #-}
2+{-# LANGUAGE TemplateHaskell #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE TupleSections #-}
5+{-# LANGUAGE DeriveFunctor #-}
6+{-# LANGUAGE DeriveFoldable #-}
7+{-# LANGUAGE DeriveTraversable #-}
8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9+{-# LANGUAGE TypeApplications #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE FlexibleContexts #-}
12+{-# LANGUAGE FlexibleInstances #-}
13+{-# LANGUAGE LambdaCase #-}
14+{-# LANGUAGE OverloadedStrings #-}
15+{-# LANGUAGE RankNTypes #-}
16+{-# LANGUAGE TypeFamilies #-}
1module Common.Api where
17module Common.Api where
2
18
3−commonStuff :: String
19+import Data.Aeson
4−commonStuff = "Here is a string defined in code common to the frontend and backend."
20+import Data.AppendMap ()
21+import Data.Map.Monoidal (MonoidalMap (..))
22+import qualified Data.Map.Monoidal as Map
23+import Data.Semigroup
24+import Data.Text (Text)
25+import Obelisk.Request.TH
26+import Reflex.Class
27+import Reflex.Query.Class
28+
29+newtype VS k v a = VS (MonoidalMap k a)
30+ deriving (Semigroup, Monoid, Functor, Foldable, Traversable, Group, ToJSON, FromJSON, Eq)
31+
32+newtype V k v a = V (MonoidalMap k (a, First (Maybe v)))
33+ deriving (Semigroup, Monoid, Functor, Foldable, Traversable, ToJSON, FromJSON, Eq)
34+
35+instance FunctorMaybe (V k v) where
36+ fmapMaybe f (V m) = V $ Map.mapMaybe (\(a, v) -> (,v) <$> f a) m
37+
38+instance (Ord k, Semigroup a) => Query (VS k v a) where
39+ type QueryResult (VS k v a) = V k v a
40+ crop _ = id
41+
42+data MyRequest a where
43+ MyRequest_Echo :: Text -> MyRequest Text
44+
45+makeRequestForData ''MyRequest
skeleton/frontend/src/Frontend.hs+8−7
@@ -1,23 +1,24 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE RecursiveDo #-}
2{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeApplications #-}
4module Frontend where
10module Frontend where
5
11
6−import qualified Data.Text as T
12+import Common.Route
7import Obelisk.Frontend
13import Obelisk.Frontend
14+import Obelisk.Generated.Static
8import Obelisk.Route
15import Obelisk.Route
9import Reflex.Dom.Core
16import Reflex.Dom.Core
10
17
11−import Common.Api
12−import Common.Route
13−import Obelisk.Generated.Static
14−
15−
16frontend :: Frontend (R FrontendRoute)
18frontend :: Frontend (R FrontendRoute)
17frontend = Frontend
19frontend = Frontend
18 { _frontend_head = el "title" $ text "Obelisk Minimal Example"
20 { _frontend_head = el "title" $ text "Obelisk Minimal Example"
19 , _frontend_body = do
21 , _frontend_body = do
20 text "Welcome to Obelisk!"
22 text "Welcome to Obelisk!"
21− el "p" $ text $ T.pack commonStuff
22 elAttr "img" ("src" =: static @"obelisk.jpg") blank
23 elAttr "img" ("src" =: static @"obelisk.jpg") blank
23 }
24 }