0b214e6 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Merge Vessel stuff

0b214e6Ryan Trinkle8 years ago

default.nix+25−12

compare with master

unifiedsplit

@@ -16,11 +16,17 @@ let

16 openssh

17 ];

19+ src = {

19− beam-src = hackGet ./dep/beam;

20+ beam = hackGet ./dep/beam;

20−

21+ constraints-extras = hackGet ./dep/constraints-extras;

21− gargoyle-src = hackGet ./dep/gargoyle;

22+ dependent-map = hackGet ./dep/dependent-map;

22−

23+ dependent-monoidal-map = hackGet ./dep/dependent-monoidal-map;

24+ dependent-sum-aeson-orphans = hackGet ./dep/dependent-sum-aeson-orphans;

25+ gargoyle = hackGet ./dep/gargoyle;

23− postgresql-simple-src = hackGet ./dep/postgresql-simple;

26+ postgresql-simple = hackGet ./dep/postgresql-simple;

27+ reflex-aeson-orphans = hackGet ./dep/reflex-aeson-orphans;

28+ vessel = hackGet ./dep/vessel;

29+ };

25 getReflexPlatform = getReflexPlatform' __useLegacyCompilers;

31 getReflexPlatform = getReflexPlatform' __useLegacyCompilers;

26 getReflexPlatform' = __useLegacyCompilers: sys: import ./dep/reflex-platform {

32 getReflexPlatform' = __useLegacyCompilers: sys: import ./dep/reflex-platform {

@@ -71,11 +77,16 @@ let

71 sha256 = "1v337d810d88jzfriw07pr16d34nibm6q2zkw787lc3sfn07glp5";

77 sha256 = "1v337d810d88jzfriw07pr16d34nibm6q2zkw787lc3sfn07glp5";

72 }) {};

78 }) {};

74− beam-core = dontCheck (self.callCabal2nix "beam-core" (beam-src + /beam-core) {});

80+ beam-core = dontCheck (self.callCabal2nix "beam-core" (src.beam + /beam-core) {});

75− beam-postgres = dontCheck (self.callCabal2nix "beam-postgres" (beam-src + /beam-postgres) {});

81+ beam-postgres = dontCheck (self.callCabal2nix "beam-postgres" (src.beam + /beam-postgres) {});

76− beam-migrate = self.callCabal2nix "beam-migrate" (beam-src + /beam-migrate) {};

82+ beam-migrate = self.callCabal2nix "beam-migrate" (src.beam + /beam-migrate) {};

78− postgresql-simple = dontCheck (self.callCabal2nix "postgresql-simple" postgresql-simple-src {});

84+ postgresql-simple = dontCheck (self.callCabal2nix "postgresql-simple" src.postgresql-simple {});

85+ constraints-extras = self.callCabal2nix "constraints-extras" src.constraints-extras {};

86+ dependent-map = self.callCabal2nix "dependent-map" src.dependent-map {};

87+ dependent-monoidal-map = self.callCabal2nix "dependent-monoidal-map" src.dependent-monoidal-map {};

88+ dependent-sum-aeson-orphans = self.callCabal2nix "dependent-sum-aeson-orphans" src.dependent-sum-aeson-orphans {};

89+ reflex-aeson-orphans = self.callCabal2nix "reflex-aeson-orphans" src.reflex-aeson-orphans {};

80 websockets = self.callCabal2nix "websockets" (pkgs.fetchFromGitHub {

91 websockets = self.callCabal2nix "websockets" (pkgs.fetchFromGitHub {

81 owner = "obsidiansystems";

92 owner = "obsidiansystems";

@@ -84,11 +95,13 @@ let

84 sha256 = "1wd0gkx8a4x6n5cdkra96zvpv8l49i0z90amvrng70ybnzbxpfi5";

95 sha256 = "1wd0gkx8a4x6n5cdkra96zvpv8l49i0z90amvrng70ybnzbxpfi5";

85 }) {};

96 }) {};

98+ vessel = self.callCabal2nix "vessel" src.vessel {};

99+

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

dep/constraints-extras/default.nixnew file+7

@@ -0,0 +1,7 @@

1+# DO NOT HAND-EDIT THIS FILE

2+import ((import <nixpkgs> {}).fetchFromGitHub (

3+ let json = builtins.fromJSON (builtins.readFile ./github.json);

4+ in { inherit (json) owner repo rev sha256;

5+ private = json.private or false;

6+ }

7+))

dep/constraints-extras/github.jsonnew file+7

@@ -0,0 +1,7 @@

1+{

2+ "owner": "obsidiansystems",

3+ "repo": "constraints-extras",

4+ "branch": "master",

5+ "rev": "2f1674dbb53b611bbdc4bfd7a617dc2a674034f3",

6+ "sha256": "1x73c11fwms5hvwry9zma164m04wq3w6ac65hry8yf7fm6ks2smi"

7+}

dep/dependent-map/default.nixnew file+7

@@ -0,0 +1,7 @@

1+# DO NOT HAND-EDIT THIS FILE

2+import ((import <nixpkgs> {}).fetchFromGitHub (

3+ let json = builtins.fromJSON (builtins.readFile ./github.json);

4+ in { inherit (json) owner repo rev sha256;

5+ private = json.private or false;

6+ }

7+))

dep/dependent-map/github.jsonnew file+7

@@ -0,0 +1,7 @@

1+{

2+ "owner": "obsidiansystems",

3+ "repo": "dependent-map",

4+ "branch": "cg-expose-internals",

5+ "rev": "e274e57bc263a309d8d53112f17f7d06d81d9f7e",

6+ "sha256": "1wb25f1r6rl4i1ylgqrqz387p2jvfv21g9hlc9904mc76k8q949v"

7+}

dep/dependent-monoidal-map/default.nixnew file+7

@@ -0,0 +1,7 @@

1+# DO NOT HAND-EDIT THIS FILE

2+import ((import <nixpkgs> {}).fetchFromGitHub (

3+ let json = builtins.fromJSON (builtins.readFile ./github.json);

4+ in { inherit (json) owner repo rev sha256;

5+ private = json.private or false;

6+ }

7+))

dep/dependent-monoidal-map/github.jsonnew file+7

@@ -0,0 +1,7 @@

1+{

2+ "owner": "obsidiansystems",

3+ "repo": "dependent-monoidal-map",

4+ "branch": "develop",

5+ "rev": "c2c9edb02b89ef67850e8ac3c3a314963b875324",

6+ "sha256": "15qqmc9j984pwrsiviz4wrkxspzzw2x9b86zily4fqlb3yqlnlny"

7+}

