git.iko.soy/purestack-dev/todomvc
on master help sign in
swap
99438955 ahead, 0 behind
.gitignore+4
since splitsnapshots
unifiedsplit
@@ -11,3 +11,7 @@
11backend.js
11backend.js
12frontend.js
12frontend.js
13result
13result
14+index.js
15+m36
16+backend.js.map
17+frontend.js.map
flake.lock+73−3
@@ -34,6 +34,23 @@
34 "type": "github"
34 "type": "github"
35 }
35 }
36 },
36 },
37+ "flake-utils_2": {
38+ "inputs": {
39+ "systems": "systems_2"
40+ },
41+ "locked": {
42+ "lastModified": 1731533236,
43+ "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
44+ "owner": "numtide",
45+ "repo": "flake-utils",
46+ "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
47+ "type": "github"
48+ },
49+ "original": {
50+ "id": "flake-utils",
51+ "type": "indirect"
52+ }
53+ },
37 "nixpkgs": {
54 "nixpkgs": {
38 "locked": {
55 "locked": {
39 "lastModified": 1750436177,
56 "lastModified": 1750436177,
@@ -65,6 +82,28 @@
65 "type": "github"
82 "type": "github"
66 }
83 }
67 },
84 },
85+ "project-m36-rest": {
86+ "inputs": {
87+ "flake-utils": "flake-utils_2",
88+ "nixpkgs": [
89+ "nixpkgs"
90+ ],
91+ "stacklock2nix": "stacklock2nix"
92+ },
93+ "locked": {
94+ "lastModified": 1751636615,
95+ "narHash": "sha256-8svgD2LdlamTqKqCkdf3ROQLckvnXP+vx3M5a57Kl5U=",
96+ "owner": "purestack-dev",
97+ "repo": "project-m36-rest",
98+ "rev": "c3a0331d62f7f5c9d90012d533e5713095a5fb4e",
99+ "type": "github"
100+ },
101+ "original": {
102+ "owner": "purestack-dev",
103+ "repo": "project-m36-rest",
104+ "type": "github"
105+ }
106+ },
68 "purescript-overlay": {
107 "purescript-overlay": {
69 "inputs": {
108 "inputs": {
70 "flake-compat": "flake-compat",
109 "flake-compat": "flake-compat",
@@ -107,6 +146,7 @@
107 "inputs": {
146 "inputs": {
108 "flake-utils": "flake-utils",
147 "flake-utils": "flake-utils",
109 "nixpkgs": "nixpkgs",
148 "nixpkgs": "nixpkgs",
149+ "project-m36-rest": "project-m36-rest",
110 "purescript-overlay": "purescript-overlay",
150 "purescript-overlay": "purescript-overlay",
111 "spago-nix": "spago-nix"
151 "spago-nix": "spago-nix"
112 }
152 }
@@ -138,11 +178,11 @@
138 "registry": "registry"
178 "registry": "registry"
139 },
179 },
140 "locked": {
180 "locked": {
141− "lastModified": 1750694836,
181+ "lastModified": 1750748667,
142− "narHash": "sha256-QxWjqgH4NapAYOCf7DG1t4G0aNO6sYgXZj+r8RAaIPA=",
182+ "narHash": "sha256-7RYmZu/q2zfGuYT0O57wXfS9/PDaHF86Kh7BDURDAZ8=",
143 "owner": "purestack-dev",
183 "owner": "purestack-dev",
144 "repo": "spago-nix",
184 "repo": "spago-nix",
145− "rev": "e0c303a269fee603809f458dfb62db974d573968",
185+ "rev": "cf33c40bf9174c4ce58637f5d882eef23ac3d3f5",
146 "type": "github"
186 "type": "github"
147 },
187 },
148 "original": {
188 "original": {
@@ -151,6 +191,21 @@
151 "type": "github"
191 "type": "github"
152 }
192 }
153 },
193 },
194+ "stacklock2nix": {
195+ "locked": {
196+ "lastModified": 1743151034,
197+ "narHash": "sha256-2QgpxnOyQg475wd0f/qzgG4fNqce1UearDjzZyrmMG8=",
198+ "owner": "cdepillabout",
199+ "repo": "stacklock2nix",
200+ "rev": "108f6ab6d0208e3842443bea26dfd72b37d82f28",
201+ "type": "github"
202+ },
203+ "original": {
204+ "owner": "cdepillabout",
205+ "repo": "stacklock2nix",
206+ "type": "github"
207+ }
208+ },
154 "systems": {
209 "systems": {
155 "locked": {
210 "locked": {
156 "lastModified": 1681028828,
211 "lastModified": 1681028828,
@@ -165,6 +220,21 @@
165 "repo": "default",
220 "repo": "default",
166 "type": "github"
221 "type": "github"
167 }
222 }
223+ },
224+ "systems_2": {
225+ "locked": {
226+ "lastModified": 1681028828,
227+ "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
228+ "owner": "nix-systems",
229+ "repo": "default",
230+ "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
231+ "type": "github"
232+ },
233+ "original": {
234+ "owner": "nix-systems",
235+ "repo": "default",
236+ "type": "github"
237+ }
168 }
238 }
169 },
239 },
170 "root": "root",
240 "root": "root",
flake.nix+14−4
@@ -7,8 +7,13 @@
7 inputs.nixpkgs.follows = "nixpkgs";
7 inputs.nixpkgs.follows = "nixpkgs";
8 };
8 };
9 spago-nix.url = "github:purestack-dev/spago-nix";
9 spago-nix.url = "github:purestack-dev/spago-nix";
10+ project-m36-rest = {
11+ url = "github:purestack-dev/project-m36-rest";
12+ inputs.nixpkgs.follows = "nixpkgs";
13+ };
10 };
14 };
11− outputs = { self, nixpkgs, flake-utils, purescript-overlay, spago-nix }:
15+ outputs = { self, nixpkgs, flake-utils, purescript-overlay, spago-nix
16+ , project-m36-rest }:
12 let supportedSystems = flake-utils.lib.defaultSystems;
17 let supportedSystems = flake-utils.lib.defaultSystems;
13 in flake-utils.lib.eachSystem supportedSystems (system:
18 in flake-utils.lib.eachSystem supportedSystems (system:
14 let
19 let
@@ -21,15 +26,20 @@
21 processes = {
26 processes = {
22 spago-frontend = {
27 spago-frontend = {
23 command =
28 command =
24− "${pkgs.spago}/bin/spago bundle-app --watch --main Frontend --to frontend.js";
29+ "${pkgs.spago}/bin/spago bundle-app --watch --main Frontend --source-maps --to frontend.js";
25 is_tty = true;
30 is_tty = true;
26 };
31 };
27 spago-backend = {
32 spago-backend = {
28 command =
33 command =
29− "${pkgs.spago}/bin/spago bundle-app --watch --main Backend --to backend.js";
34+ "${pkgs.spago}/bin/spago bundle-app --watch --main Backend --source-maps --to backend.js";
30 is_tty = true;
35 is_tty = true;
31 };
36 };
32− bun = { command = "${pkgs.bun}/bin/bun run --watch backend.js"; };
37+ bun.command = "${pkgs.bun}/bin/bun run --watch backend.js";
38+ project-m36.command = "${
39+ project-m36-rest.packages.${system}.default
40+ }/bin/project-m36-rest";
41+ proxy.command =
42+ "${pkgs.reproxy}/bin/reproxy -l=localhost:3001 --static.enabled --static.rule='*,^/api/(.*),http://localhost:3000/$$1' --assets.location=. --assets.spa --logger.stdout";
33 };
43 };
34 });
44 });
35 in {
45 in {
spago.dhall+1
@@ -15,6 +15,7 @@
15 , "effect"
15 , "effect"
16 , "either"
16 , "either"
17 , "enums"
17 , "enums"
18+ , "exceptions"
18 , "ezfetch"
19 , "ezfetch"
19 , "foldable-traversable"
20 , "foldable-traversable"
20 , "foreign"
21 , "foreign"
src/Backend.purs+52−1
@@ -1,11 +1,62 @@
1module Backend where
1module Backend where
2
2
3import Prelude
3import Prelude
4+import PureStack.Route
4
5
6+import Bun.Server as Bun
7+import Data.Argonaut (class DecodeJson, class EncodeJson)
8+import Data.Maybe (Maybe(..))
9+import Data.Newtype (class Newtype, unwrap, wrap)
10+import Data.URL as URL
5import Effect (Effect)
11import Effect (Effect)
12+import Effect.Aff (launchAff_)
13+import Effect.Aff.Class (liftAff)
14+import Effect.Class (liftEffect)
6import Effect.Console (log)
15import Effect.Console (log)
16+import Effect.Exception (throw)
17+import ProjectM36 (class RelVar, define, insert, lit, query, rel, relVar, withTransaction)
18+import ProjectM36 as M36
19+import PureStack.Client (class ToRequest)
20+import PureStack.Server (class FromRequest)
21+import PureStack.Server as Server
22+
23+newtype TodoItem = TodoItem { text :: String, done :: Boolean }
24+
25+derive instance Newtype TodoItem _
26+derive newtype instance EncodeJson TodoItem
27+derive newtype instance DecodeJson TodoItem
28+derive newtype instance ToRequest TodoItem
29+derive newtype instance FromRequest TodoItem
30+
31+instance RelVar TodoItem where
32+ relVar = "todo-item"
33+
34+type API =
35+ ( getTodos :: "todos" / GET Unit (Array TodoItem)
36+ , createTodo :: "todos" / POST TodoItem Unit
37+ )
7
38
8main :: Effect Unit
39main :: Effect Unit
9main = do
40main = do
10− log "backend!!!"
41+ m36Connection <- case URL.fromString "http://localhost:6543" of
42+ Just url -> pure $ M36.Connection url
43+ Nothing -> throw "Invalid m36 URL"
44+
45+ launchAff_ do
46+ liftEffect $ log "Creating relational variables"
47+ withTransaction m36Connection do
48+ define @TodoItem
49+ liftEffect $ log "Done"
11
50
51+ liftEffect $ Bun.serve $ Server.run @API identity
52+ { handlers:
53+ { getTodos: do
54+ liftAff $ withTransaction m36Connection $ do
55+ (map <<< map) wrap <$> query $ rel @TodoItem
56+ , createTodo: \todo -> do
57+ liftAff $ withTransaction m36Connection $ do
58+ insert @TodoItem $ lit [ todo ]
59+ pure unit
60+ }
61+ , middlewares: {}
62+ }
src/Frontend.purs+51−2
@@ -1,11 +1,60 @@
1module Frontend where
1module Frontend where
2
2
3+import Backend
4+import Plum.View
3import Prelude
5import Prelude
6+import Prim
4
7
8+import Data.Array ((:))
9+import Data.Foldable (for_)
10+import Data.URL as URL
5import Effect (Effect)
11import Effect (Effect)
6−import Effect.Console (log)
12+import Plum as Plum
13+import PureStack.Client (client)
14+
15+type Model = { newTodo :: String, todos :: Array TodoItem }
16+
17+data Msg
18+ = UpdateNewTodo String
19+ | SetTodos (Array TodoItem)
20+ | AddNewTodo
21+ | TodoAdded
7
22
8main :: Effect Unit
23main :: Effect Unit
9main = do
24main = do
10− log "frontend"
25+ origin <- Plum.currentOrigin
26+ let api = getApi (origin `URL.addSegment` "api")
27+ Plum.run @Model @Msg "plum"
28+ { init: \runMsg -> do
29+ runMsg $ SetTodos <$> api.getTodos
30+ pure { newTodo: "", todos: [] }
31+ , update: \runMsg msg model -> case msg of
32+ UpdateNewTodo newTodo -> pure model { newTodo = newTodo }
33+ AddNewTodo -> do
34+ runMsg $ api.createTodo (TodoItem { text: model.newTodo, done: false }) $> TodoAdded
35+ pure model
36+ TodoAdded -> do
37+ runMsg $ SetTodos <$> api.getTodos
38+ pure model
39+ SetTodos todos -> pure model { todos = todos }
40+ , view: \model -> column do
41+ font "sans-serif"
42+
43+ column $ height (Px 30)
44+ text "todos" do
45+ fontSize 80
46+ fontColor (rgb255 184 63 69)
47+ column $ do
48+ width (Px 550)
49+
50+ textInput { onChange: UpdateNewTodo, value: model.newTodo } do
51+ fontSize 24
52+
53+ onKey "Enter" AddNewTodo
54+
55+ for_ model.todos $ \(TodoItem todo) -> do
56+ text todo.text mempty
57+ }
58+
59+getApi = client @API
11
60
src/Plum.purs+51−16
@@ -1,52 +1,71 @@
1−module Plum (Plum, run) where
1+module Plum (Plum, run, currentOrigin) where
2
2
3import Prelude
3import Prelude
4
4
5import Data.Array as Array
5import Data.Array as Array
6import Data.Maybe (Maybe(..))
6import Data.Maybe (Maybe(..))
7+import Data.URL (URL)
8+import Data.URL as URL
7import Effect (Effect)
9import Effect (Effect)
10+import Effect.Aff (Aff, launchAff_)
11+import Effect.Class (liftEffect)
8import Effect.Console (log)
12import Effect.Console (log)
13+import Effect.Exception (throw)
9import Effect.Ref as Ref
14import Effect.Ref as Ref
10import Foreign.Object as Object
15import Foreign.Object as Object
11import Literals.Undefined (undefined)
16import Literals.Undefined (undefined)
12import Plum.View (GenericUI(..), UI, grow)
17import Plum.View (GenericUI(..), UI, grow)
13import Snabbdom as Snabbdom
18import Snabbdom as Snabbdom
19+import Unsafe.Coerce (unsafeCoerce)
14import Untagged.Union (asOneOf)
20import Untagged.Union (asOneOf)
15import Web.DOM.NonElementParentNode (getElementById) as Web
21import Web.DOM.NonElementParentNode (getElementById) as Web
16import Web.HTML (window) as Web
22import Web.HTML (window) as Web
23+import Web.HTML.Event.EventTypes (invalid)
17import Web.HTML.HTMLDocument (toNonElementParentNode) as Web
24import Web.HTML.HTMLDocument (toNonElementParentNode) as Web
25+import Web.HTML.Location as Location
18−import Web.HTML.Window (document) as Web
26+import Web.HTML.Window (document, location) as Web
19
27
20type Plum msg model =
28type Plum msg model =
21− { init :: Effect model
29+ { init :: (Aff msg -> Effect Unit) -> Effect model
22− , update :: msg -> model -> Effect model
30+ , update :: (Aff msg -> Effect Unit) -> msg -> model -> Effect model
23 , view :: model -> UI msg Unit
31 , view :: model -> UI msg Unit
24 }
32 }
25
33
26−run :: forall msg model. String -> Plum msg model -> Effect Unit
34+run :: forall @model @msg. String -> Plum msg model -> Effect Unit
27run id plum = do
35run id plum = do
28 Web.window >>= Web.document >>= Web.getElementById id <<< Web.toNonElementParentNode >>= case _ of
36 Web.window >>= Web.document >>= Web.getElementById id <<< Web.toNonElementParentNode >>= case _ of
29 Just element -> do
37 Just element -> do
30 let node = Snabbdom.toVNode element
38 let node = Snabbdom.toVNode element
39+ modelRef <- Ref.new { model: unsafeCoerce undefined, lastNode: node }
31 patch <- Snabbdom.init
40 patch <- Snabbdom.init
32− initModel <- plum.init
33− modelRef <- Ref.new { model: initModel, lastNode: node }
34 let
41 let
42+ fire =
43+ ( \msg -> do
44+ log "in"
45+ { model: m, lastNode } <- Ref.read modelRef
46+ m_ <- plum.update
47+ ( \aff ->
48+ launchAff_
49+ ( do
50+ msg' <- aff
51+ liftEffect $ fire msg'
52+ pure unit
53+ )
54+ )
55+ msg
56+ m
57+ node' <- view m_
58+ newNode <- patch lastNode node'
59+ Ref.write { model: m_, lastNode: newNode } modelRef
60+ pure unit
61+ )
35 view model = do
62 view model = do
36 let UI { children } _ = plum.view model
63 let UI { children } _ = plum.view model
37 case Array.uncons children of
64 case Array.uncons children of
38 Just { head: child } -> do
65 Just { head: child } -> do
39 let
66 let
40 { node, style } = grow
67 { node, style } = grow
41− ( \msg -> do
68+ fire
42− log "in"
43− { model: m, lastNode } <- Ref.read modelRef
44− m_ <- plum.update msg m
45− node <- view m_
46− newNode <- patch lastNode node
47− Ref.write { model: m_, lastNode: newNode } modelRef
48− pure unit
49− )
50 child
69 child
51 pure $
70 pure $
52 Snabbdom.h "div"
71 Snabbdom.h "div"
@@ -75,6 +94,15 @@ run id plum = do
75 }
94 }
76 []
95 []
77 (asOneOf undefined)
96 (asOneOf undefined)
97+ initModel <- plum.init
98+ ( \aff ->
99+ launchAff_
100+ ( do
101+ msg' <- aff
102+ liftEffect $ fire msg'
103+ pure unit
104+ )
105+ )
78 newNode <- view initModel
106 newNode <- view initModel
79 newNode_ <- patch node newNode
107 newNode_ <- patch node newNode
80 log "patched"
108 log "patched"
@@ -84,3 +112,10 @@ run id plum = do
84
112
85outerStyle :: String
113outerStyle :: String
86outerStyle = "html,body{height:100%;padding:0;margin:0;}"
114outerStyle = "html,body{height:100%;padding:0;margin:0;}"
115+
116+currentOrigin :: Effect URL
117+currentOrigin = do
118+ s <- Web.window >>= Web.location >>= Location.origin
119+ case URL.fromString s of
120+ Nothing -> throw "window.location.origin returned an invalid url"
121+ Just url -> pure url
src/Plum/View.purs+26−2
@@ -54,9 +54,12 @@ module Plum.View
54 , onHover
54 , onHover
55 , onMouseDown
55 , onMouseDown
56 , font
56 , font
57+ , fontColor
57 , fontSize
58 , fontSize
58 , fontWeight
59 , fontWeight
59 , onClick
60 , onClick
61+ , onPress
62+ , onKey
60 ) where
63 ) where
61
64
62import Prelude
65import Prelude
@@ -88,8 +91,10 @@ import Web.DOM.Element as Element
88import Web.DOM.ParentNode (firstElementChild)
91import Web.DOM.ParentNode (firstElementChild)
89import Web.Event.Event (Event)
92import Web.Event.Event (Event)
90import Web.Event.Event as Event
93import Web.Event.Event as Event
91−import Web.UIEvent.InputEvent as InputEvent
92import Web.HTML.HTMLInputElement as HTMLInputElement
94import Web.HTML.HTMLInputElement as HTMLInputElement
95+import Web.UIEvent.InputEvent as InputEvent
96+import Web.UIEvent.KeyboardEvent (KeyboardEvent)
97+import Web.UIEvent.KeyboardEvent as KeyboardEvent
93
98
94type GenericUIView children msg =
99type GenericUIView children msg =
95 { nerves :: Array (Nerve msg)
100 { nerves :: Array (Nerve msg)
@@ -249,6 +254,13 @@ n nerve = UI (mempty :: GenericUIView ch msg) { nerves = [ nerve ] } mempty
249onClick :: forall ch msg. Monoid ch => msg -> GenericUI ch msg Unit
254onClick :: forall ch msg. Monoid ch => msg -> GenericUI ch msg Unit
250onClick msg = n $ OnClick msg
255onClick msg = n $ OnClick msg
251
256
257+onPress :: forall ch msg. Monoid ch => (KeyboardEvent -> msg) -> GenericUI ch msg Unit
258+onPress msg = n $ OnPress msg
259+
260+-- | https://developer.mozilla.org/en-US/docs/Web/API/UI_Events/Keyboard_event_code_values
261+onKey :: forall ch msg. Monoid ch => String -> msg -> GenericUI ch msg Unit
262+onKey key msg = n $ OnKey key msg
263+
252m :: forall ch msg. Monoid ch => Meat -> GenericUI ch msg Unit
264m :: forall ch msg. Monoid ch => Meat -> GenericUI ch msg Unit
253m meat = UI (mempty :: GenericUIView ch msg) { meat = [ meat ] } mempty
265m meat = UI (mempty :: GenericUIView ch msg) { meat = [ meat ] } mempty
254
266
@@ -321,6 +333,9 @@ innerShadow cfg = m $ InnerShadow $ ShadowCfg cfg
321font :: forall ch msg. Monoid ch => String -> GenericUI ch msg Unit
333font :: forall ch msg. Monoid ch => String -> GenericUI ch msg Unit
322font f = m $ Font f
334font f = m $ Font f
323
335
336+fontColor :: forall ch msg. Monoid ch => Color -> GenericUI ch msg Unit
337+fontColor c = m $ FontColor c
338+
324fontSize :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
339fontSize :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
325fontSize f = m $ FontSize f
340fontSize f = m $ FontSize f
326
341
@@ -401,7 +416,10 @@ instance Renderable Side where
401 Bottom -> "bottom"
416 Bottom -> "bottom"
402 Left -> "left"
417 Left -> "left"
403
418
404−data Nerve msg = OnClick msg
419+data Nerve msg
420+ = OnClick msg
421+ | OnPress (KeyboardEvent -> msg)
422+ | OnKey String msg
405
423
406newtype WiredNerves = WiredNerves (Object (Event -> Effect Unit))
424newtype WiredNerves = WiredNerves (Object (Event -> Effect Unit))
407
425
@@ -415,6 +433,12 @@ instance Monoid WiredNerves where
415wireNerve :: forall msg. (msg -> Effect Unit) -> Nerve msg -> WiredNerves
433wireNerve :: forall msg. (msg -> Effect Unit) -> Nerve msg -> WiredNerves
416wireNerve fire nerve = WiredNerves $ case nerve of
434wireNerve fire nerve = WiredNerves $ case nerve of
417 OnClick msg -> Object.singleton "click" $ \_ev -> fire msg
435 OnClick msg -> Object.singleton "click" $ \_ev -> fire msg
436+ OnPress msg -> Object.singleton "keypress" $ \ev -> case KeyboardEvent.fromEvent ev of
437+ Nothing -> pure unit
438+ Just keyboardEvent -> fire $ msg keyboardEvent
439+ OnKey key msg -> Object.singleton "keypress" $ \ev -> case KeyboardEvent.fromEvent ev of
440+ Just keyboardEvent | KeyboardEvent.code keyboardEvent == key -> fire msg
441+ _ -> pure unit
418
442
419type View msg =
443type View msg =
420 { nerves :: Array (Nerve msg)
444 { nerves :: Array (Nerve msg)
src/ProjectM36.purs+17−7
@@ -65,11 +65,13 @@ import Data.Set as Set
65import Data.Traversable (traverse)
65import Data.Traversable (traverse)
66import Data.Tuple.Nested (type (/\), (/\))
66import Data.Tuple.Nested (type (/\), (/\))
67import Data.URL (URL, addSegment)
67import Data.URL (URL, addSegment)
68+import Debug (traceM)
68import Effect.Aff (Aff, bracket, error, throwError)
69import Effect.Aff (Aff, bracket, error, throwError)
69import Effect.Aff.HTTP (Method(..), fetch)
70import Effect.Aff.HTTP (Method(..), fetch)
70import Effect.Aff.HTTP.Request as Request
71import Effect.Aff.HTTP.Request as Request
71import Effect.Aff.HTTP.Response (Response)
72import Effect.Aff.HTTP.Response (Response)
72import Effect.Aff.HTTP.Response as Response
73import Effect.Aff.HTTP.Response as Response
74+import Effect.Class.Console (log)
73import Foreign (Foreign, unsafeFromForeign, unsafeToForeign)
75import Foreign (Foreign, unsafeFromForeign, unsafeToForeign)
74import Foreign.Object (Object)
76import Foreign.Object (Object)
75import Foreign.Object as Object
77import Foreign.Object as Object
@@ -92,7 +94,7 @@ data Expr
92
94
93instance EncodeJson Expr where
95instance EncodeJson Expr where
94 encodeJson = case _ of
96 encodeJson = case _ of
95− Lit l -> l
97+ Lit l -> encodeJson l
96 Join x y -> encodeJson { join: [ x, y ] }
98 Join x y -> encodeJson { join: [ x, y ] }
97 Union x y -> encodeJson { union: [ x, y ] }
99 Union x y -> encodeJson { union: [ x, y ] }
98 Project proj expr -> encodeJson { proj: { proj: proj, expr: expr } }
100 Project proj expr -> encodeJson { proj: { proj: proj, expr: expr } }
@@ -116,8 +118,14 @@ class LiteralRelation r fields | r -> fields where
116instance (RowList.RowToList fields fields', Relatable fields fields') => LiteralRelation (Array (Record fields)) fields where
118instance (RowList.RowToList fields fields', Relatable fields fields') => LiteralRelation (Array (Record fields)) fields where
117 lit r = Rel $ Lit $ encodeJson { lit: { attrs: attributeTypes @fields @fields', vals: encodeRelation @fields @fields' <$> r } }
119 lit r = Rel $ Lit $ encodeJson { lit: { attrs: attributeTypes @fields @fields', vals: encodeRelation @fields @fields' <$> r } }
118
120
121+else instance
122+ ( Newtype r (Record fields)
123+ , LiteralRelation (Array (Record field)) fields
124+ , RowToList fields fields'
125+ , Relatable fields fields'
126+ ) =>
119−else instance (LiteralRelation (Record fields) fields, Newtype r (Record fields)) => LiteralRelation r fields where
127+ LiteralRelation (Array r) fields where
120− lit = unwrap >>> lit
128+ lit = map unwrap >>> lit
121
129
122rel :: forall @rel fields. Newtype rel (Record fields) => RelVar rel => Rel fields
130rel :: forall @rel fields. Newtype rel (Record fields) => RelVar rel => Rel fields
123rel = Rel $ RelationVariable (relVar @rel)
131rel = Rel $ RelationVariable (relVar @rel)
@@ -474,7 +482,7 @@ define
474 => Transaction Unit
482 => Transaction Unit
475define = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do
483define = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do
476 fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)
484 fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)
477− { body: Request.json { define: { name: relVar @rel, attrs: Object.fromFoldable (attributeTypes @fields @fields') } } }
485+ { body: Request.json $ jsonToForeign $ encodeJson { define: { name: relVar @rel, attrs: attributeTypes @fields @fields' } } }
478 >>= Response.guardStatusOk
486 >>= Response.guardStatusOk
479 pure unit
487 pure unit
480
488
@@ -485,8 +493,9 @@ insert
485 => Rel fields
493 => Rel fields
486 -> Transaction Unit
494 -> Transaction Unit
487insert (Rel r) = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do
495insert (Rel r) = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do
496+ traceM $ jsonToForeign $ encodeJson { insert: { name: relVar @rel, rel: r } }
488 fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)
497 fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)
489− { body: Request.json { insert: { name: relVar @rel, rel: jsonToForeign (encodeJson r) } } }
498+ { body: Request.json $ jsonToForeign $ encodeJson { insert: { name: relVar @rel, rel: r } } }
490 >>= Response.guardStatusOk
499 >>= Response.guardStatusOk
491 pure unit
500 pure unit
492
501
@@ -498,7 +507,7 @@ query
498 -> Transaction (Array (Record fields))
507 -> Transaction (Array (Record fields))
499query (Rel r) = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do
508query (Rel r) = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do
500 resp <- fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)
509 resp <- fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)
501− { body: Request.json { query: jsonToForeign (encodeJson r) } }
510+ { body: Request.json $ jsonToForeign $ encodeJson { query: r } }
502 Response.guardStatusOk resp
511 Response.guardStatusOk resp
503 j <- json resp
512 j <- json resp
504 case decodeRelation @fields @fields' j of
513 case decodeRelation @fields @fields' j of
@@ -510,7 +519,8 @@ decodeRelation
510 . BuildRelation fields fields'
519 . BuildRelation fields fields'
511 => Json
520 => Json
512 -> Either JsonDecodeError (Array (Record fields))
521 -> Either JsonDecodeError (Array (Record fields))
522+decodeRelation j = do
513−decodeRelation j = decodeRelationJson j >>= traverse (decodeRelationFromObject @fields @fields')
523+ decodeRelationJson j >>= traverse (decodeRelationFromObject @fields @fields')
514
524
515jsonToForeign :: Json -> Foreign
525jsonToForeign :: Json -> Foreign
516jsonToForeign = unsafeCoerce
526jsonToForeign = unsafeCoerce
src/PureStack/Client.pursnew file+282
@@ -0,0 +1,282 @@
1+module PureStack.Client
2+ ( module PureStack.Route
3+ , client
4+ -------------------------------------------------------------------------------------------------
5+ , class ClientAPI
6+ , clientAPI
7+ , class ClientRoute
8+ , clientRoute
9+ , class EzFetchMethod
10+ , ezFetchMethod
11+ , class ToRequest
12+ , toRequest
13+ , class FromResponse
14+ , fromResponse
15+ , class ToPathPiece
16+ , toPathPiece
17+ , class ClientQuery
18+ , clientQuery
19+ ) where
20+
21+import Prelude
22+import PureStack.Route
23+
24+import Control.Alternative (class Alternative, empty)
25+import Data.Argonaut (class DecodeJson, class EncodeJson, Json, JsonDecodeError, decodeJson, encodeJson)
26+import Data.ArrayBuffer.Types (ArrayBuffer)
27+import Data.Either (Either(..))
28+import Data.Map as Map
29+import Data.Maybe (Maybe(..))
30+import Data.Symbol (class IsSymbol, reflectSymbol)
31+import Data.Tuple.Nested ((/\))
32+import Data.URL (URL, addQuery)
33+import Data.URL as URL
34+import Effect.Aff (Aff)
35+import Effect.Aff.Class (class MonadAff, liftAff)
36+import Effect.Aff.HTTP (Method(..), OptionalFields, fetch)
37+import Effect.Aff.HTTP.Header as Response
38+import Effect.Aff.HTTP.Request (Body(..), Credentials(..))
39+import Effect.Aff.HTTP.Request as HTTP
40+import Effect.Aff.HTTP.Response (Response)
41+import Effect.Aff.HTTP.Response as Response
42+import Foreign (Foreign)
43+import Prim.Row as Row
44+import Prim.RowList (class RowToList, RowList)
45+import Prim.RowList as RowList
46+import Record as Record
47+import Record.Builder (Builder)
48+import Record.Builder as Builder
49+import Type.Prelude (Proxy(..))
50+import Unsafe.Coerce (unsafeCoerce)
51+
52+class ClientAPI :: forall k. Row k -> RowList k -> Row Type -> Constraint
53+class ClientAPI row list req | row -> req, list -> row where
54+ clientAPI :: URL -> Builder (Record ()) (Record req)
55+
56+instance ClientAPI () RowList.Nil () where
57+ clientAPI _ = identity
58+
59+instance
60+ ( ClientRoute route req
61+ , Row.Cons field route tail row
62+ , Row.Cons field req reqTail reqs
63+ , ClientAPI tail rest reqTail
64+ , Row.Lacks field reqTail
65+ , IsSymbol field
66+ ) =>
67+ ClientAPI row (RowList.Cons field route rest) reqs where
68+ clientAPI baseUrl =
69+ clientAPI @tail @rest baseUrl >>> Builder.insert (Proxy @field) (clientRoute @route @req baseUrl)
70+
71+client :: forall @row rowList reqs. RowToList row rowList => ClientAPI row rowList reqs => URL -> Record reqs
72+client baseUrl = Builder.buildFromScratch (clientAPI @row @rowList baseUrl)
73+
74+class ClientRoute :: forall k. k -> Type -> Constraint
75+class ClientRoute route request | route -> request where
76+ clientRoute :: URL -> request
77+
78+instance (IsSymbol path, ClientRoute rest req) => ClientRoute (path / rest) req where
79+ clientRoute = \baseUrl -> clientRoute @rest (baseUrl `URL.addSegment` reflectSymbol (Proxy @path))
80+
81+else instance (ClientRoute rest req, ClientQuery row rowList, RowToList row rowList) => ClientRoute (Record row / rest) (Record row -> req) where
82+ clientRoute = \baseUrl rec -> clientRoute @rest (clientQuery @row @rowList rec baseUrl)
83+
84+else instance ClientRoute rest req => ClientRoute (Middleware middleware / rest) req where
85+ clientRoute = clientRoute @rest
86+
87+else instance (ToPathPiece t, ClientRoute rest req) => ClientRoute (t / rest) (t -> req) where
88+ clientRoute = \baseUrl t -> clientRoute @rest (baseUrl `URL.addSegment` toPathPiece t)
89+
90+else instance
91+ ( MethodName (meth req resp)
92+ , EzFetchMethod (meth req resp)
93+ , FromResponse resp
94+ ) =>
95+ ClientRoute (meth Unit (Headers headers resp)) (Aff resp) where
96+ clientRoute = \baseUrl -> do
97+ fetch (ezFetchMethod @(meth req resp)) baseUrl (toRequest unit)
98+ >>= (liftAff <<< fromResponse)
99+ >>= case _ of
100+ Nothing -> empty
101+ Just x -> pure x
102+
103+else instance
104+ ( MethodName (meth req resp)
105+ , EzFetchMethod (meth req resp)
106+ , ToRequest req
107+ , FromResponse resp
108+ ) =>
109+ ClientRoute (meth req (Headers headers resp)) (req -> Aff resp) where
110+ clientRoute = \baseUrl req -> do
111+ fetch (ezFetchMethod @(meth req resp)) baseUrl (toRequest req)
112+ >>= (liftAff <<< fromResponse)
113+ >>= case _ of
114+ Nothing -> empty
115+ Just x -> pure x
116+
117+else instance
118+ ( MethodName (meth req resp)
119+ , EzFetchMethod (meth req resp)
120+ , FromResponse resp
121+ ) =>
122+ ClientRoute (meth Unit resp) (Aff resp) where
123+ clientRoute = \baseUrl -> do
124+ fetch (ezFetchMethod @(meth req resp)) baseUrl (toRequest unit)
125+ >>= (liftAff <<< fromResponse)
126+ >>= case _ of
127+ Nothing -> empty
128+ Just x -> pure x
129+
130+else instance
131+ ( MethodName (meth req resp)
132+ , EzFetchMethod (meth req resp)
133+ , ToRequest req
134+ , FromResponse resp
135+ ) =>
136+ ClientRoute (meth req resp) (req -> Aff resp) where
137+ clientRoute = \baseUrl req -> do
138+ fetch (ezFetchMethod @(meth req resp)) baseUrl (toRequest req)
139+ >>= (liftAff <<< fromResponse)
140+ >>= case _ of
141+ Nothing -> empty
142+ Just x -> pure x
143+else instance (ClientAPI routes routesList req, RowToList routes routesList) => ClientRoute routes (Record req) where
144+ clientRoute baseUrl = Builder.buildFromScratch $ clientAPI @routes @routesList baseUrl
145+
146+class ClientQuery :: Row Type -> RowList Type -> Constraint
147+class ClientQuery row list where
148+ clientQuery :: Record row -> URL -> URL
149+
150+instance ClientQuery row RowList.Nil where
151+ clientQuery _ url = url
152+
153+instance
154+ ( ClientQuery row rest
155+ , ToPathPiece t
156+ , IsSymbol field
157+ , Row.Cons field (Array t) tail row
158+ ) =>
159+ ClientQuery row (RowList.Cons field (Array t) rest) where
160+ clientQuery rec =
161+ flip addQuery ((reflectSymbol (Proxy @field)) /\ map toPathPiece (Record.get (Proxy @field) rec))
162+ <<< clientQuery @row @rest rec
163+else instance
164+ ( ClientQuery row rest
165+ , ToPathPiece t
166+ , IsSymbol field
167+ , Row.Cons field (Maybe t) tail row
168+ ) =>
169+ ClientQuery row (RowList.Cons field (Maybe t) rest) where
170+ clientQuery rec = case (Record.get (Proxy @field) rec) of
171+ Just x ->
172+ flip addQuery ((reflectSymbol (Proxy @field)) /\ toPathPiece x)
173+ <<< clientQuery @row @rest rec
174+ Nothing -> identity
175+else instance
176+ ( ClientQuery row rest
177+ , ToPathPiece t
178+ , IsSymbol field
179+ , Row.Cons field t tail row
180+ ) =>
181+ ClientQuery row (RowList.Cons field t rest) where
182+ clientQuery rec =
183+ flip addQuery ((reflectSymbol (Proxy @field)) /\ toPathPiece (Record.get (Proxy @field) rec))
184+ <<< clientQuery @row @rest rec
185+
186+class ToPathPiece t where
187+ toPathPiece :: t -> String
188+
189+instance ToPathPiece String where
190+ toPathPiece s = s
191+
192+instance ToPathPiece Int where
193+ toPathPiece = show
194+
195+instance ToPathPiece Number where
196+ toPathPiece = show
197+
198+instance ToPathPiece Boolean where
199+ toPathPiece = show
200+
201+class ToRequest r where
202+ toRequest :: r -> Record OptionalFields
203+
204+instance ToRequest Body where
205+ toRequest body = { body, credentials: IncludeCredentials, headers: mempty }
206+
207+instance EncodeJson (Record row) => ToRequest (Record row) where
208+ toRequest body = { body: HTTP.json (jsonToForeign $ encodeJson body), credentials: IncludeCredentials, headers: mempty }
209+
210+instance ToRequest Unit where
211+ toRequest _ = { body: BodyEmpty, credentials: IncludeCredentials, headers: mempty }
212+
213+instance (ToRequest req, RowToList headers headersList, ToHeaders headers headersList) => ToRequest (Headers (Record headers) req) where
214+ toRequest (Headers headers req) =
215+ let
216+ request = toRequest req
217+ in
218+ request
219+ { headers =
220+ Response.Headers (Map.fromFoldableWithIndex $ toHeaders @headers @headersList headers)
221+ <> request.headers
222+
223+ }
224+
225+class FromResponse r where
226+ fromResponse :: Response -> Aff (Maybe r)
227+
228+instance FromResponse Json where
229+ fromResponse resp = map (Just <<< foreignToJson) (Response.json resp)
230+
231+instance DecodeJson x => FromResponse (Array x) where
232+ fromResponse resp = do
233+ fromResponse resp <#> case _ of
234+ Nothing -> Nothing
235+ Just json ->
236+ case decodeJson json of
237+ Right x -> Just x
238+ Left _ -> Nothing
239+
240+instance DecodeJson (Record row) => FromResponse (Record row) where
241+ fromResponse resp = do
242+ fromResponse resp <#> case _ of
243+ Nothing -> Nothing
244+ Just json ->
245+ case decodeJson json of
246+ Right x -> Just x
247+ Left _ -> Nothing
248+
249+instance FromResponse Unit where
250+ fromResponse _ = pure $ Just unit
251+
252+instance FromResponse String where
253+ fromResponse = map Just <<< Response.text
254+
255+instance FromResponse ArrayBuffer where
256+ fromResponse = map Just <<< Response.arrayBuffer
257+
258+class EzFetchMethod :: HttpMethod -> Constraint
259+class EzFetchMethod meth where
260+ ezFetchMethod :: Method
261+
262+instance EzFetchMethod (GET req resp) where
263+ ezFetchMethod = GET
264+
265+instance EzFetchMethod (POST req resp) where
266+ ezFetchMethod = POST
267+
268+instance EzFetchMethod (PATCH req resp) where
269+ ezFetchMethod = PATCH
270+
271+instance EzFetchMethod (PUT req resp) where
272+ ezFetchMethod = PUT
273+
274+instance EzFetchMethod (DELETE req resp) where
275+ ezFetchMethod = DELETE
276+
277+jsonToForeign :: Json -> Foreign
278+jsonToForeign = unsafeCoerce
279+
280+foreignToJson :: Foreign -> Json
281+foreignToJson = unsafeCoerce
282+
src/PureStack/Route.purs+122
@@ -10,9 +10,35 @@ module PureStack.Route
10 , DELETE
10 , DELETE
11 , PATCH
11 , PATCH
12 , Headers(..)
12 , Headers(..)
13+ , class ToHeaders
14+ , toHeaders
15+ , class ToHeader
16+ , toHeader
17+ , class FromHeaders
18+ , fromHeaders
19+ , class FromHeader
20+ , fromHeader
13 , Middleware
21 , Middleware
14 ) where
22 ) where
15
23
24+import Prelude
25+
26+import Data.Either (Either(..))
27+import Data.Int as Int
28+import Data.Maybe (Maybe(..))
29+import Data.Symbol (class IsSymbol, reflectSymbol)
30+import Foreign.Object (Object)
31+import Foreign.Object as Object
32+import Prim.Row as Row
33+import Prim.RowList (RowList)
34+import Prim.RowList as RowList
35+import PureStack.Cookie (Cookie)
36+import PureStack.Cookie as Cookie
37+import Record as Record
38+import Record.Builder (Builder)
39+import Record.Builder as Builder
40+import Type.Prelude (Proxy(..))
41+
16data HttpMethod
42data HttpMethod
17
43
18-- | The `req` can only ever be `Unit`
44-- | The `req` can only ever be `Unit`
@@ -52,4 +78,100 @@ infixr 1 type Slash as /
52
78
53data Headers headers r = Headers headers r
79data Headers headers r = Headers headers r
54
80
81+class FromHeader t where
82+ fromHeader :: String -> Maybe t
83+
84+instance FromHeader Cookie where
85+ fromHeader = Cookie.parse >>> case _ of
86+ Left _ -> Nothing
87+ Right x -> Just x
88+
89+instance FromHeader String where
90+ fromHeader = Just
91+
92+instance FromHeader Int where
93+ fromHeader = Int.fromString
94+
95+class FromHeaders :: Row Type -> RowList Type -> Constraint
96+class FromHeaders row list | list -> row where
97+ fromHeaders :: Object String -> Maybe (Builder {} (Record row))
98+
99+instance FromHeaders () RowList.Nil where
100+ fromHeaders _ = Just $ identity
101+
102+instance
103+ ( FromHeader t
104+ , IsSymbol field
105+ , FromHeaders tail rest
106+ , Row.Cons field (Maybe t) tail row
107+ , Row.Lacks field tail
108+ ) =>
109+ FromHeaders row (RowList.Cons field (Maybe t) rest) where
110+ fromHeaders headers = do
111+ r <- fromHeaders @tail @rest headers
112+ case Object.lookup (reflectSymbol @field Proxy) headers of
113+ Nothing -> pure $ Builder.insert (Proxy @field) Nothing <<< r
114+ Just t -> do
115+ v <- fromHeader t
116+ pure $ Builder.insert (Proxy @field) (Just v) <<< r
117+
118+else instance
119+ ( FromHeader t
120+ , IsSymbol field
121+ , FromHeaders tail rest
122+ , Row.Cons field t tail row
123+ , Row.Lacks field tail
124+ ) =>
125+ FromHeaders row (RowList.Cons field t rest) where
126+ fromHeaders headers = do
127+ t <- Object.lookup (reflectSymbol @field Proxy) headers >>= fromHeader
128+ r <- fromHeaders @tail @rest headers
129+ pure $ Builder.insert (Proxy @field) t <<< r
130+
131+class ToHeader t where
132+ toHeader :: t -> String
133+
134+instance ToHeader Cookie where
135+ toHeader = Cookie.stringify
136+
137+instance ToHeader String where
138+ toHeader s = s
139+
140+instance ToHeader Int where
141+ toHeader = show
142+
143+class ToHeaders :: Row Type -> RowList Type -> Constraint
144+class ToHeaders row list where
145+ toHeaders :: Record row -> Object String
146+
147+instance ToHeaders row RowList.Nil where
148+ toHeaders _ = Object.empty
149+
150+instance
151+ ( ToHeaders row rest
152+ , Row.Cons field (Maybe t) tail row
153+ , IsSymbol field
154+ , ToHeader t
155+ ) =>
156+ ToHeaders row (RowList.Cons field (Maybe t) rest) where
157+ toHeaders headers =
158+ let
159+ rest = toHeaders @row @rest headers
160+ in
161+ case Record.get (Proxy @field) headers of
162+ Nothing -> rest
163+ Just val -> Object.insert (reflectSymbol @field Proxy) (toHeader val) rest
164+
165+else instance
166+ ( ToHeaders row rest
167+ , Row.Cons field t tail row
168+ , IsSymbol field
169+ , ToHeader t
170+ ) =>
171+ ToHeaders row (RowList.Cons field t rest) where
172+ toHeaders headers =
173+ Object.insert (reflectSymbol @field Proxy) (toHeader (Record.get (Proxy @field) headers))
174+ (toHeaders @row @rest headers)
175+
176+data Middleware :: Symbol -> Type
55data Middleware tag
177data Middleware tag
src/PureStack/Server.purs+21−56
@@ -20,10 +20,7 @@ module PureStack.Server
20 , serveQuery
20 , serveQuery
21 , class ParsePathPiece
21 , class ParsePathPiece
22 , parsePathPiece
22 , parsePathPiece
23− , class FromHeaders
23+ , module PureStack.Route
24− , fromHeaders
25− , class FromHeader
26− , fromHeader
27 ) where
24 ) where
28
25
29import Prelude
26import Prelude
@@ -143,7 +140,7 @@ else instance (ToResponse resp, MethodName (meth Unit resp)) => ServeRoute (meth
143 pure $ \(Nt nt) handler _middlewares _req -> do
140 pure $ \(Nt nt) handler _middlewares _req -> do
144 resp <- nt handler
141 resp <- nt handler
145 pure $ toResponse resp
142 pure $ toResponse resp
146−else instance (FromRequest req, MethodName (meth resp Unit)) => ServeRoute (meth resp Unit) (req -> m Unit) middlewares m where
143+else instance (FromRequest req, MethodName (meth resp Unit)) => ServeRoute (meth req Unit) (req -> m Unit) middlewares m where
147 serveRoute { path, verb } = do
144 serveRoute { path, verb } = do
148 assert $ verb == methodName @(meth resp Unit)
145 assert $ verb == methodName @(meth resp Unit)
149 assert $ path == []
146 assert $ path == []
@@ -239,11 +236,29 @@ class ToResponse r where
239 toResponse :: r -> Response
236 toResponse :: r -> Response
240
237
241instance EncodeJson (Record row) => ToResponse (Record row) where
238instance EncodeJson (Record row) => ToResponse (Record row) where
242− toResponse rec = Response { body: JsonResponseBody $ encodeJson rec, status: 200, statusText: "OK", headers: Object.empty }
239+ toResponse rec = toResponse $ encodeJson rec
240+
241+instance EncodeJson t => ToResponse (Array t) where
242+ toResponse = encodeJson >>> toResponse
243
243
244instance ToResponse Response where
244instance ToResponse Response where
245 toResponse resp = resp
245 toResponse resp = resp
246
246
247+instance ToResponse Json where
248+ toResponse body = Response { body: JsonResponseBody body, status: 200, statusText: "OK", headers: Object.empty }
249+
250+instance
251+ ( ToResponse resp
252+ , ToHeaders headers headersList
253+ , RowToList headers headersList
254+ ) =>
255+ ToResponse (Headers (Record headers) resp) where
256+ toResponse (Headers headers resp) =
257+ let
258+ Response initResp = toResponse resp
259+ in
260+ Response initResp { headers = Object.union (toHeaders @headers @headersList headers) initResp.headers }
261+
247class FromRequest r where
262class FromRequest r where
248 fromRequest :: Request -> Aff (Maybe r)
263 fromRequest :: Request -> Aff (Maybe r)
249
264
@@ -283,56 +298,6 @@ instance
283 r' <- r
298 r' <- r
284 pure $ Headers (Builder.buildFromScratch headers) r'
299 pure $ Headers (Builder.buildFromScratch headers) r'
285
300
286−class FromHeader t where
287− fromHeader :: String -> Maybe t
288−
289−instance FromHeader Cookie where
290− fromHeader = Cookie.parse >>> case _ of
291− Left _ -> Nothing
292− Right x -> Just x
293−
294−instance FromHeader String where
295− fromHeader = Just
296−
297−instance FromHeader Int where
298− fromHeader = Int.fromString
299−
300−class FromHeaders :: Row Type -> RowList Type -> Constraint
301−class FromHeaders row list | list -> row where
302− fromHeaders :: Object String -> Maybe (Builder {} (Record row))
303−
304−instance FromHeaders () RowList.Nil where
305− fromHeaders _ = Just $ identity
306−
307−instance
308− ( FromHeader t
309− , IsSymbol field
310− , FromHeaders tail rest
311− , Row.Cons field (Maybe t) tail row
312− , Row.Lacks field tail
313− ) =>
314− FromHeaders row (RowList.Cons field (Maybe t) rest) where
315− fromHeaders headers = do
316− r <- fromHeaders @tail @rest headers
317− case Object.lookup (reflectSymbol @field Proxy) headers of
318− Nothing -> pure $ Builder.insert (Proxy @field) Nothing <<< r
319− Just t -> do
320− v <- fromHeader t
321− pure $ Builder.insert (Proxy @field) (Just v) <<< r
322−
323−else instance
324− ( FromHeader t
325− , IsSymbol field
326− , FromHeaders tail rest
327− , Row.Cons field t tail row
328− , Row.Lacks field tail
329− ) =>
330− FromHeaders row (RowList.Cons field t rest) where
331− fromHeaders headers = do
332− t <- Object.lookup (reflectSymbol @field Proxy) headers >>= fromHeader
333− r <- fromHeaders @tail @rest headers
334− pure $ Builder.insert (Proxy @field) t <<< r
335−
336class ParsePathPiece t where
301class ParsePathPiece t where
337 parsePathPiece :: String -> Maybe t
302 parsePathPiece :: String -> Maybe t
338
303