c18c96d · obelisk · git.iko.soy

default.nix+4−3

compare with master

unifiedsplit

@@ -93,10 +93,10 @@ let

93 gargoyle = doJailbreak (self.callCabal2nix "gargoyle" (gargoyle-src + /gargoyle) {});

94 gargoyle-postgresql-nix = pkgs.haskell.lib.addBuildTool

95 (self.callCabal2nix "gargoyle-postgresql-nix" (gargoyle-src + /gargoyle-postgresql-nix) {})

96− pkgs.postgresql; # `staticWhich` requires `psql` on PATH during build time

96+ pkgs.postgresql100; # `staticWhich` requires `psql` on PATH during build time

97− gargoyle-postgresql = addBuildDepend (doJailbreak (self.callCabal2nix "gargoyle-postgresql" (gargoyle-src + /gargoyle-postgresql) {})) pkgs.postgresql;

97+ gargoyle-postgresql = addBuildDepend (doJailbreak (self.callCabal2nix "gargoyle-postgresql" (gargoyle-src + /gargoyle-postgresql) {})) pkgs.postgresql100;

98 postgresql-libpq = enableCabalFlag (overrideCabal super.postgresql-libpq (drv: {

99− pkgconfigDepends = (drv.pkgconfigDepends or []) ++ [pkgs.postgresql]; #TODO: Obelisk should probably provide this version of postgresql

99+ pkgconfigDepends = (drv.pkgconfigDepends or []) ++ [pkgs.postgresql100]; #TODO: Obelisk should probably provide this version of postgresql

100 })) "use-pkg-config";

101 })

102

@@ -113,6 +113,7 @@ let

113 obelisk-cliapp = self.callCabal2nix "obelisk-cliapp" (cleanSource ./lib/cliapp) {};

114 obelisk-command = self.callCabal2nix "obelisk-command" (cleanSource ./lib/command) {};

115 obelisk-frontend = self.callCabal2nix "obelisk-frontend" (cleanSource ./lib/frontend) {};

116+ obelisk-request = self.callCabal2nix "obelisk-request" (cleanSource ./lib/request) {};

116 obelisk-run = self.callCabal2nix "obelisk-run" (cleanSource ./lib/run) {};

117 obelisk-run = self.callCabal2nix "obelisk-run" (cleanSource ./lib/run) {};

117 obelisk-route = self.callCabal2nix "obelisk-route" (cleanSource ./lib/route) {};

118 obelisk-route = self.callCabal2nix "obelisk-route" (cleanSource ./lib/route) {};

118 obelisk-selftest = self.callCabal2nix "obelisk-selftest" (cleanSource ./lib/selftest) {};

119 obelisk-selftest = self.callCabal2nix "obelisk-selftest" (cleanSource ./lib/selftest) {};

lib/backend/obelisk-backend.cabal+37−2

@@ -6,22 +6,57 @@ build-type: Simple

6library

7 hs-source-dirs: src

8 build-depends: base,

9+ aeson,

10+ async,

11+ attoparsec,

12+ binary,

9 bytestring,

13 bytestring,

10 categories,

14 categories,

15+ clientsession,

16+ constraints,

17+ containers,

11 data-default,

18 data-default,

12 dependent-sum,

19 dependent-sum,

13 dependent-sum-template,

20 dependent-sum-template,

21+ directory,

22+ --TODO: Do we really want enclosed-exceptions?

23+ enclosed-exceptions,

24+ filepath,

25+ gargoyle,

26+ gargoyle-postgresql-nix,

14 lens,

27 lens,

28+ monoidal-containers,

15 mtl,

29 mtl,

16 obelisk-asset-serve-snap,

30 obelisk-asset-serve-snap,

17 obelisk-executable-config-inject,

31 obelisk-executable-config-inject,

18 obelisk-frontend,

32 obelisk-frontend,

33+ obelisk-request,

19 obelisk-route,

34 obelisk-route,

20 obelisk-snap-extras,

35 obelisk-snap-extras,

36+ postgresql-libpq,

37+ postgresql-simple,

38+ reflex,

21 reflex-dom,

39 reflex-dom,

40+ resource-pool,

22 snap,

41 snap,

42+ snap-core,

23 snap-server,

43 snap-server,

44+ split,

45+ stm,

46+ template-haskell,

24 text,

47 text,

48+ these,

49+ time,

25− universe

50+ universe,

51+ unordered-containers,

52+ websockets,

53+ websockets-snap

26− exposed-modules: Obelisk.Backend

54+ exposed-modules:

55+ Data.MonoidMap

56+ Obelisk.Api

57+ Obelisk.Api.Pipeline

58+ Obelisk.Backend

59+ Obelisk.Db

60+ Obelisk.Postgres.LogicalDecoding.Plugins.TestDecoding

61+ Obelisk.Postgres.Replication

27 ghc-options: -Wall

62 ghc-options: -Wall

lib/backend/src/Data/MonoidMap.hs+5−5

@@ -40,9 +40,9 @@ instance (Ord k) => Functor (MonoidMap k) where

40instance FunctorMaybe (MonoidMap k) where

41 fmapMaybe f (MonoidMap m) = MonoidMap $ Map.mapMaybe f m

42

43−instance (Ord k) => Align (MonoidMap k) where

43+instance Ord k => Align (MonoidMap k) where

44− nil = MonoidMap nil

44+ nil = MonoidMap $ MonoidalMap nil

45− align (MonoidMap x) (MonoidMap y) = MonoidMap (align x y)