dep/dependent-sum-aeson-orphans/default.nixnew file+7

@@ -0,0 +1,7 @@

1+# DO NOT HAND-EDIT THIS FILE

2+import ((import <nixpkgs> {}).fetchFromGitHub (

3+ let json = builtins.fromJSON (builtins.readFile ./github.json);

4+ in { inherit (json) owner repo rev sha256;

5+ private = json.private or false;

6+ }

7+))

dep/dependent-sum-aeson-orphans/github.jsonnew file+7

@@ -0,0 +1,7 @@

1+{

2+ "owner": "obsidiansystems",

3+ "repo": "dependent-sum-aeson-orphans",

4+ "branch": "master",

5+ "rev": "a4b2f1113dbfe09a0abf417e2a7fbd6215b0e213",

6+ "sha256": "1nwij0nxa3pbm4dky78iicgf1paph58whni2b7ga27f9qakbhmpr"

7+}

dep/reflex-aeson-orphans/default.nixnew file+7

@@ -0,0 +1,7 @@

1+# DO NOT HAND-EDIT THIS FILE

2+import ((import <nixpkgs> {}).fetchFromGitHub (

3+ let json = builtins.fromJSON (builtins.readFile ./github.json);

4+ in { inherit (json) owner repo rev sha256;

5+ private = json.private or false;

6+ }

7+))

dep/reflex-aeson-orphans/github.jsonnew file+7

@@ -0,0 +1,7 @@

1+{

2+ "owner": "reflex-frp",

3+ "repo": "reflex-aeson-orphans",

4+ "branch": "master",

5+ "rev": "cf7e30cd0908660231956ef415103af1913feb69",

6+ "sha256": "1hv7kxxk6s7b8xhbwx8i3fx6rk2ggvvsv1grwzydxl54lyhy60c6"

7+}

dep/vessel/default.nixnew file+7

@@ -0,0 +1,7 @@

1+# DO NOT HAND-EDIT THIS FILE

2+import ((import <nixpkgs> {}).fetchFromGitHub (

3+ let json = builtins.fromJSON (builtins.readFile ./github.json);

4+ in { inherit (json) owner repo rev sha256;

5+ private = json.private or false;

6+ }

7+))

dep/vessel/github.jsonnew file+7

@@ -0,0 +1,7 @@

1+{

2+ "owner": "obsidiansystems",

3+ "repo": "vessel",

4+ "branch": "develop",

5+ "rev": "b56cf521cb7c6ad051b882e0c44afaf890864af3",

6+ "sha256": "1qrq44snhws7wvkck88md3czghfhcqd53v85jxjfaa9ks94dabsz"

7+}

lib/backend/obelisk-backend.cabal+4

@@ -14,10 +14,12 @@ library

14 categories,

15 clientsession,

16 constraints,

17+ constraints-extras,

17 containers,

18 containers,

18 data-default,

19 data-default,

19 dependent-sum,

20 dependent-sum,

20 dependent-sum-template,

21 dependent-sum-template,

22+ dependent-map,

21 directory,

23 directory,

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

24 --TODO: Do we really want enclosed-exceptions?

23 enclosed-exceptions,

25 enclosed-exceptions,

@@ -49,9 +51,11 @@ library

49 time,

51 time,

50 universe,

52 universe,

51 unordered-containers,

53 unordered-containers,

54+ vessel,

52 websockets,

55 websockets,

53 websockets-snap

56 websockets-snap

54 exposed-modules:

57 exposed-modules:

58+ Data.Aeson.GADT

55 Data.MonoidMap

59 Data.MonoidMap

56 Obelisk.Api

60 Obelisk.Api

57 Obelisk.Api.Pipeline

61 Obelisk.Api.Pipeline

lib/backend/src/Data/Aeson/GADT.hsnew file+184

@@ -0,0 +1,184 @@

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE ExistentialQuantification #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE LambdaCase #-}

6+{-# LANGUAGE RankNTypes #-}

7+{-# LANGUAGE FlexibleContexts #-}

8+{-# LANGUAGE FlexibleInstances #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE StandaloneDeriving #-}

11+{-# LANGUAGE TypeApplications #-}

12+{-# LANGUAGE TypeFamilies #-}

13+{-# LANGUAGE TypeOperators #-}

14+{-# LANGUAGE UndecidableInstances #-}

15+{-# LANGUAGE QuasiQuotes #-}

16+{-# LANGUAGE TemplateHaskell #-}

17+{-# LANGUAGE PatternGuards #-}

18+

19+{-# OPTIONS_GHC -fno-warn-orphans #-}

20+

21+module Data.Aeson.GADT where

22+

23+import Control.Monad

24+import Data.Aeson

25+import Data.Some as Some

26+import Data.Constraint.Forall

27+import Data.GADT.Compare

28+import Language.Haskell.TH

29+import Data.Functor.Classes

30+

31+import Data.Constraint.Extras

32+import Data.Dependent.Sum

33+import Data.Dependent.Map (DMap)

34+import qualified Data.Dependent.Map as DMap

35+import Data.Functor.Identity

36+

37+import Data.Some (Some(..))

38+

39+decCons :: Dec -> [Con]

40+decCons = \case

41+ DataD _ _ _ _ cs _ -> cs

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

43+ _ -> error "undefined"

44+

45+conName :: Con -> Name

46+conName c = case c of

47+ NormalC n _ -> n

48+ RecC n _ -> n

49+ InfixC _ n _ -> n

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

51+ GadtC [n] _ _ -> n

52+ RecGadtC [n] _ _ -> n

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

54+

55+conArity :: Con -> Int

56+conArity c = case c of

57+ NormalC _ ts -> length ts

58+ RecC _ ts -> length ts

59+ InfixC _ _ _ -> 2

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

61+ GadtC _ ts _ -> length ts

62+ RecGadtC _ ts _ -> length ts

63+

64+deriveJSONGADT :: Name -> DecsQ

65+deriveJSONGADT n = do

66+ tj <- deriveToJSONGADT n

67+ fj <- deriveFromJSONGADT n

68+ return (tj ++ fj)

69+

70+deriveToJSONGADT :: Name -> DecsQ

71+deriveToJSONGADT n = do

72+ x <- reify n

73+ let cons = case x of

74+ TyConI d -> decCons d

75+ _ -> error "undefined"

76+ [d|

77+ instance ToJSON ($(conT n) a) where

78+ toJSON r = $(caseE [|r|] $ map conMatchesToJSON cons)

79+ |]

80+

81+instance (ForallF ToJSON c) => ToJSON (Some c) where

82+ toJSON (Some.This (x :: c a)) = whichever @ToJSON @c @a (toJSON x)

83+

84+deriveFromJSONGADT :: Name -> DecsQ

85+deriveFromJSONGADT n = do

86+ x <- reify n

87+ let cons = case x of

88+ TyConI d -> decCons d

89+ _ -> error "undefined"

90+ let wild = match wildP (normalB [|fail "deriveFromJSONGADT: Supposedly-complete GADT pattern match fell through in generated code. This shouldn't happen."|]) []

91+ [d|

92+ instance FromJSON (Some $(conT n)) where

93+ parseJSON v = do

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

95+ $(caseE [|tag' :: String|] $ map (conMatchesParseJSON [|v'|]) cons ++ [wild])

96+ |]

97+

98+deriveEqTag :: Name -> DecsQ

99+deriveEqTag n = do

100+ x <- reify n

101+ let cons = case x of

102+ TyConI d -> decCons d

103+ _ -> error "undefined"

104+ [d|

105+ instance Eq1 f => EqTag $(conT n) f where

106+ eqTagged a b = $(caseE [|(a, b)|] $ concatMap conMatchesEqTagged cons)

107+ |]

108+

109+-- | Generate all required matches (and some redundant ones...) for `eqTagged`

110+-- for some constructor

111+conMatchesEqTagged :: Con -> [MatchQ]

112+conMatchesEqTagged c = case c of

113+ ForallC _ _ c' -> conMatchesEqTagged c'

114+ GadtC _ tys _ -> forTypes (map snd tys)

115+ _ -> error "conMatchesEqTagged: Unmatched constructor type"

116+ where

117+ name = conName c

118+ forTypes ts =

119+ [ do

120+ as <- mapM (\_ -> newName "a") ts

121+ bs <- mapM (\_ -> newName "b") ts

122+ x <- newName "x"

123+ y <- newName "y"

124+ let compareTagFields = foldr (\(a, b) e -> [| $(varE a) == $(varE b) && $(e) |]) [| True |] (zip as bs)

125+ match

126+ (tupP [conP name (map varP as), conP name (map varP bs)])

127+ (normalB (lamE [varP x, varP y] [| $(compareTagFields) && eq1 $(varE x) $(varE y) |] ))

128+ []

129+ , match

130+ (tupP [conP name (map (const wildP) ts), wildP])

131+ (normalB [| \ _ _ -> False |])

132+ []

133+ ]

134+

135+-- | Implementation of 'toJSON'

136+conMatchesToJSON :: Con -> MatchQ

137+conMatchesToJSON c = do

138+ let name = conName c

139+ base = nameBase name

140+ toJSONExp e = [| toJSON $(e) |]

141+ vars <- replicateM (conArity c) (newName "x")

142+ let body = toJSONExp $ tupE [ [| base :: String |] , tupE $ map (toJSONExp . varE) vars ]

143+ match (conP name (map varP vars)) (normalB body) []

144+

145+

146+-- | Implementation of 'parseJSON'

147+conMatchesParseJSON :: ExpQ -> Con -> MatchQ

148+conMatchesParseJSON e c = do

149+ let name = conName c

150+ match' = match (litP (StringL (nameBase name)))

151+ vars <- replicateM (conArity c) (newName "x")

152+ let forTypes _ = do

153+ let pat = tupP (map varP vars)

154+ conApp = foldl appE (conE name) (map varE vars)

155+ body = doE [ bindS pat [| parseJSON $e |]

156+ , noBindS [| return (This $conApp) |]

157+ ]

158+ match' (normalB body) []

159+ case c of

160+ ForallC _ _ c' -> conMatchesParseJSON e c'

161+ GadtC _ tys _ -> forTypes (map snd tys)

162+ NormalC _ tys -> forTypes (map snd tys)

163+ _ -> error "conMatchesParseJSON: Unmatched constructor type"

164+

165+type ToJSONFactor f g = (Has' ToJSON f g, ForallF ToJSON f)

166+type FromJSONFactor f g = (FromJSON (Some f), GCompare f, Has' FromJSON f g)

167+

168+type JSONFactor f = (ToJSONFactor f Identity, FromJSONFactor f Identity)

169+

170+instance ToJSONFactor f g => ToJSON (DSum f g) where

171+ toJSON ((f :: f a) :=> x) = toJSON (whichever @ToJSON @f @a (toJSON f), has' @ToJSON @g f (toJSON x))

172+

173+instance FromJSONFactor f g => FromJSON (DSum f g) where

174+ parseJSON x = do

175+ (tag, val) <- parseJSON x

176+ Some.This (parsedTag :: f a) <- parseJSON tag

177+ val' <- has' @FromJSON @g parsedTag (parseJSON val)

178+ return $ parsedTag :=> val'

179+

180+instance ToJSONFactor f g => ToJSON (DMap f g) where

181+ toJSON = toJSON . DMap.toList

182+

183+instance FromJSONFactor f g => FromJSON (DMap f g) where

184+ parseJSON = fmap DMap.fromList . parseJSON

lib/backend/src/Obelisk/Api.hs+26−95

@@ -1,3 +1,5 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE StandaloneDeriving #-}

1{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE LambdaCase #-}

5{-# LANGUAGE LambdaCase #-}

@@ -24,69 +26,20 @@ import Control.Monad (forever)

24import Control.Monad.Reader

26import Control.Monad.Reader

25import Control.Monad.Trans (lift)

27import Control.Monad.Trans (lift)

26import Data.Aeson (FromJSON, ToJSON)

28import Data.Aeson (FromJSON, ToJSON)

29+import Data.Align

27import Data.Attoparsec.ByteString

30import Data.Attoparsec.ByteString

28import Data.ByteString (ByteString)

31import Data.ByteString (ByteString)

29import Data.Default

32import Data.Default

33+import Data.Functor.Compose

30−import Data.Map.Monoidal (MonoidalMap)

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

31−import Data.MonoidMap (MonoidMap (..))

32import Data.Pool (withResource)

35import Data.Pool (withResource)

36+import Data.Vessel

33import qualified Database.PostgreSQL.Simple as PG

37import qualified Database.PostgreSQL.Simple as PG

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

38import qualified Database.PostgreSQL.Simple.Transaction as PG

35−import Reflex (FunctorMaybe (..))

36import Reflex.Patch (Group)

39import Reflex.Patch (Group)

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

40import Reflex.Query.Class (QueryResult, SelectedCount (..))

38import Snap.Core (Snap)

41import Snap.Core (Snap)

40−{-

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

42−newtype QueryHandler q m = QueryHandler

43− { runQueryHandler :: q -> m (QueryResult q) }

44−

45−-- | A way to push data into a pipeline

46−newtype Recipient q m = Recipient

47− { tellRecipient :: QueryResult q -> m () }

48−

49−-- | A way of attaching to (and later detaching from) a pipeline

50−newtype Registrar q = Registrar { unRegistrar :: Recipient q IO -> IO (QueryHandler q IO, IO ()) }

51−

52−-- | A way of connecting a source of data to a consumer of data. The consumer

53−-- can pull data from the datasource and the datasource can push data to the

54−-- consumer.

55−--

56−-- q is the consumer side

57−-- q' is the datasource side

58−newtype Pipeline m q q' = Pipeline { unPipeline :: QueryHandler q' m -> Recipient q m -> IO (QueryHandler q m, Recipient q' m) }

59−

60−instance Category (Pipeline m) where

61− id = Pipeline $ \qh r -> return (qh, r)

62− Pipeline f . Pipeline g = Pipeline $ \qh r -> do

63− rec (qh'', r') <- g qh' r

64− (qh', r'') <- f qh r'

65− return (qh'', r'')

66−

67−-- | A key used to track particular consumers

68−newtype ClientKey = ClientKey { unClientKey :: Integer }

69− deriving (Eq, Ord, Show)

70−

71−servePostgres

72− :: ( Monoid q'

73− , Semigroup q'

74− )

75− => Pool Postgresql -- ^ The DB to connect to

76− -> (forall a. request a -> write a)

77− -> (ByteString -> q' -> read (QueryResult q'))

78− -> (q' -> read (QueryResult q))

79− -> Pipeline IO q q'

80− -> (Snap () -> IO a)

81− -> IO a

82−servePostgres db handleApi handleNotify handleQuery pipe = do

83− (getNextNotification, finalizeListener) <- startNotificationListener db

84− rec (qh, finalizeFeed) <- feedPipeline (handleNotify <$> getNextNotification) handleQuery r

85− (qh', r) <- unPipeline pipe qh r'

86− (r', handleListen) <- connectPipelineToWebsockets "" (RequestHandler handleApi) qh'

87− return (handleListen, finalizeFeed >> finalizeListener)

88−-}

89−

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

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

91 deriving (Functor, Applicative, Monad)

44 deriving (Functor, Applicative, Monad)

@@ -114,43 +67,39 @@ unsafeWriteDb :: (PG.Connection -> IO a) -> WriteDb a

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

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

115

116withApiHandler

69withApiHandler

117− :: forall query queryResult request a.

70+ :: forall v query q0 request a.

118− ( Monoid (query SelectedCount)

71+ ( View v

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

72+ , Group (v (Const SelectedCount))

120− , QueryResult (query SelectedCount) ~ queryResult SelectedCount

73+ , query ~ v (Compose (MonoidalMap ClientKey) (Const SelectedCount))

121− , QueryResult (query ()) ~ queryResult ()

74+ , q0 ~ v Proxy

122− , Foldable queryResult

75+ , QueryResult query ~ v (Compose (MonoidalMap ClientKey) Identity)

123− , Functor query

76+ , QueryResult (v (Const SelectedCount)) ~ v Identity

124− , Functor queryResult

77+ , Monoid (v (Compose (MonoidalMap ClientKey) (Const SelectedCount)))

125− , FunctorMaybe queryResult

78+ , Monoid (v Identity)

126− , Monoid (query (MonoidMap ClientKey SelectedCount))

79+ , ToJSON (v Identity)

127− , Monoid (queryResult SelectedCount)

128− , Eq (queryResult SelectedCount)

129− , Eq (query (MonoidMap ClientKey SelectedCount))

130− , Eq (query SelectedCount)

131− , Group (query SelectedCount)

132− , ToJSON (queryResult ())

133− , FromJSON (query ())

80+ , FromJSON (v Proxy)

134 , Request request

81 , Request request

135 )

82 )

136 => ByteString -- ^ The URI of the DB to connect to

83 => ByteString -- ^ The URI of the DB to connect to

137 -> (forall x. request x -> WriteDb x) -- ^ How to handle an API request

84 -> (forall x. request x -> WriteDb x) -- ^ How to handle an API request

138− -> (forall x. query x -> Transaction -> ReadDb (QueryResult (query x))) -- ^ How to handle a change

85+ -> (v Proxy -> Transaction -> ReadDb (v Identity)) -- ^ How to handle a change

139− -> (forall x. query x -> ReadDb (QueryResult (query x))) -- ^ How to handle a query

86+ -> (v Proxy -> ReadDb (v Identity)) -- ^ How to handle a query

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

87 -> (Snap () -> IO a)

141 -> IO a

88 -> IO a

142withApiHandler dbUri handleApi handleChange handleQuery go = do

89withApiHandler dbUri handleApi handleChange handleQuery go = do

143 withNonEmptyTransactions dbUri $ \transactions -> do

90 withNonEmptyTransactions dbUri $ \transactions -> do

144 withConnectionPool dbUri $ \db -> do

91 withConnectionPool dbUri $ \db -> do

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

92+ let onChange :: Transaction -> v (Compose (MonoidalMap ClientKey) (Const SelectedCount)) -> IO (v (Compose (MonoidalMap ClientKey) Identity))

146− onChange m q = withResource db $ \conn -> readTransaction conn $ handleChange q m

93+ onChange txn q = withResource db $ \conn -> readTransaction conn $ mapDecomposedV (flip handleChange txn) q

147− let pipe :: Pipeline IO (MonoidalMap ClientKey (query SelectedCount)) (query (MonoidMap ClientKey SelectedCount))

94+ let pipe :: Pipeline IO (MonoidalMap ClientKey (v (Const SelectedCount))) (v (Compose (MonoidalMap ClientKey) (Const SelectedCount)))

148− pipe = queryMorphismPipeline $ transposeMonoidMap . monoidMapQueryMorphism

95+ pipe = queryMorphismPipeline transposeView

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

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

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

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

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

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

152 go handleListen

99 go handleListen

153

100

101+deriving instance Ord k => Align (MonoidalMap k)

102+

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

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

155withNonEmptyTransactions dbUri go = do

104withNonEmptyTransactions dbUri go = do

156 let opts = def

105 let opts = def

@@ -167,21 +116,3 @@ withNonEmptyTransactions dbUri go = do

167 atomically $ writeTChan transactions transaction

116 atomically $ writeTChan transactions transaction

168 withAsync processLines $ \a -> link a >> do

117 withAsync processLines $ \a -> link a >> do

169 go transactions

118 go transactions

170−{-

171−

172−standardChangeChannel :: PG.Identifier

173−standardChangeChannel = "obelisk_api_updates"

174−

175−standardChangeSubscriberTable :: PG.Identifier

176−standardChangeSubscriberTable = "obelisk_api_updates_subscriber"

177−

178−standardChangeSpillTable :: PG.Identifier

179−standardChangeSpillTable = "obelisk_api_updates_spill"

180−

181−-- | Listen on a Postgres notification channel. Uses a connection from the Pool for as long as it is r-- | Listen for Postgresql changes on a particular channel

182−withChangeListener :: FromJSON change => Pool PG.Connection -> (change -> IO ()) -> IO a -> IO a

183−withChangeListener db onChange = withBigNotificationListener db standardChangeChannel standardChangeSpillTable $ \message ->

184− case Aeson.eitherDecode' $ LBS.fromStrict message of

185− Left e -> fail $ "withChangeListener: " <> e

186− Right change -> onChange change

187−-}

lib/backend/src/Obelisk/Api/Pipeline.hs+44−43

@@ -1,4 +1,6 @@

1{-# LANGUAGE RecursiveDo #-}

2+{-# LANGUAGE TypeApplications #-}

3+{-# LANGUAGE KindSignatures #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE UndecidableInstances #-}

6{-# LANGUAGE UndecidableInstances #-}

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

10import Prelude hiding (id, (.))

12import Prelude hiding (id, (.))

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

14+import Obelisk.Request (Request)

16+import Data.Vessel

17+import Data.Constraint.Extras

18+import Data.Some (Some)

19+import qualified Data.Some as Some

14import Control.Concurrent

20import Control.Concurrent

15import Control.Monad

21import Control.Monad

16import Control.Monad.State.Strict

22import Control.Monad.State.Strict

@@ -152,8 +158,8 @@ data WebSocketRequest q r

152 | WebSocketRequest_Api (TaggedRequest r)

158 | WebSocketRequest_Api (TaggedRequest r)

153 deriving (Typeable, Generic)

159 deriving (Typeable, Generic)

154

160

155−instance (Request r, FromJSON q) => FromJSON (WebSocketRequest q r)

161+instance (FromJSON q, FromJSON (Some r)) => FromJSON (WebSocketRequest q r)

156−instance (Request r, ToJSON q) => ToJSON (WebSocketRequest q r)

162+instance (ToJSON q, ToJSON (Some r)) => ToJSON (WebSocketRequest q r)

157

163

158-- | Represents a WebSocket response from one of three channels: incoming 'View's, API responses, or version info

164-- | Represents a WebSocket response from one of three channels: incoming 'View's, API responses, or version info

159data WebSocketResponse q

165data WebSocketResponse q

@@ -166,11 +172,11 @@ instance FromJSON (QueryResult q) => FromJSON (WebSocketResponse q)

166instance ToJSON (QueryResult q) => ToJSON (WebSocketResponse q)

172instance ToJSON (QueryResult q) => ToJSON (WebSocketResponse q)

167

173

168-- | A request tagged with an identifier

174-- | A request tagged with an identifier

169−data TaggedRequest r = TaggedRequest Value (SomeRequest r)

175+data TaggedRequest r = TaggedRequest Value (Some r)

170 deriving (Typeable, Generic)

176 deriving (Typeable, Generic)

171

177

172−instance Request r => FromJSON (TaggedRequest r)

178+instance FromJSON (Some r) => FromJSON (TaggedRequest r)

173−instance Request r => ToJSON (TaggedRequest r)

179+instance ToJSON (Some r) => ToJSON (TaggedRequest r)

174

180

175-- | A response tagged with an identifier matching the one in the 'TaggedRequest'. The identifier is the first argument.

181-- | A response tagged with an identifier matching the one in the 'TaggedRequest'. The identifier is the first argument.

176data TaggedResponse = TaggedResponse Value Value

182data TaggedResponse = TaggedResponse Value Value

@@ -181,42 +187,39 @@ instance ToJSON TaggedResponse

181

187

182-- | Handles a websocket connection

188-- | Handles a websocket connection

183handleWebsocket

189handleWebsocket

184− :: forall q qr r.

190+ :: forall (v :: (* -> *) -> *) q q0 req.

185− ( Eq (q SelectedCount)

191+ ( View v

186− , Eq (qr SelectedCount)

192+ , Group (v (Const SelectedCount))

187− , QueryResult (q SelectedCount) ~ qr SelectedCount

193+ , q ~ v (Const SelectedCount)

194+ , q0 ~ v Proxy

188− , QueryResult (q ()) ~ qr ()

195+ , QueryResult q ~ v Identity

189− , ToJSON (qr ())

196+ , ToJSON (v Identity)

190− , Functor qr

191− , Group (q SelectedCount)

192− , Monoid (qr SelectedCount)

193− , FromJSON (q ())

197+ , FromJSON (v Proxy)

194− , Request r

198+ , Request req

195− , Functor q

196 )

199 )

197 => Text -- ^ Version

200 => Text -- ^ Version

198− -> (forall a. r a -> IO a)

201+ -> (forall a. req a -> IO a)

199− -> Registrar (q SelectedCount)

202+ -> Registrar q

200 -> Snap ()

203 -> Snap ()

201handleWebsocket v rh register = withWebsocketsConnection $ \conn -> do

204handleWebsocket v rh register = withWebsocketsConnection $ \conn -> do

202− let sender = Recipient $ sendEncodedDataMessage conn . (\a -> WebSocketResponse_View (void a) :: WebSocketResponse (q ()))

205+ let sender = Recipient $ sendEncodedDataMessage conn . (\a -> WebSocketResponse_View a :: WebSocketResponse q)

203− sendEncodedDataMessage conn (WebSocketResponse_Version v :: WebSocketResponse (q ()))

206+ sendEncodedDataMessage conn (WebSocketResponse_Version v :: WebSocketResponse q)

204 bracket (unRegistrar register sender) snd $ \(vsHandler, _) -> flip evalStateT mempty $ forever $ do

207 bracket (unRegistrar register sender) snd $ \(vsHandler, _) -> flip evalStateT mempty $ forever $ do

205− (wsr :: WebSocketRequest (q ()) r) <- liftIO $ getDataMessage conn

208+ (wsr :: WebSocketRequest q0 r) <- liftIO $ getDataMessage conn

206 case wsr of

209 case wsr of

207− WebSocketRequest_Api (TaggedRequest reqId (SomeRequest req)) -> lift $ do

210+ WebSocketRequest_Api (TaggedRequest reqId (Some.This req)) -> lift $ do

208 a <- rh req

211 a <- rh req

209 sendEncodedDataMessage conn

212 sendEncodedDataMessage conn

210− (WebSocketResponse_Api $ TaggedResponse reqId (toJSON a) :: WebSocketResponse (q ()))

213+ (WebSocketResponse_Api $ TaggedResponse reqId (has @ToJSON req (toJSON a)) :: WebSocketResponse q)

211 WebSocketRequest_ViewSelector new -> do

214 WebSocketRequest_ViewSelector new -> do

212 old <- get

215 old <- get

213− let new' = SelectedCount 1 <$ new

216+ let new' = mapV (const (Const (SelectedCount 1))) new

214 vsDiff = new' ~~ old

217 vsDiff = new' ~~ old

215− when (vsDiff /= mempty) $ do

218+ when (not (nullV vsDiff)) $ do

216 qr <- lift $ runQueryHandler vsHandler vsDiff

219 qr <- lift $ runQueryHandler vsHandler vsDiff

217 put new'

220 put new'

218− when (qr /= mempty) $ lift $

221+ when (not (nullV qr)) $ lift $

219− sendEncodedDataMessage conn (WebSocketResponse_View (void qr) :: WebSocketResponse (q ()))

222+ sendEncodedDataMessage conn (WebSocketResponse_View qr :: WebSocketResponse q)

220

223

221-------------------------------------------------------------------------------

224-------------------------------------------------------------------------------

222

225

@@ -249,24 +252,22 @@ feedPipeline getNextNotification qh r = do

249

252

250-- | Connects the pipeline to websockets consumers

253-- | Connects the pipeline to websockets consumers

251connectPipelineToWebsockets

254connectPipelineToWebsockets

252− :: ( Eq (q SelectedCount)

255+ :: forall v req q.

256+ ( View v

253− , QueryResult (q SelectedCount) ~ qr SelectedCount

257+ , q ~ v (Const SelectedCount)

254− , QueryResult (q ()) ~ qr ()

258+ , QueryResult q ~ v Identity

255− , Group (q SelectedCount)

259+ , Group q

256− , Monoid (qr SelectedCount)

260+ , Monoid (v Identity)

257− , Eq (qr SelectedCount)

258− , ToJSON (qr ())

261+ , ToJSON (v Identity)

259− , FromJSON (q ())

262+ , FromJSON (v Proxy)

260− , Request r

263+ , Request req

261− , Functor qr

262− , Functor q

263 )

264 )

264 => Text

265 => Text

265− -> (forall a. r a -> IO a)

266+ -> (forall a. req a -> IO a)

266 -- ^ API handler

267 -- ^ API handler

267− -> QueryHandler (MonoidalMap ClientKey (q SelectedCount)) IO

268+ -> QueryHandler (MonoidalMap ClientKey q) IO

268 -- ^ A way to retrieve more data for each consumer

269 -- ^ A way to retrieve more data for each consumer

269− -> IO (Recipient (MonoidalMap ClientKey (q SelectedCount)) IO, Snap ())

270+ -> IO (Recipient (MonoidalMap ClientKey q) IO, Snap ())

270 -- ^ A way to send data to many consumers and a handler for websockets connections

271 -- ^ A way to send data to many consumers and a handler for websockets connections

271connectPipelineToWebsockets ver rh qh = do

272connectPipelineToWebsockets ver rh qh = do

272 (allRecipients, registerRecipient) <- connectPipelineToWebsockets' qh

273 (allRecipients, registerRecipient) <- connectPipelineToWebsockets' qh

lib/request/obelisk-request.cabal+2−1

@@ -8,11 +8,12 @@ library

8 build-depends: base,

9 aeson,

10 constraints,

11+ constraints-extras,

12+ dependent-sum,

11 template-haskell,

13 template-haskell,

12 vector

14 vector

13 exposed-modules:

15 exposed-modules:

14 Obelisk.Request

16 Obelisk.Request

15− Obelisk.Request.TH

16 other-modules:

17 other-modules:

17 Obelisk.Request.HList

18 Obelisk.Request.HList

18 ghc-options: -Wall

19 ghc-options: -Wall

lib/request/src/Obelisk/Request.hs+7−19

@@ -1,25 +1,13 @@

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3module Obelisk.Request

5module Obelisk.Request

4− ( Request (..)

6+ ( Request

5− , SomeRequest (..)

6 ) where

7 ) where

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

9+import Data.Aeson (FromJSON, ToJSON)

9−import Data.Aeson.Types (Parser)

10−import Data.Constraint (Dict)

10+import Data.Constraint.Extras

11+import Data.Some (Some)

12−class Request r where

13+type Request r = (FromJSON (Some r), ToJSON (Some r), Has FromJSON r, Has ToJSON r) --TODO: shouldn't Has FromJSON r imply FromJSON (Some r) ?

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

skeleton/backend/src/Backend.hs+98−7

@@ -1,4 +1,6 @@

1{-# LANGUAGE EmptyCase #-}

2+{-# LANGUAGE PolyKinds #-}

3+{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE StandaloneDeriving #-}

4{-# LANGUAGE StandaloneDeriving #-}

3{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE UndecidableInstances #-}

6{-# LANGUAGE UndecidableInstances #-}

@@ -23,6 +25,14 @@

23{-# OPTIONS_GHC -fno-warn-orphans #-} --TODO: Eliminate this

25{-# OPTIONS_GHC -fno-warn-orphans #-} --TODO: Eliminate this

24module Backend where

26module Backend where

28+import Prelude hiding (id, (.))

29+

30+import Control.Category

31+import Control.Category.Monoidal (Monoidal)

32+import Control.Category.Braided

33+import Control.Categorical.Bifunctor

34+import Control.Category.Associative

35+import Control.Category.Cartesian

26import Control.Exception

36import Control.Exception

27import Control.Applicative

37import Control.Applicative

28import Control.Concurrent

38import Control.Concurrent

@@ -31,10 +41,12 @@ import Common.Schema

31import Backend.Schema

41import Backend.Schema

32import Common.Route

42import Common.Route

33import Data.Foldable

43import Data.Foldable

44+import Data.Functor.Misc

34import qualified Data.Map.Monoidal as Map

45import qualified Data.Map.Monoidal as Map

35import Data.Maybe

46import Data.Maybe

36import Data.Pool

47import Data.Pool

37import Data.Semigroup

48import Data.Semigroup

49+import Data.Vessel

38import Obelisk.Backend

50import Obelisk.Backend

39import Obelisk.Route

51import Obelisk.Route

40import Obelisk.Api

52import Obelisk.Api

@@ -65,7 +77,7 @@ import Reflex.Patch.MapWithMove2

66import Data.Proxy

78import Data.Proxy

68−import Control.Lens

80+import Control.Lens hiding (Bifunctor, bimap)

69import qualified GHC.Generics as Generic

81import qualified GHC.Generics as Generic

70import GHC.Generics hiding (R, C)

82import GHC.Generics hiding (R, C)

71import GHC.Types

83import GHC.Types

@@ -83,19 +95,19 @@ backend = Backend

83 print e

95 print e

84 forever $ threadDelay maxBound --TODO: Probably not necessary once we have `ob psql`

96 forever $ threadDelay maxBound --TODO: Probably not necessary once we have `ob psql`

85 Right _ -> pure ()

97 Right _ -> pure ()

86− let onNotify :: forall a. VS (Id Task) Task a -> Transaction -> ReadDb (V (Id Task) Task a)

98+ let onNotify :: VS (Id Task) (First Task) Proxy -> Transaction -> ReadDb (V (Id Task) (First Task) Identity)

87− onNotify (VS requested) txn = do

99+ onNotify (MapV requested) txn = do

88 decoded <- ReadDb $ do

100 decoded <- ReadDb $ do

89 conn <- ask

101 conn <- ask

90 lift $ decodeTransaction conn txn

102 lift $ decodeTransaction conn txn

91 traceM $ show $ _db_tasks decoded

103 traceM $ show $ _db_tasks decoded

92 traceM $ show $ _db_users decoded

104 traceM $ show $ _db_users decoded

93 tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db

105 tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db

94− pure $ V $ Map.intersectionWith (,) requested $ Map.fromList $ fmap (\x -> (TaskId $ _task_id x, First $ Just x)) tasks

106+ pure $ MapV $ Map.fromList $ fmap (\x -> (TaskId $ _task_id x, Identity $ First x)) tasks

95− onSubscribe :: forall a. VS (Id Task) Task a -> ReadDb (V (Id Task) Task a)

107+ onSubscribe :: VS (Id Task) (First Task) Proxy -> ReadDb (V (Id Task) (First Task) Identity)

96− onSubscribe (VS requested) = do

108+ onSubscribe (MapV requested) = do

97 tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db

109 tasks <- runSelectReturningList' $ select $ all_ $ _db_tasks db

98− pure $ V $ Map.intersectionWith (,) requested $ Map.fromList $ fmap (\x -> (TaskId $ _task_id x, First $ Just x)) tasks

110+ pure $ MapV $ Map.fromList $ fmap (\x -> (TaskId $ _task_id x, Identity $ First x)) tasks

99 onRequest :: forall a. MyRequest a -> WriteDb a

111 onRequest :: forall a. MyRequest a -> WriteDb a

100 onRequest = \case

112 onRequest = \case

101 MyRequest_Add a -> do

113 MyRequest_Add a -> do

@@ -113,6 +125,80 @@ backend = Backend

113 , _backend_routeEncoder = backendRouteEncoder

125 , _backend_routeEncoder = backendRouteEncoder

114 }

126 }

115

127

128+class CoCartesian' (k :: o -> o -> *) where

129+ type Sum' k :: (o -> *) -> o

130+ inSum :: tag x -> x `k` Sum' k tag

131+ outSum :: (forall x. tag x -> x `k` a) -> Sum' k tag `k` a

132+

133+class Cartesian' (k :: o -> o -> *) where

134+ type Product' k :: (o -> *) -> o

135+ outProd :: field x -> Product' k field `k` x

136+ inProd :: (forall x. field x -> a `k` x) -> a `k` Product' k field

137+ inProd' :: forall (field :: o -> *) (a :: o). (Product' (->) (WrapArg field (k a))) -> a `k` Product' k field

138+

139+newtype Product'Hask field = Product'Hask (forall x. field x -> x)

140+

141+instance Cartesian' (->) where

142+ type Product' (->) = Product'Hask

143+

144+{-

145+type MyAppView = CrudEverything MyAppDb

146+-}

147+

148+{-

149+crudEverything :: IV (PostgresDb a) (a CrudIF, someOtherIF)

150+crudEverything = (distributeIV $ MyDB

151+ { _myDb_thing = crudIV :: IV (TableEntity ThingT) (CrudIF Thing)

152+ }) &&& someOtherIV

153+

154+watch $ (mempty { _myDb_thing = crudPage 10 0 }, mempty)

155+-}

156+

157+{-

158+newtype PatchTarget' p = PatchTarget' (PatchTarget p)

159+

160+data Server a b = forall state. Server

161+ { _server_subscribe :: b Proxy -> ReadDb (b (Product state PatchTarget')) -- Output 'b' must have same shape as input

162+ , _server_notify :: Transaction -> b state -> ReadDb (b (Product state Identity)) -- Output state must have same shape as input state; output `b Identity` must be no larger than input `b State`, and should have size approximately proportional to the Transaction size. Output `b State` should generally not be fully traversed.

163+ , _server_request :: forall x. request x -> WriteDb x

164+ }

165+-}

166+

167+{-

168+data Delta x

169+

170+data IF query view request response

171+

172+data DBIn query request = (Event (Delta query), Event request)

173+

174+data DBOut view response = (Event (Partial view), Event (Delta view), Event response)

175+

176+--data Database query view request response

177+-- Such that: every Delta query triggers a Partial view; every request (by anyone) triggers a Delta view; every request (by us) triggers a response

178+database :: DBIn -> m DBOut

179+

180+times :: DBIn -> DBIn -> m (DBOut, DBOut)

181+

182+item :: DBOut dbView dbResponse -> DBIn appQuery appResponse -> m (DBIn dbQuery dbRequest, DBOut appView appResponse)

183+

184+data IV dbquery db dbreq request query result = forall state. IV

185+ { _iv_notify

186+ :: query

187+ -> Delta db --TODO: Should this be NonEmptyDelta, where NonEmptyDelta (a, b) = These (NonEmptyDelta a) (NonEmptyDelta b)

188+ -> state

189+ -> (state, Delta result)

190+ , _iv_subscribe :: Delta query -> db -> (state, result)

191+ , _iv_request :: request -> db -> (dbreq, a)

192+ }

193+

194+timesIV :: IV db request query result -> IV db2 request2 query2 result2 -> IV (db, db2) (Either request request2) (query, query2) (result, result2)

195+timesIV (IV n s {- r -}) (IV n2 s2 {- r2 -}) = IV

196+ (\(q, q2) (ddb, ddb2) (s, s2) -> _ (n q ddb s, n2 q2 ddb2 s2))

197+ _

198+

199+composeIV :: IV result (Delta db) query2 result2 -> IV db request query result

200+-}

201+

116class MonadBeamRead m where

202class MonadBeamRead m where

117 runSelectReturningList' :: FromBackendRow Postgres a => SqlSelect Postgres a -> m [a]

203 runSelectReturningList' :: FromBackendRow Postgres a => SqlSelect Postgres a -> m [a]

118 runSelectReturningOne' :: FromBackendRow Postgres a => SqlSelect Postgres a -> m (Maybe a)

204 runSelectReturningOne' :: FromBackendRow Postgres a => SqlSelect Postgres a -> m (Maybe a)

@@ -296,6 +382,11 @@ instance Beamable tbl => Patch (PartialUpdate tbl) where

296 type PatchTarget (PartialUpdate tbl) = tbl Identity

382 type PatchTarget (PartialUpdate tbl) = tbl Identity

297 apply (PartialUpdate new) old = zipBeamFieldsM (\(Columnar' newField) (Columnar' oldField) -> pure $ Columnar' $ fromMaybe oldField newField) new old

383 apply (PartialUpdate new) old = zipBeamFieldsM (\(Columnar' newField) (Columnar' oldField) -> pure $ Columnar' $ fromMaybe oldField newField) new old

298

384

385+availableValues :: PatchMapWithMove2 k p -> OldMap.Map k (PatchTarget p)

386+availableValues (PatchMapWithMove2 m) = flip OldMap.mapMaybe m $ \case

387+ NodeInfo { _nodeInfo_from = From_Insert v } -> Just v

388+ _ -> Nothing

389+

299decodeChange

390decodeChange

300 :: forall tbl

391 :: forall tbl

301 . Table tbl

392 . Table tbl

skeleton/common/src/Common/Api.hs+27−22

@@ -1,50 +1,55 @@

1−{-# LANGUAGE EmptyCase #-}

2−{-# LANGUAGE TemplateHaskell #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE TupleSections #-}

5−{-# LANGUAGE DeriveFunctor #-}

6{-# LANGUAGE DeriveFoldable #-}

1{-# LANGUAGE DeriveFoldable #-}

2+{-# LANGUAGE DeriveFunctor #-}

7{-# LANGUAGE DeriveTraversable #-}

3{-# LANGUAGE DeriveTraversable #-}

8−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+{-# LANGUAGE EmptyCase #-}

9−{-# LANGUAGE TypeApplications #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

12{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

13{-# LANGUAGE LambdaCase #-}

9{-# LANGUAGE LambdaCase #-}

14{-# LANGUAGE OverloadedStrings #-}

10{-# LANGUAGE OverloadedStrings #-}

11+{-# LANGUAGE PolyKinds #-}

15{-# LANGUAGE RankNTypes #-}

12{-# LANGUAGE RankNTypes #-}

13+{-# LANGUAGE ScopedTypeVariables #-}

14+{-# LANGUAGE TemplateHaskell #-}

15+{-# LANGUAGE TupleSections #-}

16+{-# LANGUAGE TypeApplications #-}

16{-# LANGUAGE TypeFamilies #-}

17{-# LANGUAGE TypeFamilies #-}

17module Common.Api where

18module Common.Api where

19import Common.Schema

20import Common.Schema

20import Data.Aeson

21import Data.Aeson

22+import Data.Aeson.GADT

21import Data.AppendMap ()

23import Data.AppendMap ()

24+import Data.Constraint.Extras.TH

22import Data.Functor.Identity

25import Data.Functor.Identity

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

26import Data.Map.Monoidal (MonoidalMap (..))

24import qualified Data.Map.Monoidal as Map

27import qualified Data.Map.Monoidal as Map

28+import Data.Vessel

25import Data.Semigroup

29import Data.Semigroup

26import Data.Text (Text)

30import Data.Text (Text)

27−import Obelisk.Request.TH

31+import Data.Functor.Compose

28import Reflex.Class

32import Reflex.Class

29import Reflex.Query.Class

33import Reflex.Query.Class

31−newtype VS k v a = VS (MonoidalMap k a)

35+type VS = MapV

32− deriving (Semigroup, Monoid, Functor, Foldable, Traversable, Group, ToJSON, FromJSON, Eq)

36+-- ()

33−

34−newtype V k v a = V (MonoidalMap k (a, First (Maybe v)))

35− deriving (Semigroup, Monoid, Functor, Foldable, Traversable, ToJSON, FromJSON, Eq)

36−

37−instance FunctorMaybe (V k v) where

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

40−instance (Ord k, Semigroup a) => Query (VS k v a) where

38+type V = MapV

41− type QueryResult (VS k v a) = V k v a

39+-- PatchMapWithMove2 (Id Task) (TaskT Maybe)

42− crop _ = id

44type family Id t where

41type family Id t where

45 Id (f Identity) = PrimaryKey f Identity

42 Id (f Identity) = PrimaryKey f Identity

47data MyRequest a where

44data MyRequest a where

48− MyRequest_Add :: Text -> MyRequest (Id Task)

45+ MyRequest_Add :: Text -> MyRequest (PrimaryKey TaskT Identity)

46+

47+--TODO: deriveArgDict REQUIRES PolyKinds; see if we can check for that in TH

48+deriveArgDict ''MyRequest

49+deriveJSONGADT ''MyRequest

50+

51+instance (Ord k, Ord k', Semigroup v) => Query (MapV (k :: *) (v :: *) (Compose (MonoidalMap k') (Const SelectedCount))) where

52+ type QueryResult (MapV k v (Compose (MonoidalMap k') (Const SelectedCount))) = MapV k v (Compose (MonoidalMap k') Identity)

50−makeRequestForData ''MyRequest

54+instance (Ord k, Semigroup v) => Query (MapV (k :: *) (v :: *) (Const SelectedCount)) where

55+ type QueryResult (MapV k v (Const SelectedCount)) = MapV k v Identity