45+ align (MonoidMap (MonoidalMap x)) (MonoidMap (MonoidalMap y)) = MonoidMap $ MonoidalMap $ align x y

46− alignWith f (MonoidMap x) (MonoidMap y) = MonoidMap (alignWith f x y)

46+ alignWith f (MonoidMap (MonoidalMap x)) (MonoidMap (MonoidalMap y)) = MonoidMap $ MonoidalMap $ alignWith f x y

47

48−instance (Ord k) => Unalign (MonoidMap k)

48+instance Ord k => Unalign (MonoidMap k)

lib/backend/src/Obelisk/Api.hs+28−73

@@ -1,85 +1,41 @@

1−{-# LANGUAGE RankNTypes #-}

1+{-# LANGUAGE GADTs #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3+{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE OverloadedStrings #-}

5+{-# LANGUAGE PatternSynonyms #-}

4{-# LANGUAGE QuasiQuotes #-}

6{-# LANGUAGE QuasiQuotes #-}

7+{-# LANGUAGE RankNTypes #-}

5{-# LANGUAGE RecursiveDo #-}

8{-# LANGUAGE RecursiveDo #-}

6−{-# LANGUAGE GADTs #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

7−{-# LANGUAGE PatternSynonyms #-}

8−{-# LANGUAGE LambdaCase #-}

9module Obelisk.Api where

10module Obelisk.Api where

10

11

11import Prelude hiding ((.))

12import Prelude hiding ((.))

12

13

14+import Obelisk.Api.Pipeline

15+import Obelisk.Db

13import Obelisk.Postgres.Replication

16import Obelisk.Postgres.Replication

14import Obelisk.Postgres.LogicalDecoding.Plugins.TestDecoding

17import Obelisk.Postgres.LogicalDecoding.Plugins.TestDecoding

15−import Obelisk.Db

18+import Obelisk.Request (Request)

16

19

17import Control.Category

20import Control.Category

18−import Control.Concurrent (forkIO, killThread)

19import Control.Concurrent.Async

21import Control.Concurrent.Async

20−import Control.Concurrent.STM (TChan, atomically, dupTChan, newBroadcastTChanIO, readTChan, writeTChan, newTChanIO)

22+import Control.Concurrent.STM (TChan, atomically, readTChan, writeTChan, newTChanIO)

21−import Control.Monad (forever, void)

23+import Control.Monad (forever)

22import Control.Monad.Reader

24import Control.Monad.Reader

23−import Control.Monad.State.Strict

24−import Control.Exception

25−import Control.Exception.Enclosed

26−import Data.Binary (Binary)

27−import qualified Data.Binary as Binary

28−import Data.Binary.Get (ByteOffset)

29−import Data.Aeson (FromJSON, ToJSON, toJSON)

30−import qualified Data.Aeson as Aeson

31−import qualified Data.ByteString as BS

32−import qualified Data.ByteString.Lazy as LBS

33−import Data.List.Split (wordsBy)

34−import Data.Functor.Identity (Identity (..))

35−import Data.Pool (Pool, withResource)

36−import Data.Semigroup ((<>))

37−import Data.String (fromString)

38−import qualified Data.Text as T

39−import Data.Text.Encoding (encodeUtf8, decodeUtf8)

40−import qualified Database.PostgreSQL.Simple as PG

41−import qualified Database.PostgreSQL.Simple.Transaction as PG

42−import Database.PostgreSQL.Simple.SqlQQ

43−import qualified Database.PostgreSQL.Simple.Types as PG

44−import qualified Database.PostgreSQL.Simple.Notification as PG

45−import GHC.Generics (Generic)

46−import Control.Category (Category)

47−import qualified Control.Category as Cat

48−import Control.Concurrent (forkIO, killThread)

49−import Control.Exception (bracket)

50−import Control.Lens (imapM_)

51−import Control.Monad (forever, void, when)

52−import Control.Monad.IO.Class (MonadIO, liftIO)

53−import Control.Monad.State.Strict (evalStateT, get, put)

54import Control.Monad.Trans (lift)

25import Control.Monad.Trans (lift)

55−import Data.Aeson (FromJSON, toJSON)

26+import Data.Aeson (FromJSON, ToJSON)

56−import Data.AppendMap (AppendMap)

27+import Data.Attoparsec.ByteString

57−import qualified Data.AppendMap as Map

58−import Data.Map.Monoidal (MonoidalMap)

59−import Data.Foldable (fold)

60−import Data.IORef (atomicModifyIORef', newIORef, readIORef)

61−import Data.MonoidMap (MonoidMap (..), monoidMap)

62−import Data.Pool (Pool)

63−import Data.Semigroup (Semigroup, (<>))

64−import Data.Text (Text)

65−import Data.Typeable (Typeable)

66−import Debug.Trace (trace)

67−import Reflex (FunctorMaybe (..))

68−import Reflex.Patch (Group, negateG, (~~))

69−import Reflex.Query.Base (mapQuery, mapQueryResult)

70−import Reflex.Query.Class (Query, QueryResult, QueryMorphism (..), SelectedCount (..), crop)

71−import Snap.Core (MonadSnap, Snap)

72−import qualified Web.ClientSession as CS

73import Data.ByteString (ByteString)

28import Data.ByteString (ByteString)

74−import Data.Int

75−import Data.Word

76−import Data.Char

77import Data.Default

29import Data.Default

78−import Data.Attoparsec

30+import Data.Map.Monoidal (MonoidalMap)

79−

31+import Data.MonoidMap (MonoidMap (..))

80−import Rhyolite.Backend.DB.PsqlSimple hiding (Binary)

32+import Data.Pool (withResource)

81−import Obelisk.Api.Pipeline

33+import qualified Database.PostgreSQL.Simple as PG

82−--import Rhyolite.Backend.App

34+import qualified Database.PostgreSQL.Simple.Transaction as PG

35+import Reflex (FunctorMaybe (..))

36+import Reflex.Patch (Group)

37+import Reflex.Query.Class (QueryResult, SelectedCount (..))

38+import Snap.Core (Snap)

83

39

84{-

40{-

85-- | A way for a pipeline to retrieve data

41-- | A way for a pipeline to retrieve data

@@ -132,6 +88,7 @@ servePostgres db handleApi handleNotify handleQuery pipe = do

132-}

88-}

133

89

134newtype ReadDb a = ReadDb { unReadDb :: ReaderT PG.Connection IO a }

90newtype ReadDb a = ReadDb { unReadDb :: ReaderT PG.Connection IO a }

91+ deriving (Functor, Applicative, Monad)

135

92

136readTransaction :: PG.Connection -> ReadDb a -> IO a

93readTransaction :: PG.Connection -> ReadDb a -> IO a

137readTransaction conn (ReadDb r) = PG.withTransactionModeRetry m PG.isSerializationError conn $ runReaderT r conn

94readTransaction conn (ReadDb r) = PG.withTransactionModeRetry m PG.isSerializationError conn $ runReaderT r conn

@@ -141,6 +98,7 @@ readTransaction conn (ReadDb r) = PG.withTransactionModeRetry m PG.isSerializati

141 }

98 }

142

99

143newtype WriteDb a = WriteDb { unWriteDb :: ReaderT PG.Connection IO a }

100newtype WriteDb a = WriteDb { unWriteDb :: ReaderT PG.Connection IO a }

101+ deriving (Functor, Applicative, Monad)

144

102

145writeTransaction :: PG.Connection -> WriteDb a -> IO a

103writeTransaction :: PG.Connection -> WriteDb a -> IO a

146writeTransaction conn (WriteDb r) = PG.withTransactionModeRetry m PG.isSerializationError conn $ runReaderT r conn

104writeTransaction conn (WriteDb r) = PG.withTransactionModeRetry m PG.isSerializationError conn $ runReaderT r conn

@@ -156,7 +114,7 @@ unsafeWriteDb :: (PG.Connection -> IO a) -> WriteDb a

156unsafeWriteDb f = WriteDb $ lift . f =<< ask

114unsafeWriteDb f = WriteDb $ lift . f =<< ask

157

115

158withApiHandler

116withApiHandler

159− :: forall query queryResult request change a.

117+ :: forall query queryResult request a.

160 ( Monoid (query SelectedCount)

118 ( Monoid (query SelectedCount)

161 , QueryResult (query (MonoidMap ClientKey SelectedCount)) ~ queryResult (MonoidMap ClientKey SelectedCount)

119 , QueryResult (query (MonoidMap ClientKey SelectedCount)) ~ queryResult (MonoidMap ClientKey SelectedCount)

162 , QueryResult (query SelectedCount) ~ queryResult SelectedCount

120 , QueryResult (query SelectedCount) ~ queryResult SelectedCount

@@ -182,9 +140,6 @@ withApiHandler

182 -> (Snap () -> IO a)

140 -> (Snap () -> IO a)

183 -> IO a

141 -> IO a

184withApiHandler dbUri handleApi handleChange handleQuery go = do

142withApiHandler dbUri handleApi handleChange handleQuery go = do

185− let opts = def

186− { _logicalDecodingOptions_pluginOptions = [("skip-empty-xacts", Nothing)]

187− }

188 withNonEmptyTransactions dbUri $ \transactions -> do

143 withNonEmptyTransactions dbUri $ \transactions -> do

189 withConnectionPool dbUri $ \db -> do

144 withConnectionPool dbUri $ \db -> do

190 let onChange :: Transaction -> query x -> IO (QueryResult (query x))

145 let onChange :: Transaction -> query x -> IO (QueryResult (query x))

@@ -193,7 +148,7 @@ withApiHandler dbUri handleApi handleChange handleQuery go = do

193 pipe = queryMorphismPipeline $ transposeMonoidMap . monoidMapQueryMorphism

148 pipe = queryMorphismPipeline $ transposeMonoidMap . monoidMapQueryMorphism

194 rec (qh, finalizeFeed) <- feedPipeline (onChange <$> atomically (readTChan transactions)) (QueryHandler $ \q -> withResource db $ \conn -> readTransaction conn $ handleQuery q) r

149 rec (qh, finalizeFeed) <- feedPipeline (onChange <$> atomically (readTChan transactions)) (QueryHandler $ \q -> withResource db $ \conn -> readTransaction conn $ handleQuery q) r

195 (qh', r) <- unPipeline pipe qh r'

150 (qh', r) <- unPipeline pipe qh r'

196− (r', handleListen) <- connectPipelineToWebsockets "" (\r -> withResource db $ \conn -> writeTransaction conn $ handleApi r) qh'

151+ (r', handleListen) <- connectPipelineToWebsockets "" (\r'' -> withResource db $ \conn -> writeTransaction conn $ handleApi r'') qh'

197 go handleListen

152 go handleListen

198

153

199withNonEmptyTransactions :: ByteString -> (TChan Transaction -> IO a) -> IO a

154withNonEmptyTransactions :: ByteString -> (TChan Transaction -> IO a) -> IO a

@@ -201,11 +156,11 @@ withNonEmptyTransactions dbUri go = do

201 let opts = def

156 let opts = def

202 { _logicalDecodingOptions_pluginOptions = [("skip-empty-xacts", Nothing)]

157 { _logicalDecodingOptions_pluginOptions = [("skip-empty-xacts", Nothing)]

203 }

158 }

204− withLogicalDecoding dbUri "test_decoding" opts $ \lines -> do

159+ withLogicalDecoding dbUri "test_decoding" opts $ \decodedLines -> do

205 transactions <- newTChanIO

160 transactions <- newTChanIO

206 processLine <- linesToTransactions

161 processLine <- linesToTransactions

207 let processLines = forever $ do

162 let processLines = forever $ do

208− lineRaw <- atomically $ readTChan lines

163+ lineRaw <- atomically $ readTChan decodedLines

209 let Right l = parseOnly (line <* endOfInput) lineRaw

164 let Right l = parseOnly (line <* endOfInput) lineRaw

210 Right mTransaction <- processLine l

165 Right mTransaction <- processLine l

211 forM_ mTransaction $ \transaction ->

166 forM_ mTransaction $ \transaction ->

lib/backend/src/Obelisk/Api/Pipeline.hs+3−18

@@ -9,6 +9,8 @@ module Obelisk.Api.Pipeline where

9

10import Prelude hiding (id, (.))

11

12+import Obelisk.Request (Request, SomeRequest (..))

13+

12import Control.Concurrent

14import Control.Concurrent

13import Control.Monad

15import Control.Monad

14import Control.Monad.State.Strict

16import Control.Monad.State.Strict

@@ -16,8 +18,6 @@ import Data.Typeable

16import GHC.Generics

18import GHC.Generics

17import Control.Lens (imapM_)

19import Control.Lens (imapM_)

18import Data.Aeson

20import Data.Aeson

19−import Data.Aeson.Types (Parser)

20−import Data.Constraint (Dict)

21import Reflex.Query.Base

22import Reflex.Query.Class

23import Reflex.Patch

@@ -37,21 +37,6 @@ import qualified Network.WebSockets.Stream as WS

37import Network.WebSockets.Snap

38import Control.Exception

39

40−data SomeRequest t where

41− SomeRequest :: (FromJSON x, ToJSON x) => t x -> SomeRequest t

42−

43−class Request r where

44− requestToJSON :: r a -> Value

45− requestParseJSON :: Value -> Parser (SomeRequest r)

46− requestResponseToJSON :: r a -> Dict (ToJSON a)

47− requestResponseFromJSON :: r a -> Dict (FromJSON a)

48−

49−instance Request r => FromJSON (SomeRequest r) where

50− parseJSON = requestParseJSON

51−

52−instance Request r => ToJSON (SomeRequest r) where

53− toJSON (SomeRequest r) = requestToJSON r

54−

55-- | A way for a pipeline to retrieve data

40-- | A way for a pipeline to retrieve data

56newtype QueryHandler q m = QueryHandler

41newtype QueryHandler q m = QueryHandler

57 { runQueryHandler :: q -> m (QueryResult q) }

42 { runQueryHandler :: q -> m (QueryResult q) }

@@ -154,7 +139,7 @@ multiplexQuery lookupQueryHandler = do

154 -- TODO: Should we have a way of ensuring that this doesn't actually cause a query to be run?

139 -- TODO: Should we have a way of ensuring that this doesn't actually cause a query to be run?

155 -- It shouldn't cause the query to be run again but it depends on if the callee will notice

140 -- It shouldn't cause the query to be run again but it depends on if the callee will notice

156 -- that the new query is strictly smaller than the old one.

141 -- that the new query is strictly smaller than the old one.

157− runQueryHandler (lookupQueryHandler cid) antiQ

142+ _ <- runQueryHandler (lookupQueryHandler cid) antiQ

158 return ()

143 return ()

159

144

160 return (queryHandler, unregisterRecipient)

145 return (queryHandler, unregisterRecipient)

lib/backend/src/Obelisk/Db.hs+2−1

@@ -36,7 +36,8 @@ withDbUri dbPath a = do

36 let myConfig = defaultConfig

37 { _gargoyle_init = \workDir -> do

38 _gargoyle_init defaultConfig workDir

39− appendFile (workDir </> "postgresql.conf") "\n# Added by Obelisk.Db\nwal_level = logical\n"

39+ appendFile (workDir </> "postgresql.conf") "\n# Added by Obelisk.Db\nwal_level = logical\nmax_wal_senders = 10\n"

40+ appendFile (workDir </> "pg_hba.conf") "\n# Added by Obelisk.Db\nlocal replication postgres trust\n"

40 }

41 }

41 withGargoyle myConfig dbPath a

42 withGargoyle myConfig dbPath a

42

43

lib/backend/src/Obelisk/Postgres/LogicalDecoding/Plugins/TestDecoding.hs+5−5

@@ -182,13 +182,13 @@ type Transaction = (Xid, Map QualifiedIdentifier (Seq Change))

182

183data LineError

184 = LineError_OtherTransactionAlreadyInProgress

185− Xid -- ^ Existing transaction ID

185+ Xid -- Existing transaction ID

186− Xid -- ^ New transaction ID that tried to start

186+ Xid -- New transaction ID that tried to start

187 | LineError_CommittingWithoutTransaction

188− Xid -- ^ Transaction ID that tried to commit

188+ Xid -- Transaction ID that tried to commit

189 | LineError_CommittingWrongTransaction

190− Xid -- ^ Existing transaction ID

190+ Xid -- Existing transaction ID

191− Xid -- ^ New transaction ID that tried to start

191+ Xid -- New transaction ID that tried to start

192 | LineError_ChangeOutsideTransaction

193

194-- | Create a function that will statefully accumulate lines until a Transaction

lib/backend/src/Obelisk/Postgres/QQ.hsnew file+69

@@ -0,0 +1,69 @@

1+{-# LANGUAGE TemplateHaskellQuotes #-}

2+module Obelisk.Postgres.QQ

3+ ( queryQ

4+ , executeQ

5+ , sqlQ

6+ , traceQueryQ

7+ ) where

8+

9+import Database.PostgreSQL.Simple.SqlQQ (sql)

10+import Database.PostgreSQL.Simple.ToField (toField, Action)

11+import Language.Haskell.TH (Exp, Name, Q, appE, mkName, tupE, varE, listE, sigE)

12+import Language.Haskell.TH.Quote (QuasiQuoter (..))

13+

14+-- | This quasiquoter is the obvious combination of 'sqlQ' and 'query'.

15+queryQ :: QuasiQuoter

16+queryQ = QuasiQuoter

17+ { quotePat = error "queryQ: quasiquoter used in pattern context"

18+ , quoteType = error "queryQ: quasiquoter used in type context"

19+ , quoteExp = \s -> appE [| uncurry query |] (sqlQExp s)

20+ , quoteDec = error "queryQ: quasiquoter used in declaration context"

21+ }

22+

23+-- | This quasiquoter is the obvious combination of 'sqlQ' and 'execute'.

24+executeQ :: QuasiQuoter

25+executeQ = QuasiQuoter

26+ { quotePat = error "executeQ: quasiquoter used in pattern context"

27+ , quoteType = error "executeQ: quasiquoter used in type context"

28+ , quoteExp = \s -> appE [| uncurry execute |] (sqlQExp s)

29+ , quoteDec = error "executeQ: quasiquoter used in declaration context"

30+ }

31+

32+traceQueryQ :: QuasiQuoter

33+traceQueryQ = QuasiQuoter

34+ { quotePat = error "traceQueryQ: quasiquoter used in pattern context"

35+ , quoteType = error "traceQueryQ: quasiquoter used in type context"

36+ , quoteExp = \s -> appE [| uncurry traceQuery |] (sqlQExp s)

37+ , quoteDec = error "traceQueryQ: quasiquoter used in declaration context"

38+ }

39+-- | This quasiquoter takes a SQL query with named arguments in the form "?var" and generates a pair

40+-- consisting of the Query string itself and a tuple of variables in corresponding order.

41+--

42+-- For example: uncurry query [sqlQ| SELECT * FROM 'Book' b WHERE b.title = ?title AND b.author = ?author |]

43+--

44+-- will be equivalent to query [sql| SELECT * FROM 'Book' b WHERE b.title = ? AND b.author = ? |] [toField title, toField author]

45+sqlQ :: QuasiQuoter

46+sqlQ = QuasiQuoter

47+ { quotePat = error "sqlQ: quasiquoter used in pattern context"

48+ , quoteType = error "sqlQ: quasiquoter used in type context"

49+ , quoteExp = sqlQExp

50+ , quoteDec = error "sqlQ: quasiquoter used in declaration context"

51+ }

52+

53+sqlQExp :: String -> Q Exp

54+sqlQExp s =

55+ let (s',vs) = extractVars s

56+ in tupE [quoteExp sql s', sigE (listE $ map (appE (varE 'toField) . varE) vs) [t| [Action] |]]

57+

58+extractVars :: String -> (String, [Name])

59+extractVars = extractVars'

60+ where

61+ extractVars' [] = ([],[])

62+ extractVars' ('?':s') =

63+ let [(var,rest)] = lex s'

64+ (s'',vars) = extractVars' rest

65+ in ('?':s'', mkName var : vars)

66+ extractVars' s' =

67+ let (pre,post) = break (=='?') s'

68+ (s'',vars) = extractVars' post

69+ in (pre ++ s'', vars)

lib/backend/src/Obelisk/Postgres/Replication.hs+2−1

@@ -46,7 +46,7 @@ import qualified Data.Binary.Get as Binary

46import qualified Data.Binary.Put as Binary

47import Data.Char

48

49−import Rhyolite.Backend.DB.PsqlSimple hiding (Binary)

49+import Obelisk.Postgres.QQ

50

51-- | Start a replication session using logical decoding

52withLogicalDecoding

@@ -64,6 +64,7 @@ withLogicalDecoding dbUri pluginName opts go = bracket (PQ.connectdb $ dbUri <>

64 <*> newMVar mempty

65 <*> newIORef 0

66 backendPid <- PQ.backendPID unwrappedConn

67+ putStrLn $ "withLogicalDecoding.d" <> show backendPid

67 let slotName = PG.Identifier $ slotNamePrefix <> T.pack (show backendPid)

68 let slotName = PG.Identifier $ slotNamePrefix <> T.pack (show backendPid)

68 [(_, _, _, _) :: (Text, Text, Maybe Text, Text)] <- uncurry (PG.query pgConn) [sqlQ| CREATE_REPLICATION_SLOT ?slotName TEMPORARY LOGICAL ?pluginName NOEXPORT_SNAPSHOT |]

69 [(_, _, _, _) :: (Text, Text, Maybe Text, Text)] <- uncurry (PG.query pgConn) [sqlQ| CREATE_REPLICATION_SLOT ?slotName TEMPORARY LOGICAL ?pluginName NOEXPORT_SNAPSHOT |]

69 withConn $ \conn -> do

70 withConn $ \conn -> do

lib/request/obelisk-request.cabalnew file+18

@@ -0,0 +1,18 @@

1+name: obelisk-request

2+version: 0.1

3+cabal-version: >= 1.2

4+build-type: Simple

5+

6+library

7+ hs-source-dirs: src

8+ build-depends: base,

9+ aeson,

10+ constraints,

11+ template-haskell,

12+ vector

13+ exposed-modules:

14+ Obelisk.Request

15+ Obelisk.Request.TH

16+ other-modules:

17+ Obelisk.Request.HList

18+ ghc-options: -Wall

lib/request/src/Obelisk/Request.hsnew file+25

@@ -0,0 +1,25 @@

1+{-# LANGUAGE GADTs #-}

2+

3+module Obelisk.Request

4+ ( Request (..)

5+ , SomeRequest (..)

6+ ) where

7+

8+import Data.Aeson (FromJSON, ToJSON, Value, parseJSON, toJSON)

9+import Data.Aeson.Types (Parser)

10+import Data.Constraint (Dict)

11+

12+class Request r where

13+ requestToJSON :: r a -> Value

14+ requestParseJSON :: Value -> Parser (SomeRequest r)

15+ requestResponseToJSON :: r a -> Dict (ToJSON a)

16+ requestResponseFromJSON :: r a -> Dict (FromJSON a)

17+

18+data SomeRequest t where

19+ SomeRequest :: (FromJSON x, ToJSON x) => t x -> SomeRequest t

20+

21+instance Request r => FromJSON (SomeRequest r) where

22+ parseJSON = requestParseJSON

23+

24+instance Request r => ToJSON (SomeRequest r) where

25+ toJSON (SomeRequest r) = requestToJSON r

lib/request/src/Obelisk/Request/HList.hsnew file+59

@@ -0,0 +1,59 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE StandaloneDeriving #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE TypeOperators #-}

8+

9+module Obelisk.Request.HList (HList (..)) where

10+

11+import Data.Aeson (FromJSON, ToJSON, Value (Array), parseJSON, toJSON, withArray)

12+import Data.Vector (Vector)

13+import qualified Data.Vector as V

14+

15+data family HList (l::[*])

16+

17+data instance HList '[] = HNil

18+data instance HList (x ': xs) = x `HCons` HList xs

19+

20+infixr 2 `HCons`

21+

22+deriving instance Eq (HList '[])

23+deriving instance (Eq x, Eq (HList xs)) => Eq (HList (x ': xs))

24+

25+deriving instance Ord (HList '[])

26+deriving instance (Ord x, Ord (HList xs)) => Ord (HList (x ': xs))

27+

28+deriving instance Bounded (HList '[])

29+deriving instance (Bounded x, Bounded (HList xs)) => Bounded (HList (x ': xs))

30+

31+instance (FromJSON h, FromJSON (HList t)) => FromJSON (HList (h ': t)) where

32+ parseJSON = withArray "HList (a ': t)" $ \v -> do

33+ Just (aVal, v') <- return $ vectorView v

34+ a <- parseJSON aVal

35+ b <- parseJSON $ Array v'

36+ return $ HCons a b

37+

38+instance FromJSON (HList '[]) where

39+ parseJSON = withArray "HList '[]" $ \v -> do

40+ Nothing <- return $ vectorView v

41+ return HNil

42+

43+class HListToJSON l where

44+ hListToJSON :: HList l -> [Value]

45+

46+instance (ToJSON h, HListToJSON t) => HListToJSON (h ': t) where

47+ hListToJSON (HCons h t) = toJSON h : hListToJSON t

48+

49+instance HListToJSON '[] where

50+ hListToJSON HNil = []

51+

52+instance HListToJSON l => ToJSON (HList l) where

53+ toJSON = Array . V.fromList . hListToJSON

54+

55+vectorView :: Vector a -> Maybe (a, Vector a)

56+vectorView v =

57+ if V.length v > 0

58+ then Just (V.head v, V.tail v)

59+ else Nothing

lib/request/src/Obelisk/Request/TH.hsnew file+142

@@ -0,0 +1,142 @@

1+{-# LANGUAGE TemplateHaskell #-}

2+

3+module Obelisk.Request.TH

4+ ( makeJson

5+ , makeRequestForDataInstance

6+ , makeRequestForData

7+ ) where

8+

9+import Control.Monad (guard, replicateM)

10+import Data.Aeson.Types

11+import Data.Constraint (Dict (..))

12+import Data.List (isPrefixOf)

13+import Data.Semigroup ((<>))

14+import Language.Haskell.TH

15+

16+import Obelisk.Request

17+import Obelisk.Request.HList (HList (..))

18+

19+makeJson :: Name -> DecsQ

20+makeJson n = do

21+ x <- reify n

22+ let base = nameBase n

23+ toBeStripped = base <> "_"

24+ modifyConName cn = if length cons == 1 then cn else if toBeStripped `isPrefixOf` cn then drop (length toBeStripped) cn else error $ "makeRequest: expecting name beginning with " <> show toBeStripped <> ", got " <> show cn

25+ cons = case x of

26+ TyConI d -> decCons d

27+ _ -> error $ "cant do constructor:" ++ show x

28+ typeNames = map tvbName $ case x of

29+ TyConI d -> decTvbs d

30+ _ -> error $ "cant do typename:" ++ show x

31+ let wild = match wildP (normalB [|fail "invalid message"|]) []

32+ [d|

33+ instance ToJSON $(foldl appT (conT n) $ map varT typeNames) where

34+ toJSON r = $(caseE [|r|] $ map (conToJson modifyConName) cons)

35+ instance FromJSON $(foldl appT (conT n) $ map varT typeNames) where

36+ parseJSON v = do

37+ (tag', v') <- parseJSON v

38+ $(caseE [|tag' :: String|] $ map (conParseJson modifyConName id [|v'|]) cons ++ [wild])

39+ |]

40+

41+makeRequestForDataInstance :: Name -> Name -> DecsQ

42+makeRequestForDataInstance n n' = do

43+ x <- reify n

44+ let base = nameBase n

45+ toBeStripped = base <> "_"

46+ modifyConName cn = if length cons == 1 then cn else if toBeStripped `isPrefixOf` cn then drop (length toBeStripped) cn else error $ "makeRequest: expecting name beginning with " <> show toBeStripped <> ", got " <> show cn

47+ cons = case x of

48+ (FamilyI _ dataInstances) -> do

49+ (DataInstD _ _ (ConT m:_) _ xs _) <- dataInstances

50+ guard $ m == n'

51+ xs

52+ _ -> error $ "cant do family:" ++ show x

53+ let wild = match wildP (normalB [|fail "invalid message"|]) []

54+ [d|

55+ instance Request $(appT (conT n) (conT n')) where

56+ requestToJSON r = $(caseE [|r|] $ map (conToJson modifyConName) cons)

57+ requestParseJSON v = do

58+ (tag', v') <- parseJSON v

60+ requestResponseToJSON r = $(caseE [|r|] $ map (\c -> match (conP (conName c) $ replicate (conArity c) wildP) (normalB [|Dict|]) []) cons)

61+ requestResponseFromJSON r = $(caseE [|r|] $ map (\c -> match (conP (conName c) $ replicate (conArity c) wildP) (normalB [|Dict|]) []) cons)

62+ |]

63+

64+makeRequestForData :: Name -> DecsQ

65+makeRequestForData n = do

66+ x <- reify n

67+ let base = nameBase n

68+ toBeStripped = base <> "_"

69+ modifyConName cn = if length cons == 1 then cn else if toBeStripped `isPrefixOf` cn then drop (length toBeStripped) cn else error $ "makeRequest: expecting name beginning with " <> show toBeStripped <> ", got " <> show cn

70+ cons ::[Con]

71+ cons = case x of

72+ TyConI (DataD _ _ _ _ xs _) -> xs

73+ _ -> error $ "cant do data:" ++ show x

74+ let wild = match wildP (normalB [|fail "invalid message"|]) []

75+ [d|

76+ instance Request $(conT n) where

77+ requestToJSON r = $(caseE [|r|] $ map (conToJson modifyConName) cons)

78+ requestParseJSON v = do

79+ (tag', v') <- parseJSON v

81+ requestResponseToJSON r = $(caseE [|r|] $ map (\c -> match (conP (conName c) $ replicate (conArity c) wildP) (normalB [|Dict|]) []) cons)

82+ requestResponseFromJSON r = $(caseE [|r|] $ map (\c -> match (conP (conName c) $ replicate (conArity c) wildP) (normalB [|Dict|]) []) cons)

83+ |]

84+

85+conParseJson :: (String -> String) -> (ExpQ -> ExpQ) -> ExpQ -> Con -> MatchQ

86+conParseJson modifyName wrapBody e c = do

87+ let name = conName c

88+ varNames <- replicateM (conArity c) $ newName "f"

89+ let fields = map varE varNames

90+ tuple = foldr (\a b -> conP 'HCons [varP a, b]) (conP 'HNil []) varNames

91+ body = doE [ bindS tuple [|parseJSON $e|]

92+ , noBindS [|return $(appsE (conE name : fields))|]

93+ ]

94+ match (litP (StringL (modifyName $ nameBase name))) (normalB (wrapBody body)) []

95+

96+conToJson :: (String -> String) -> Con -> MatchQ

97+conToJson modifyName c = do

98+ let name = conName c

99+ base = nameBase name

100+ tag' = modifyName base

101+ varNames <- replicateM (conArity c) $ newName "f"

102+ let tuple = foldr (\a b -> appsE [conE 'HCons, varE a, b]) (conE 'HNil) varNames

103+ body = [|toJSON (tag' :: String, toJSON $tuple)|]

104+ match (conP name $ map varP varNames) (normalB body) []

105+

106+conArity :: Con -> Int

107+conArity c = case c of

108+ NormalC _ ts -> length ts

109+ RecC _ ts -> length ts

110+ InfixC _ _ _ -> 2

111+ ForallC _ _ c' -> conArity c'

112+ GadtC _ ts _ -> length ts

113+ RecGadtC _ ts _ -> length ts

114+

115+

116+decCons :: Dec -> [Con]

117+decCons d = case d of

118+ DataD _ _ _ _ cs _ -> cs

119+ NewtypeD _ _ _ _ c _ -> [c]

120+ _ -> error $ "not a data/newtype:" ++ show d

121+

122+-- | Extracts the name from a type variable binder.

123+tvbName :: TyVarBndr -> Name

124+tvbName (PlainTV name ) = name

125+tvbName (KindedTV name _) = name

126+

127+

128+decTvbs :: Dec -> [TyVarBndr]

129+decTvbs d = case d of

130+ DataD _ _ tvbs _ _ _ -> tvbs

131+ NewtypeD _ _ tvbs _ _ _ -> tvbs

132+ _ -> error $ "not a data/newtype:" ++ show d

133+

134+conName :: Con -> Name

135+conName c = case c of

136+ NormalC n _ -> n

137+ RecC n _ -> n

138+ InfixC _ n _ -> n

139+ ForallC _ _ c' -> conName c'

140+ GadtC [n] _ _ -> n

141+ RecGadtC [n] _ _ -> n

142+ _ -> error "conName: GADT constructors with multiple names not yet supported"

skeleton/.gitignore+1

@@ -5,3 +5,4 @@ result-ios

5result-exe

6.attr-cache

7ghcid-output.txt

8+db

skeleton/backend/backend.cabal+1

@@ -11,6 +11,7 @@ library

11 , common

12 , frontend

13 , obelisk-backend

14+ , obelisk-request

14 , obelisk-route

15 , obelisk-route

15 exposed-modules:

16 exposed-modules:

16 Backend

17 Backend

skeleton/backend/src/Backend.hs+58−2

@@ -1,17 +1,73 @@

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 #-}

2{-# LANGUAGE FlexibleContexts #-}

11{-# LANGUAGE FlexibleContexts #-}

12+{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE LambdaCase #-}

13{-# LANGUAGE LambdaCase #-}

14+{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE RankNTypes #-}

15{-# LANGUAGE RankNTypes #-}

5{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE TypeFamilies #-}

6module Backend where

17module Backend where

7

18

8import Common.Route

19import Common.Route

20+import Data.Aeson

21+import Data.Text (Text)

22+import Data.Functor.Identity

23+import Data.Map.Monoidal (MonoidalMap (..))

24+import qualified Data.Map.Monoidal as Map

25+import Data.Semigroup

9import Obelisk.Backend

26import Obelisk.Backend

10import Obelisk.Route

27import Obelisk.Route

11−import Obelisk.Api.Pipeline

28+import Obelisk.Api

29+import Obelisk.Api.Pipeline --TODO: Move Request to Obelisk.Api

30+import Obelisk.Db

31+import 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)

40+

41+newtype V k v a = V (MonoidalMap k (a, First (Maybe v)))

42+ deriving (Semigroup, Monoid, Functor, Foldable, Traversable, ToJSON, FromJSON, Eq)

43+

44+instance FunctorMaybe (V k v) where

45+ fmapMaybe f (V m) = V $ Map.mapMaybe (\(a, v) -> (,v) <$> f a) m

46+

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

53+

54+makeRequestForData ''MyRequest

12

55

13backend :: Backend BackendRoute FrontendRoute

56backend :: Backend BackendRoute FrontendRoute

14backend = Backend

57backend = Backend

15− { _backend_run = \serve -> serve $ const $ return ()

58+ { _backend_run = \serve -> do

59+ withDbUri "db" $ \dbUri -> do

60+ print dbUri

61+ let onNotify :: forall a. VS Int Text a -> Transaction -> ReadDb (V Int Text a)

62+ onNotify (VS _) txn = do

63+ traceM $ show txn

64+ pure $ V $ MonoidalMap mempty

65+ onSubscribe :: forall a. VS Int Text a -> ReadDb (V Int Text a)

66+ onSubscribe (VS _) = do

67+ pure $ V $ MonoidalMap mempty

68+ withApiHandler dbUri (\(MyRequest_Echo a) -> pure a) onNotify onSubscribe $ \handler -> do

69+ serve $ \case

70+ BackendRoute_Api :/ () -> handler

71+ _ -> return ()

16 , _backend_routeEncoder = backendRouteEncoder

72 , _backend_routeEncoder = backendRouteEncoder

17 }

73 }

skeleton/common/src/Common/Route.hs+2

@@ -29,6 +29,7 @@ data BackendRoute :: * -> * where

29 BackendRoute_Missing :: BackendRoute ()

30 -- You can define any routes that will be handled specially by the backend here.

31 -- i.e. These do not serve the frontend, but do something different, such as serving static files.

32+ BackendRoute_Api :: BackendRoute ()

32

33

33data FrontendRoute :: * -> * where

34data FrontendRoute :: * -> * where

34 FrontendRoute_Main :: FrontendRoute ()

35 FrontendRoute_Main :: FrontendRoute ()

@@ -40,6 +41,7 @@ backendRouteEncoder = handleEncoder (const (InL BackendRoute_Missing :/ ())) $

40 pathComponentEncoder $ \case

41 pathComponentEncoder $ \case

41 InL backendRoute -> case backendRoute of

42 InL backendRoute -> case backendRoute of

42 BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty

43 BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty

44+ BackendRoute_Api -> PathSegment "api" $ unitEncoder mempty

43 InR obeliskRoute -> obeliskRouteSegment obeliskRoute $ \case

45 InR obeliskRoute -> obeliskRouteSegment obeliskRoute $ \case

44 -- The encoder given to PathEnd determines how to parse query parameters,

46 -- The encoder given to PathEnd determines how to parse query parameters,

45 -- in this example, we have none, so we insist on it.

47 -- in this example, we have none, so we insist on it.