git.iko.soy/purestack-dev/todomvc
on master help sign in
swap
99438958 ahead, 0 behind
.gitignore+5
since splitsnapshots
unifiedsplit
@@ -10,3 +10,8 @@
10/.spago
10/.spago
11backend.js
11backend.js
12frontend.js
12frontend.js
13+result
14+index.js
15+m36
16+backend.js.map
17+frontend.js.map
flake.lock+123−1
@@ -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,
@@ -49,6 +66,44 @@
49 "type": "github"
66 "type": "github"
50 }
67 }
51 },
68 },
69+ "package-sets": {
70+ "flake": false,
71+ "locked": {
72+ "lastModified": 1750577700,
73+ "narHash": "sha256-O2yPcwTqiOl/GcJSykwEfiy1EPKde4/EM3XuEvNWcO4=",
74+ "owner": "purescript",
75+ "repo": "package-sets",
76+ "rev": "9c76f35a27cc266b1f0fdbd151eb4a5859e30540",
77+ "type": "github"
78+ },
79+ "original": {
80+ "owner": "purescript",
81+ "repo": "package-sets",
82+ "type": "github"
83+ }
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+ },
52 "purescript-overlay": {
107 "purescript-overlay": {
53 "inputs": {
108 "inputs": {
54 "flake-compat": "flake-compat",
109 "flake-compat": "flake-compat",
@@ -71,11 +126,29 @@
71 "type": "github"
126 "type": "github"
72 }
127 }
73 },
128 },
129+ "registry": {
130+ "flake": false,
131+ "locked": {
132+ "lastModified": 1750577695,
133+ "narHash": "sha256-Jv4PUe54RtwKwQaxr1ABQu2o1/+nkqYcV88CAB9zAhQ=",
134+ "owner": "purescript",
135+ "repo": "registry",
136+ "rev": "45fc747d4d0f006b19775f9013642ed8c62d5465",
137+ "type": "github"
138+ },
139+ "original": {
140+ "owner": "purescript",
141+ "repo": "registry",
142+ "type": "github"
143+ }
144+ },
74 "root": {
145 "root": {
75 "inputs": {
146 "inputs": {
76 "flake-utils": "flake-utils",
147 "flake-utils": "flake-utils",
77 "nixpkgs": "nixpkgs",
148 "nixpkgs": "nixpkgs",
149+ "project-m36-rest": "project-m36-rest",
78− "purescript-overlay": "purescript-overlay"
150+ "purescript-overlay": "purescript-overlay",
151+ "spago-nix": "spago-nix"
79 }
152 }
80 },
153 },
81 "slimlock": {
154 "slimlock": {
@@ -99,6 +172,40 @@
99 "type": "github"
172 "type": "github"
100 }
173 }
101 },
174 },
175+ "spago-nix": {
176+ "inputs": {
177+ "package-sets": "package-sets",
178+ "registry": "registry"
179+ },
180+ "locked": {
181+ "lastModified": 1750748667,
182+ "narHash": "sha256-7RYmZu/q2zfGuYT0O57wXfS9/PDaHF86Kh7BDURDAZ8=",
183+ "owner": "purestack-dev",
184+ "repo": "spago-nix",
185+ "rev": "cf33c40bf9174c4ce58637f5d882eef23ac3d3f5",
186+ "type": "github"
187+ },
188+ "original": {
189+ "owner": "purestack-dev",
190+ "repo": "spago-nix",
191+ "type": "github"
192+ }
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+ },
102 "systems": {
209 "systems": {
103 "locked": {
210 "locked": {
104 "lastModified": 1681028828,
211 "lastModified": 1681028828,
@@ -113,6 +220,21 @@
113 "repo": "default",
220 "repo": "default",
114 "type": "github"
221 "type": "github"
115 }
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+ }
116 }
238 }
117 },
239 },
118 "root": "root",
240 "root": "root",
flake.nix+30−4
@@ -6,8 +6,14 @@
6 url = "github:thomashoneyman/purescript-overlay";
6 url = "github:thomashoneyman/purescript-overlay";
7 inputs.nixpkgs.follows = "nixpkgs";
7 inputs.nixpkgs.follows = "nixpkgs";
8 };
8 };
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+ };
9 };
14 };
10− outputs = { self, nixpkgs, flake-utils, purescript-overlay }:
15+ outputs = { self, nixpkgs, flake-utils, purescript-overlay, spago-nix
16+ , project-m36-rest }:
11 let supportedSystems = flake-utils.lib.defaultSystems;
17 let supportedSystems = flake-utils.lib.defaultSystems;
12 in flake-utils.lib.eachSystem supportedSystems (system:
18 in flake-utils.lib.eachSystem supportedSystems (system:
13 let
19 let
@@ -20,18 +26,33 @@
20 processes = {
26 processes = {
21 spago-frontend = {
27 spago-frontend = {
22 command =
28 command =
23− "${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";
24 is_tty = true;
30 is_tty = true;
25 };
31 };
26 spago-backend = {
32 spago-backend = {
27 command =
33 command =
28− "${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";
29 is_tty = true;
35 is_tty = true;
30 };
36 };
31− 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";
32 };
43 };
33 });
44 });
34 in {
45 in {
46+ packages = {
47+ frontend = spago-nix.lib.spago { inherit pkgs; } {
48+ src = ./.;
49+ main = "Frontend";
50+ };
51+ backend = spago-nix.lib.spago { inherit pkgs; } {
52+ src = ./.;
53+ main = "Backend";
54+ };
55+ };
35 apps = {
56 apps = {
36 dev = {
57 dev = {
37 type = "app";
58 type = "app";
@@ -52,4 +73,9 @@
52 };
73 };
53 };
74 };
54 });
75 });
76+ nixConfig = {
77+ extra-substituters = [ "https://cache.garnix.io" ];
78+ extra-trusted-public-keys =
79+ [ "cache.garnix.io:CTFPyKSLcx5RMJKfLo5EEPUObbA78b0YQ2DTCJXqr9g=" ];
80+ };
55}
81}
spago.dhall+53−1
@@ -1,5 +1,57 @@
1{ name = "my-project"
1{ name = "my-project"
2−, dependencies = [ "console", "effect", "prelude" ]
2+, dependencies =
3+ [ "aff"
4+ , "aff-promise"
5+ , "argonaut"
6+ , "argonaut-codecs"
7+ , "arraybuffer"
8+ , "arraybuffer-types"
9+ , "arrays"
10+ , "bifunctors"
11+ , "console"
12+ , "control"
13+ , "datetime"
14+ , "debug"
15+ , "effect"
16+ , "either"
17+ , "enums"
18+ , "exceptions"
19+ , "ezfetch"
20+ , "foldable-traversable"
21+ , "foreign"
22+ , "foreign-object"
23+ , "formatters"
24+ , "functions"
25+ , "integers"
26+ , "lists"
27+ , "literals"
28+ , "maybe"
29+ , "newtype"
30+ , "now"
31+ , "numbers"
32+ , "ordered-collections"
33+ , "parsing"
34+ , "partial"
35+ , "prelude"
36+ , "profunctor-lenses"
37+ , "record"
38+ , "refs"
39+ , "run"
40+ , "safe-coerce"
41+ , "simple-json"
42+ , "strings"
43+ , "strings-extra"
44+ , "transformers"
45+ , "tuples"
46+ , "typelevel-prelude"
47+ , "unsafe-coerce"
48+ , "untagged-union"
49+ , "url-immutable"
50+ , "web-dom"
51+ , "web-events"
52+ , "web-html"
53+ , "web-uievents"
54+ ]
3, packages = ./packages.dhall
55, packages = ./packages.dhall
4, sources = [ "src/**/*.purs", "test/**/*.purs" ]
56, sources = [ "src/**/*.purs", "test/**/*.purs" ]
5}
57}
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/Bun/Request.jsnew file+15
@@ -0,0 +1,15 @@
1+export function jsonPromise(req) {
2+ return req.json()
3+}
4+
5+export function method(req) {
6+ return req.method
7+}
8+
9+export function url(req) {
10+ return req.url
11+}
12+
13+export function headers(req) {
14+ return Object.fromEntries(req.headers.entries());
15+}
src/Bun/Request.pursnew file+28
@@ -0,0 +1,28 @@
1+module Bun.Request
2+ ( Request
3+ , method
4+ , url
5+ , json
6+ , headers
7+ ) where
8+
9+import Prelude
10+
11+import Control.Promise (Promise)
12+import Control.Promise as Promise
13+import Data.Argonaut (Json)
14+import Effect.Aff (Aff)
15+import Foreign.Object (Object)
16+
17+foreign import data Request :: Type
18+
19+foreign import jsonPromise :: Request -> Promise Json
20+
21+json :: Request -> Aff Json
22+json = jsonPromise >>> Promise.toAff
23+
24+foreign import method :: Request -> String
25+
26+foreign import url :: Request -> String
27+
28+foreign import headers :: Request -> Object String
src/Bun/Response.jsnew file+35
@@ -0,0 +1,35 @@
1+export function json(j) {
2+ return function(options) {
3+ return Response.json(j, options)
4+ }
5+}
6+
7+
8+export function string(s) {
9+ return function(options) {
10+ return new Response(s, options)
11+ }
12+}
13+
14+
15+export function stream(s) {
16+ return function(options) {
17+ return new Response(s, options)
18+ }
19+}
20+
21+export function body(resp) {
22+ return resp.body
23+}
24+
25+export function status(resp) {
26+ return resp.status
27+}
28+
29+export function statusText(resp) {
30+ return resp.statusText
31+}
32+
33+export function headers(resp) {
34+ return Object.fromEntries(resp.headers.entries());
35+}
src/Bun/Response.pursnew file+18
@@ -0,0 +1,18 @@
1+module Bun.Response where
2+
3+import Data.Argonaut (Json)
4+import Foreign.Object (Object)
5+
6+foreign import data Response :: Type
7+foreign import data ReadableStream :: Type
8+
9+type Options = { status :: Int, statusText :: String, headers :: Object String }
10+
11+foreign import json :: Json -> Options -> Response
12+foreign import string :: String -> Options -> Response
13+foreign import stream :: ReadableStream -> Options -> Response
14+foreign import body :: Response -> ReadableStream
15+foreign import headers :: Response -> Object String
16+foreign import status :: Response -> Int
17+foreign import statusText :: Response -> String
18+
src/Bun/Server.jsnew file+9
@@ -0,0 +1,9 @@
1+export function serve_(f) {
2+ return function() {
3+ return Bun.serve({
4+ fetch(req) {
5+ return f(req)()
6+ }
7+ })
8+ }
9+}
src/Bun/Server.pursnew file+15
@@ -0,0 +1,15 @@
1+module Bun.Server (serve) where
2+
3+import Prelude
4+
5+import Bun.Request (Request)
6+import Bun.Response (Response)
7+import Control.Promise (Promise)
8+import Control.Promise as Promise
9+import Effect (Effect)
10+import Effect.Aff (Aff)
11+
12+foreign import serve_ :: (Request -> Effect (Promise Response)) -> Effect Unit
13+
14+serve :: (Request -> Aff Response) -> Effect Unit
15+serve f = serve_ (\req -> Promise.fromAff (f req))
src/Data/Base64.jsnew file+53
@@ -0,0 +1,53 @@
1+// Uses heavily code from https://github.com/dchest/tweetnacl-util-js which exists in the public domain
2+// Modifications have been made where appropriate to the purescript FFI platform
3+
4+function validateBase64(s) {
5+ if (!(/^(?:[A-Za-z0-9+/]{4})*(?:[A-Za-z0-9+/]{2}==|[A-Za-z0-9+/]{3}=)?$/.test(s))) {
6+ throw new TypeError('invalid encoding');
7+ }
8+}
9+
10+export function encodeBase64Impl(buffer) {
11+ if (typeof btoa === 'undefined') {
12+ // Node
13+ return Buffer.from(buffer).toString('base64');
14+ } else {
15+ // Browser
16+ const reducer = function (a, n) {
17+ return a.concat([String.fromCharCode(n)]);
18+ };
19+ const arr = new Array();
20+ const wrapped = new Uint8Array(buffer);
21+ return btoa(wrapped.reduce(reducer, arr).join(''));
22+ }
23+};
24+
25+export function decodeBase64Impl(just, nothing, str) {
26+ try {
27+ validateBase64(str);
28+ if (typeof atob === 'undefined') {
29+ arrayRepresentation = new Uint8Array(Array.prototype.slice.call(Buffer.from(str, 'base64'), 0));
30+ return just(arrayRepresentation.buffer);
31+ } else {
32+ // Browser
33+ var i = 0;
34+ const byteString = atob(str);
35+ var ns = new Uint8Array(byteString.length);
36+ for (i = 0; i < ns.length; i++) {
37+ ns[i] = byteString.charCodeAt(i);
38+ }
39+ return just(ns.buffer);
40+ }
41+ } catch (e) {
42+ return nothing;
43+ }
44+};
45+
46+export function fromStringImpl(just, nothing, str) {
47+ try {
48+ validateBase64(str);
49+ return just(str);
50+ } catch (e) {
51+ return nothing;
52+ }
53+}
src/Data/Base64.pursnew file+45
@@ -0,0 +1,45 @@
1+module Data.Base64
2+ ( encodeBase64
3+ , decodeBase64
4+ , Base64
5+ , runBase64
6+ , fromString
7+ ) where
8+
9+import Data.ArrayBuffer.Types (ArrayBuffer)
10+import Data.Function.Uncurried (Fn3, runFn3)
11+import Data.Maybe (Maybe(..), fromJust)
12+import Partial.Unsafe (unsafePartial)
13+import Prelude ((<<<), class Show, class Eq, (<>), ($))
14+
15+-- | A boxed Base64 type to prevent accidental misuse
16+newtype Base64 = Base64 String
17+
18+derive instance eqBase64 :: Eq Base64
19+
20+-- | Show instance is for textual representations, not data representation
21+instance showBase64 :: Show Base64 where
22+ show (Base64 s) = "Base64 (" <> s <> ")"
23+
24+foreign import encodeBase64Impl :: ArrayBuffer -> String
25+
26+-- | Encodes an ArrayBuffer into the base64 representation thereof
27+encodeBase64 :: ArrayBuffer -> Base64
28+encodeBase64 = Base64 <<< encodeBase64Impl
29+
30+foreign import decodeBase64Impl :: Fn3 (ArrayBuffer -> Maybe ArrayBuffer) (Maybe ArrayBuffer) String (Maybe ArrayBuffer)
31+
32+-- | Decode base64 content to the array buffer(byte) representation it stored internally.
33+decodeBase64 :: Base64 -> ArrayBuffer
34+-- Uses unsafe calls to coerce types, but because Base64 can only be constructed in this module,
35+-- The function with this type signature is total. The underlying ffi function must however be defined in terms of Maybe
36+decodeBase64 (Base64 content) = unsafePartial $ fromJust $ runFn3 decodeBase64Impl Just Nothing content
37+
38+-- |
39+runBase64 :: Base64 -> String
40+runBase64 (Base64 s) = s
41+
42+foreign import fromStringImpl :: Fn3 (Base64 -> Maybe Base64) (Maybe Base64) String (Maybe Base64)
43+
44+fromString :: String -> Maybe Base64
45+fromString = runFn3 fromStringImpl Just Nothing
src/Data/DateTime/ISO.pursnew file+156
@@ -0,0 +1,156 @@
1+module Data.DateTime.ISO (ISO(..), unwrapISO) where
2+
3+import Prelude
4+
5+import Data.Argonaut as A
6+import Data.Argonaut.Decode (class DecodeJson, decodeJson)
7+import Data.Argonaut.Encode (class EncodeJson, encodeJson)
8+import Data.Array as Array
9+import Data.Bifunctor (lmap)
10+import Data.DateTime (DateTime(..), Date, Millisecond, Time)
11+import Data.DateTime as DT
12+import Data.Enum (class BoundedEnum, fromEnum, toEnum)
13+import Data.Foldable (class Foldable, foldl, length)
14+import Data.Maybe (Maybe, maybe, fromMaybe)
15+import Data.Newtype (class Newtype, wrap, unwrap)
16+import Data.String (fromCodePointArray, codePointFromChar, toCodePointArray)
17+import Data.String (length) as String
18+import Data.String.CodeUnits (fromCharArray, toCharArray) as String
19+import Data.Traversable (sequence)
20+import Parsing as P
21+import Parsing.Combinators as PC
22+import Parsing.String as PS
23+
24+-- | A minimal `DateTime` wrapper that encodes/decodes to/from the *simplified*
25+-- | extended ISO format ([`ISO 8601`](https://en.wikipedia.org/wiki/ISO_8601)).
26+-- | Specifically `YYYY-MM-DDTHH:mm:ss[.sss]Z` where hyphens and colons can be omitted.
27+newtype ISO = ISO DateTime
28+
29+derive instance newtypeISO :: Newtype ISO _
30+
31+-- | A monomorphic `unwrap`.
32+unwrapISO :: ISO -> DateTime
33+unwrapISO = unwrap
34+
35+instance showISO :: Show ISO where
36+ show (ISO (DateTime date time)) = foldl append ""
37+ [ showInt $ DT.year date
38+ , "-"
39+ , padl 2 '0' $ showInt $ DT.month date
40+ , "-"
41+ , padl 2 '0' $ showInt $ DT.day date
42+ , "T"
43+ , padl 2 '0' $ showInt $ DT.hour time
44+ , ":"
45+ , padl 2 '0' $ showInt $ DT.minute time
46+ , ":"
47+ , padl 2 '0' $ showInt $ DT.second time
48+ , "."
49+ , removeTrailingZeros $ padMilli $ DT.millisecond time
50+ , "Z"
51+ ]
52+ where
53+ showInt :: forall a. BoundedEnum a => a -> String
54+ showInt = show <<< fromEnum
55+
56+-- | Pad an integer from a millisecond value with enough zeros so it is three
57+-- digits.
58+padMilli :: Millisecond -> String
59+padMilli = padl 3 '0' <<< show <<< fromEnum
60+
61+-- | Remove trailing zeros from a millisecond value.
62+removeTrailingZeros :: String -> String
63+removeTrailingZeros "000" = "0"
64+removeTrailingZeros s =
65+ fromCodePointArray
66+ <<< Array.reverse
67+ <<< Array.dropWhile (_ == codePointFromChar '0')
68+ <<<
69+ Array.reverse $
70+ toCodePointArray s
71+
72+instance decodeJsonISO :: DecodeJson ISO where
73+ decodeJson = decodeJson
74+ >=> flip P.runParser (parseISO :: P.Parser String ISO)
75+ >>> lmap (P.parseErrorMessage >>> A.TypeMismatch)
76+
77+instance encodeJsonISO :: EncodeJson ISO where
78+ encodeJson = show >>> encodeJson
79+
80+--------------------------------------------------------------------------------
81+
82+parseISO :: forall m. Monad m => P.ParserT String m ISO
83+parseISO = do
84+ date <- parseISODate
85+ _ <- PS.char 'T'
86+ time <- parseISOTime
87+ pure $ wrap $ DateTime date time
88+
89+parseISODate :: forall m. Monad m => P.ParserT String m Date
90+parseISODate = do
91+ year <- parseDigits 4 <#> toEnum >>= maybeFail "bad year"
92+ _ <- dash
93+ month <- parseDigits 2 <#> toEnum >>= maybeFail "bad month"
94+ _ <- dash
95+ day <- parseDigits 2 <#> toEnum >>= maybeFail "bad day"
96+ DT.exactDate year month day # maybeFail "bad date"
97+
98+ where
99+ dash = PC.optional $ PC.try $ PS.char '-'
100+
101+parseISOTime :: forall m. Monad m => P.ParserT String m Time
102+parseISOTime = do
103+ hh <- parseDigits 2 <#> toEnum >>= maybeFail "bad hour"
104+ _ <- colon
105+ mm <- parseDigits 2 <#> toEnum >>= maybeFail "bad minute"
106+ _ <- colon
107+ ss <- parseDigits 2 <#> toEnum >>= maybeFail "bad second"
108+ -- NOTE: milliseconds may not be present
109+ ms <- PC.option bottom $
110+ PC.try (PS.char '.') *> Array.some parseDigit <#> doMilli
111+ pure $ DT.Time hh mm ss ms
112+ where
113+ colon = PC.optional $ PC.try $ PS.char ':'
114+
115+-- | Parse an array of three integers into a `Millisecond` value.
116+doMilli :: Array Int -> Millisecond
117+doMilli ns =
118+ let
119+ padded = Array.take 3 $ ns <> Array.replicate (3 - length ns) 0
120+ in
121+ fromMaybe top $ toEnum $ foldDigits padded
122+
123+parseDigits :: forall m. Monad m => Int -> P.ParserT String m Int
124+parseDigits = map foldDigits <<< sequence <<< flip Array.replicate parseDigit
125+
126+parseDigit :: forall m. Monad m => P.ParserT String m Int
127+parseDigit =
128+ PC.choice
129+ [ PS.char '0' *> pure 0
130+ , PS.char '1' *> pure 1
131+ , PS.char '2' *> pure 2
132+ , PS.char '3' *> pure 3
133+ , PS.char '4' *> pure 4
134+ , PS.char '5' *> pure 5
135+ , PS.char '6' *> pure 6
136+ , PS.char '7' *> pure 7
137+ , PS.char '8' *> pure 8
138+ , PS.char '9' *> pure 9
139+ ] `PC.withErrorMessage` "expected digit (0-9)"
140+
141+--------------------------------------------------------------------------------
142+
143+foldDigits :: forall f. Foldable f => f Int -> Int
144+foldDigits = foldl (\acc d -> acc * 10 + d) zero
145+
146+maybeFail :: forall m a. Monad m => String -> Maybe a -> P.ParserT String m a
147+maybeFail str = maybe (P.fail str) pure
148+
149+padl :: Int -> Char -> String -> String
150+padl n chr str = String.fromCharArray $
151+ padl' (n - String.length str) chr (String.toCharArray str)
152+
153+padl' :: Int -> Char -> Array Char -> Array Char
154+padl' n chr chrs
155+ | n <= 0 = chrs
156+ | otherwise = padl' (n - 1) chr (chr `Array.cons` chrs)
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.pursnew file+121
@@ -0,0 +1,121 @@
1+module Plum (Plum, run, currentOrigin) where
2+
3+import Prelude
4+
5+import Data.Array as Array
6+import Data.Maybe (Maybe(..))
7+import Data.URL (URL)
8+import Data.URL as URL
9+import Effect (Effect)
10+import Effect.Aff (Aff, launchAff_)
11+import Effect.Class (liftEffect)
12+import Effect.Console (log)
13+import Effect.Exception (throw)
14+import Effect.Ref as Ref
15+import Foreign.Object as Object
16+import Literals.Undefined (undefined)
17+import Plum.View (GenericUI(..), UI, grow)
18+import Snabbdom as Snabbdom
19+import Unsafe.Coerce (unsafeCoerce)
20+import Untagged.Union (asOneOf)
21+import Web.DOM.NonElementParentNode (getElementById) as Web
22+import Web.HTML (window) as Web
23+import Web.HTML.Event.EventTypes (invalid)
24+import Web.HTML.HTMLDocument (toNonElementParentNode) as Web
25+import Web.HTML.Location as Location
26+import Web.HTML.Window (document, location) as Web
27+
28+type Plum msg model =
29+ { init :: (Aff msg -> Effect Unit) -> Effect model
30+ , update :: (Aff msg -> Effect Unit) -> msg -> model -> Effect model
31+ , view :: model -> UI msg Unit
32+ }
33+
34+run :: forall @model @msg. String -> Plum msg model -> Effect Unit
35+run id plum = do
36+ Web.window >>= Web.document >>= Web.getElementById id <<< Web.toNonElementParentNode >>= case _ of
37+ Just element -> do
38+ let node = Snabbdom.toVNode element
39+ modelRef <- Ref.new { model: unsafeCoerce undefined, lastNode: node }
40+ patch <- Snabbdom.init
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+ )
62+ view model = do
63+ let UI { children } _ = plum.view model
64+ case Array.uncons children of
65+ Just { head: child } -> do
66+ let
67+ { node, style } = grow
68+ fire
69+ child
70+ pure $
71+ Snabbdom.h "div"
72+ { attrs: Object.empty
73+ , on: Object.empty
74+ , style: Object.empty
75+ , props: Object.empty
76+ }
77+ [ Snabbdom.h "style"
78+ { attrs: Object.empty
79+ , on: Object.empty
80+ , style: Object.empty
81+ , props: Object.empty
82+ }
83+ []
84+ (asOneOf $ outerStyle <> style)
85+ , node
86+ ]
87+ (asOneOf undefined)
88+ Nothing -> pure $
89+ Snabbdom.h "div"
90+ { attrs: Object.empty
91+ , on: Object.empty
92+ , style: Object.empty
93+ , props: Object.empty
94+ }
95+ []
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+ )
106+ newNode <- view initModel
107+ newNode_ <- patch node newNode
108+ log "patched"
109+ Ref.write { model: initModel, lastNode: newNode_ } modelRef
110+ pure unit
111+ Nothing -> pure unit
112+
113+outerStyle :: String
114+outerStyle = "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.pursnew file+724
@@ -0,0 +1,724 @@
1+module Plum.View
2+ ( View
3+ , Nerve(..)
4+ , Meat(..)
5+ , Font
6+ , BorderStyle(..)
7+ , Corner(..)
8+ , Shadow(..)
9+ , ShadowCfg
10+ , Side(..)
11+ , Bones(..)
12+ , grow
13+ , Direction(..)
14+ , Alignment(..)
15+ , Length(..)
16+ , Color(..)
17+ , rgb255
18+ , rgba255
19+ , rgb
20+ , rgba
21+ , UI
22+ , GenericUI(..)
23+ , GenericUIView
24+ , column
25+ , row
26+ , stack
27+ , text
28+ , link
29+ , newTabLink
30+ , download
31+ , downloadAs
32+ , image
33+ , textInput
34+ , spacing
35+ , explain
36+ , align
37+ , width
38+ , height
39+ , wrapped
40+ , bgColor
41+ , padding
42+ , spread
43+ , opacity
44+ , pointer
45+ , move
46+ , clip
47+ , borders
48+ , border
49+ , borderStyle
50+ , roundAll
51+ , round
52+ , shadow
53+ , innerShadow
54+ , onHover
55+ , onMouseDown
56+ , font
57+ , fontColor
58+ , fontSize
59+ , fontWeight
60+ , onClick
61+ , onPress
62+ , onKey
63+ ) where
64+
65+import Prelude
66+
67+import Control.Monad.Writer (Writer, runWriter, tell)
68+import Control.Monad.Writer.Trans (mapWriterT)
69+import Data.Array (foldMap)
70+import Data.Array as Array
71+import Data.Array.NonEmpty (concatMap)
72+import Data.Int as Int
73+import Data.Maybe (Maybe(..))
74+import Data.Maybe as Maybe
75+import Data.String as String
76+import Data.Traversable (traverse)
77+import Data.TraversableWithIndex (traverseWithIndex)
78+import Data.Tuple.Nested (type (/\), (/\))
79+import Effect (Effect)
80+import Foreign.Object (Object)
81+import Foreign.Object as Object
82+import Literals.Undefined (undefined)
83+import Prim.TypeError (class Warn)
84+import Prim.TypeError as TypeError
85+import Snabbdom (VNode)
86+import Snabbdom as Snabbdom
87+import Type.Row.Homogeneous (class Homogeneous)
88+import Unsafe.Coerce (unsafeCoerce)
89+import Untagged.Union (asOneOf)
90+import Web.DOM.Element as Element
91+import Web.DOM.ParentNode (firstElementChild)
92+import Web.Event.Event (Event)
93+import Web.Event.Event as Event
94+import 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
98+
99+type GenericUIView children msg =
100+ { nerves :: Array (Nerve msg)
101+ , meat :: Array Meat
102+ , hover :: Array Meat
103+ , down :: Array Meat
104+ , children :: children
105+ }
106+
107+type UIView msg = GenericUIView (Array (View msg)) msg
108+
109+data GenericUI children msg a = UI (GenericUIView children msg) a
110+
111+instance (Semigroup children, Semigroup a) => Semigroup (GenericUI children msg a) where
112+ append (UI v a) (UI v' a') = UI (v <> v') (a <> a')
113+
114+instance (Monoid children, Monoid a) => Monoid (GenericUI children msg a) where
115+ mempty = UI mempty mempty
116+
117+type UI msg a = GenericUI (Array (View msg)) msg a
118+
119+instance Functor (GenericUI children msg) where
120+ map f (UI v a) = UI v $ f a
121+
122+instance Monoid children => Apply (GenericUI children msg) where
123+ apply (UI views f) (UI views' a) = UI (views <> views') (f a)
124+
125+instance Monoid children => Applicative (GenericUI children msg) where
126+ pure = UI mempty
127+
128+instance Monoid children => Bind (GenericUI children msg) where
129+ bind (UI views a) f =
130+ let
131+ UI views' b = f a
132+ in
133+ UI (views <> views') b
134+
135+instance Monoid children => Monad (GenericUI children msg)
136+
137+column :: forall msg. UI msg Unit -> UI msg Unit
138+column (UI { nerves, meat, hover, down, children } _) =
139+ UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ Column children ] } unit
140+
141+row :: forall msg a. UI msg a -> UI msg a
142+row (UI { nerves, meat, hover, down, children } a) =
143+ UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ Row children ] } a
144+
145+stack :: forall msg a. UI msg a -> UI msg a
146+stack (UI { nerves, meat, hover, down, children } a) =
147+ UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ Stack children ] } a
148+
149+text :: forall msg. String -> GenericUI Unit msg Unit -> UI msg Unit
150+text s (UI { nerves, meat, hover, down } a) = UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ Text s ] } a
151+
152+link :: forall msg a. String -> UI msg a -> UI msg a
153+link url (UI { nerves, meat, hover, down, children } a) = UI
154+ (mempty :: UIView msg)
155+ { children =
156+ [ { meat
157+ , nerves
158+ , hover
159+ , down
160+ } /\ Link url { newTab: false } (Maybe.fromMaybe none $ Array.head children)
161+ ]
162+ }
163+ a
164+
165+newTabLink :: forall msg a. String -> UI msg a -> UI msg a
166+newTabLink url (UI { nerves, meat, hover, down, children } a) = UI
167+ (mempty :: UIView msg)
168+ { children =
169+ [ { meat
170+ , nerves
171+ , hover
172+ , down
173+ } /\ Link url { newTab: true } (Maybe.fromMaybe none $ Array.head children)
174+ ]
175+ }
176+ a
177+
178+download :: forall msg a. String -> UI msg a -> UI msg a
179+download url (UI { nerves, meat, children, down, hover } a) = UI
180+ (mempty :: UIView msg)
181+ { children =
182+ [ { meat
183+ , nerves
184+ , down
185+ , hover
186+ } /\ Download url { filename: Nothing } (Maybe.fromMaybe none $ Array.head children)
187+ ]
188+ }
189+ a
190+
191+downloadAs :: forall msg a. String -> { filename :: String } -> UI msg a -> UI msg a
192+downloadAs url { filename } (UI { nerves, meat, hover, down, children } a) = UI
193+ (mempty :: UIView msg)
194+ { children =
195+ [ { meat
196+ , nerves
197+ , hover
198+ , down
199+ } /\ Download url { filename: Just filename } (Maybe.fromMaybe none $ Array.head children)
200+ ]
201+ }
202+ a
203+
204+image :: forall msg a. String -> { description :: String } -> GenericUI Unit msg a -> UI msg a
205+image url description (UI { nerves, meat, hover, down } a) =
206+ UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ Image url description ] } a
207+
208+textInput :: forall msg a. { value :: String, onChange :: String -> msg } -> GenericUI Unit msg a -> UI msg a
209+textInput props (UI { nerves, meat, hover, down } a) =
210+ UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ TextInput props ] } a
211+
212+string :: String -> Classes -> WiredNerves -> String -> VNode
213+string elem classes (WiredNerves on) s =
214+ Snabbdom.h elem
215+ { attrs: Object.singleton "class" (Array.intercalate " " classes)
216+ , on
217+ , style: Object.empty
218+ , props: Object.empty
219+ }
220+ []
221+ (asOneOf s)
222+
223+h :: String -> Classes -> WiredNerves -> Array VNode -> VNode
224+h elem classes (WiredNerves on) children =
225+ Snabbdom.h elem
226+ { attrs: Object.singleton "class" (Array.intercalate " " classes)
227+ , on
228+ , props: Object.empty
229+ , style: Object.empty
230+ }
231+ children
232+ (asOneOf undefined)
233+
234+hWith :: forall props. Homogeneous props String => String -> Record props -> Classes -> WiredNerves -> Array VNode -> VNode
235+hWith elem props classes (WiredNerves on) children =
236+ Snabbdom.h elem
237+ { attrs: Object.singleton "class" (Array.intercalate " " classes)
238+ , on
239+ , props: Object.fromHomogeneous props
240+ , style: Object.empty
241+ }
242+ children
243+ (asOneOf undefined)
244+
245+data Length = Px Int | Fill | Fit | Max Int Length | Min Int Length
246+
247+data Alignment = Start | Center | End
248+
249+data Direction = X | Y
250+
251+n :: forall ch msg. Monoid ch => Nerve msg -> GenericUI ch msg Unit
252+n nerve = UI (mempty :: GenericUIView ch msg) { nerves = [ nerve ] } mempty
253+
254+onClick :: forall ch msg. Monoid ch => msg -> GenericUI ch msg Unit
255+onClick msg = n $ OnClick msg
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+
264+m :: forall ch msg. Monoid ch => Meat -> GenericUI ch msg Unit
265+m meat = UI (mempty :: GenericUIView ch msg) { meat = [ meat ] } mempty
266+
267+spacing :: forall ch msg. Monoid ch => { x :: Int, y :: Int } -> GenericUI ch msg Unit
268+spacing { x, y } = m $ Spacing x y
269+
270+explain :: forall ch msg. Monoid ch => Warn (TypeError.Text "Debug explain present") => GenericUI ch msg Unit
271+explain = m Explain
272+
273+align :: forall ch msg. Monoid ch => Direction -> Alignment -> GenericUI ch msg Unit
274+align dir al = m $ Align dir al
275+
276+width :: forall ch msg. Monoid ch => Length -> GenericUI ch msg Unit
277+width l = m $ Width l
278+
279+height :: forall ch msg. Monoid ch => Length -> GenericUI ch msg Unit
280+height l = m $ Height l
281+
282+wrapped :: forall ch msg. Monoid ch => GenericUI ch msg Unit
283+wrapped = m Wrapped
284+
285+bgColor :: forall ch msg. Monoid ch => Color -> GenericUI ch msg Unit
286+bgColor c = m $ BackgroundColor c
287+
288+padding :: forall ch msg. Monoid ch => Side -> Int -> GenericUI ch msg Unit
289+padding s l = m $ Padding s l
290+
291+spread :: forall ch msg. Monoid ch => GenericUI ch msg Unit
292+spread = m Spread
293+
294+opacity :: forall ch msg. Monoid ch => Number -> GenericUI ch msg Unit
295+opacity o = m $ Opacity o
296+
297+pointer :: forall ch msg. Monoid ch => GenericUI ch msg Unit
298+pointer = m Pointer
299+
300+move :: forall ch msg. Monoid ch => { x :: Int, y :: Int } -> GenericUI ch msg Unit
301+move a = m $ Move a
302+
303+clip :: forall ch msg. Monoid ch => Direction -> GenericUI ch msg Unit
304+clip dir = m $ Clip dir
305+
306+onHover :: forall ch msg. Monoid ch => GenericUI Unit msg Unit -> GenericUI ch msg Unit
307+onHover (UI { meat } a) = UI (mempty :: GenericUIView ch msg) { hover = meat } a
308+
309+onMouseDown :: forall ch msg. Monoid ch => GenericUI Unit msg Unit -> GenericUI ch msg Unit
310+onMouseDown (UI { meat } a) = UI (mempty :: GenericUIView ch msg) { down = meat } a
311+
312+borders :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
313+borders l = Array.foldMap (\s -> m $ BorderWidth s l) [ Top, Right, Bottom, Left ]
314+
315+border :: forall ch msg. Monoid ch => Side -> Int -> GenericUI ch msg Unit
316+border s l = m $ BorderWidth s l
317+
318+borderStyle :: forall ch msg. Monoid ch => BorderStyle -> GenericUI ch msg Unit
319+borderStyle s = m $ BorderStyle s
320+
321+roundAll :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
322+roundAll l = Array.foldMap (\c -> m $ Round c l) [ TopLeft, TopRight, BottomRight, BottomLeft ]
323+
324+round :: forall ch msg. Monoid ch => Corner -> Int -> GenericUI ch msg Unit
325+round c l = m $ Round c l
326+
327+shadow :: forall ch msg. Monoid ch => ShadowCfg -> GenericUI ch msg Unit
328+shadow cfg = m $ Shadow $ ShadowCfg cfg
329+
330+innerShadow :: forall ch msg. Monoid ch => ShadowCfg -> GenericUI ch msg Unit
331+innerShadow cfg = m $ InnerShadow $ ShadowCfg cfg
332+
333+font :: forall ch msg. Monoid ch => String -> GenericUI ch msg Unit
334+font f = m $ Font f
335+
336+fontColor :: forall ch msg. Monoid ch => Color -> GenericUI ch msg Unit
337+fontColor c = m $ FontColor c
338+
339+fontSize :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
340+fontSize f = m $ FontSize f
341+
342+fontWeight :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
343+fontWeight f = m $ FontWeight f
344+
345+data Meat
346+ = Spacing Int Int
347+ | Explain
348+ | Align Direction Alignment
349+ | Width Length
350+ | Height Length
351+ | Wrapped
352+ | BackgroundColor Color
353+ | Padding Side Int
354+ | Spread
355+ | Opacity Number
356+ | Pointer
357+ | Move { x :: Int, y :: Int }
358+ | Clip Direction
359+ | BorderWidth Side Int
360+ | BorderStyle BorderStyle
361+ | Round Corner Int
362+ | Shadow Shadow
363+ | InnerShadow Shadow
364+ | FontColor Color
365+ | FontWeight Int
366+ | FontSize Int
367+ | Font Font
368+
369+type Font = String
370+
371+type ShadowCfg = { offset :: { x :: Int, y :: Int }, size :: Number, blur :: Number, color :: Color }
372+
373+newtype Shadow = ShadowCfg ShadowCfg
374+
375+instance Renderable Shadow where
376+ render (ShadowCfg s) = show s.offset.x <> "px " <> show s.offset.y <> "px " <> show s.blur <> "px " <> show s.size <> "px " <> render s.color
377+ renderKey (ShadowCfg s) = show s.offset.x <> "-" <> show s.offset.y <> "-" <> show s.blur <> "-" <> show s.size <> "-" <> renderKey s.color
378+
379+data Corner = TopLeft | TopRight | BottomRight | BottomLeft
380+
381+instance Renderable Corner where
382+ render = case _ of
383+ TopLeft -> "top-left"
384+ TopRight -> "top-right"
385+ BottomRight -> "bottom-right"
386+ BottomLeft -> "bottom-left"
387+ renderKey = case _ of
388+ TopLeft -> "top-left"
389+ TopRight -> "top-right"
390+ BottomRight -> "bottom-right"
391+ BottomLeft -> "bottom-left"
392+
393+data BorderStyle = Solid | Dashed | Dotted
394+
395+instance Renderable BorderStyle where
396+ render = case _ of
397+ Solid -> "solid"
398+ Dashed -> "dashed"
399+ Dotted -> "dotted"
400+ renderKey = case _ of
401+ Solid -> "solid"
402+ Dashed -> "dashed"
403+ Dotted -> "dotted"
404+
405+data Side = Top | Right | Bottom | Left
406+
407+instance Renderable Side where
408+ render = case _ of
409+ Top -> "top"
410+ Right -> "right"
411+ Bottom -> "bottom"
412+ Left -> "left"
413+ renderKey = case _ of
414+ Top -> "top"
415+ Right -> "right"
416+ Bottom -> "bottom"
417+ Left -> "left"
418+
419+data Nerve msg
420+ = OnClick msg
421+ | OnPress (KeyboardEvent -> msg)
422+ | OnKey String msg
423+
424+newtype WiredNerves = WiredNerves (Object (Event -> Effect Unit))
425+
426+instance Semigroup WiredNerves where
427+ append (WiredNerves x) (WiredNerves y) =
428+ WiredNerves $ Object.unionWith (\f g ev -> f ev *> g ev) x y
429+
430+instance Monoid WiredNerves where
431+ mempty = WiredNerves Object.empty
432+
433+wireNerve :: forall msg. (msg -> Effect Unit) -> Nerve msg -> WiredNerves
434+wireNerve fire nerve = WiredNerves $ case nerve of
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
442+
443+type View msg =
444+ { nerves :: Array (Nerve msg)
445+ , meat :: Array Meat
446+ , hover :: Array Meat
447+ , down :: Array Meat
448+ } /\ Bones msg
449+
450+none :: forall msg. View msg
451+none = mempty /\ None
452+
453+newtype Skin = Skin (Object String)
454+
455+sk :: String -> String -> String -> Writer SkinGrowth Classes
456+sk cName key value = do
457+ tell $ SkinGrowth $ { meat: Object.singleton cName { key, value }, hover: Object.empty, down: Object.empty }
458+ pure [ cName ]
459+
460+instance Semigroup Skin where
461+ append (Skin x) (Skin y) = Skin $ Object.union x y
462+
463+instance Monoid Skin where
464+ mempty = Skin Object.empty
465+
466+data Context = Grid | Flexbox Direction | Generic | Span
467+
468+skin :: Context -> Meat -> Writer SkinGrowth Classes
469+skin ctx = case _ of
470+ Spacing x y -> sk ("spacing-" <> show x <> "-" <> show y) "gap" (show x <> "px " <> show y <> "px")
471+ Explain -> sk "explain" "border" "dashed magenta"
472+ Align dir alignment -> case ctx of
473+ Generic -> mempty
474+ Span -> mempty
475+ Grid ->
476+ let
477+ k =
478+ ( case dir of
479+ X -> "justify-items"
480+ Y -> "align-items"
481+ )
482+ v =
483+ ( case alignment of
484+ Start -> "start"
485+ Center -> "center"
486+ End -> "end"
487+ )
488+ in
489+ sk ("align-grid-" <> k <> "-" <> v) k v
490+
491+ Flexbox flexDir ->
492+ let
493+ k =
494+ ( case flexDir /\ dir of
495+ X /\ X -> "justify-content"
496+ X /\ Y -> "align-items"
497+ Y /\ X -> "align-items"
498+ Y /\ Y -> "justify-content"
499+ )
500+
501+ v =
502+ ( case alignment of
503+ Start -> "flex-start"
504+ Center -> "center"
505+ End -> "flex-end"
506+ )
507+ in
508+ sk ("align-flexbox-" <> k <> "-" <> v) k v
509+ Width l -> sk ("width-" <> renderKey l) "width" (render l)
510+ Height l -> sk ("height-" <> renderKey l) "height" (render l)
511+ Wrapped -> case ctx of
512+ Flexbox _ -> sk "wrapped" "flex-wrap" "wrap"
513+ _ -> pure []
514+ BackgroundColor color -> sk ("bg-color-" <> renderKey color) "background-color" (render color)
515+ Padding side l ->
516+ sk
517+ ("padding-" <> renderKey side <> "-" <> show l)
518+ ("padding-" <> render side)
519+ (show l <> "px")
520+ Spread -> case ctx of
521+ Flexbox _ -> sk "spread" "justify-content" "space-between"
522+ _ -> pure []
523+ Opacity o -> sk ("opacity-" <> show o) "opacity" (show o)
524+ Pointer -> sk "pointer" "cursor" "pointer"
525+ Move { x, y } -> sk ("move-" <> show x <> "-" <> show y) "transform" ("translate(" <> show x <> "px, " <> show y <> "px)")
526+ Clip X -> sk "clip-x" "overflow-x" "hidden"
527+ Clip Y -> sk "clip-y" "overflow-y" "hidden"
528+ BorderWidth side l -> sk ("border-width-" <> renderKey side <> "-" <> show l) ("border-" <> render side <> "-width") (show l <> "px")
529+ BorderStyle s -> sk ("border-style-" <> renderKey s) "border-style" (render s)
530+ Round corner l -> sk ("round-" <> renderKey corner <> "-" <> show l) ("border-" <> render corner <> "-radius") (show l <> "px")
531+ Shadow s -> sk ("shadow-" <> renderKey s) "box-shadow" (render s)
532+ InnerShadow s -> sk ("inner-shadow-" <> renderKey s) "box-shadow" (render s <> " inset")
533+ FontColor c -> sk ("font-color-" <> renderKey c) "color" (render c)
534+ FontSize l -> sk ("font-size-" <> show l) "font-size" (show l <> "px")
535+ Font f -> sk ("font-" <> removeSpaces f) "font-family" f
536+ FontWeight w -> sk ("font-weight-" <> show w) "font-weight" (show w)
537+
538+removeSpaces :: String -> String
539+removeSpaces = String.replaceAll (String.Pattern " ") (String.Replacement "-")
540+
541+class Renderable x where
542+ render :: x -> String
543+ renderKey :: x -> String
544+
545+instance Renderable Length where
546+ render = case _ of
547+ Px px -> show px <> "px"
548+ Fit -> "fit-content"
549+ Fill -> "100%"
550+ Max px l -> "max(" <> show px <> "px," <> render l <> ")"
551+ Min px l -> "min(" <> show px <> "px," <> render l <> ")"
552+ renderKey = case _ of
553+ Px px -> show px
554+ Fit -> "fit-content"
555+ Fill -> "fill"
556+ Max px l -> "max-" <> show px <> "-" <> renderKey l
557+ Min px l -> "min-" <> show px <> "-" <> renderKey l
558+
559+newtype Color = Color { r :: Int, g :: Int, b :: Int, a :: Int }
560+
561+rgb255 :: Int -> Int -> Int -> Color
562+rgb255 r g b = Color { r, g, b, a: 100 }
563+
564+rgba255 :: Int -> Int -> Int -> Int -> Color
565+rgba255 r g b a = Color { r, g, b, a }
566+
567+rgb :: Number -> Number -> Number -> Color
568+rgb r g b = Color { r: Int.round (r * 255.0), g: Int.round (g * 255.0), b: Int.round (b * 255.0), a: 100 }
569+
570+rgba :: Number -> Number -> Number -> Number -> Color
571+rgba r g b a = Color { r: Int.round (r * 255.0), g: Int.round (g * 255.0), b: Int.round (b * 255.0), a: Int.round (a * 100.0) }
572+
573+instance Renderable Color where
574+ render (Color { r, g, b, a }) = "rgb(" <> show r <> "," <> show g <> "," <> show b <> "," <> show a <> "%)"
575+ renderKey (Color { r, g, b, a }) = show r <> "-" <> show g <> "-" <> show b <> "-" <> show a
576+
577+data Bones :: Type -> Type
578+data Bones msg
579+ = Column (Array (View msg))
580+ | Row (Array (View msg))
581+ | Stack (Array (View msg))
582+ | Wrapper (View msg)
583+ | Text String
584+ | Link String { newTab :: Boolean } (View msg)
585+ | Download String { filename :: Maybe String } (View msg)
586+ | Image String { description :: String }
587+ | TextInput { value :: String, onChange :: String -> msg }
588+ | None
589+
590+type Classes = Array String
591+
592+newtype Mutation = Mutation { extraSkin :: Classes }
593+
594+instance Semigroup Mutation where
595+ append (Mutation x) (Mutation y) = Mutation { extraSkin: x.extraSkin <> y.extraSkin }
596+
597+instance Monoid Mutation where
598+ mempty = Mutation { extraSkin: mempty }
599+
600+newtype SkinGrowth = SkinGrowth
601+ { meat :: Object { key :: String, value :: String }
602+ , hover :: Object { key :: String, value :: String }
603+ , down :: Object { key :: String, value :: String }
604+ }
605+
606+styleSkinGrowth :: SkinGrowth -> String
607+styleSkinGrowth (SkinGrowth o) =
608+ Object.foldMap (\className { key, value } -> "." <> className <> "{" <> key <> ":" <> value <> ";}") o.meat
609+ <> Object.foldMap (\className { key, value } -> "." <> className <> "{" <> key <> ":" <> value <> ";}") o.hover
610+ <> Object.foldMap (\className { key, value } -> "." <> className <> "{" <> key <> ":" <> value <> ";}") o.down
611+
612+instance Semigroup SkinGrowth where
613+ append (SkinGrowth x) (SkinGrowth y) = SkinGrowth $
614+ { meat: Object.union x.meat y.meat
615+ , hover: Object.union x.hover y.hover
616+ , down: Object.union x.down y.down
617+ }
618+
619+instance Monoid SkinGrowth where
620+ mempty = SkinGrowth mempty
621+
622+growSkin :: forall msg. (msg -> Effect Unit) -> Mutation -> View msg -> Writer SkinGrowth VNode
623+growSkin fire (Mutation mutation) ({ meat, hover, down, nerves } /\ bones) = do
624+ let
625+ wiredNerves = Array.foldMap (wireNerve fire) nerves
626+ alignCenter = [ Align X Center, Align Y Center ]
627+ widthFill = [ Width Fill, Height Fill ]
628+ skn ctx = do
629+ meatClasses <- ((_ <> mutation.extraSkin) <<< Array.concat) <$> traverse (skin ctx)
630+ ( meat
631+ <> case ctx of
632+ Span -> mempty
633+ Grid -> widthFill
634+ Flexbox _ -> widthFill
635+ Generic -> widthFill
636+ <> case ctx of
637+ Grid -> alignCenter
638+ Flexbox _ -> alignCenter
639+ Span -> mempty
640+ Generic -> alignCenter
641+ )
642+ let hoverClasses /\ (SkinGrowth hover') = runWriter $ traverse (skin ctx) hover
643+ _ <- traverseWithIndex
644+ ( \key val -> tell $ SkinGrowth $
645+ { meat: Object.empty
646+ , hover: Object.singleton (key <> "-hover:hover") val
647+ , down: Object.empty
648+ }
649+ )
650+ hover'.meat
651+ let downClasses /\ (SkinGrowth down') = runWriter $ traverse (skin ctx) down
652+ _ <- traverseWithIndex
653+ ( \key val -> tell $ SkinGrowth $
654+ { meat: Object.empty
655+ , hover: Object.empty
656+ , down: Object.singleton (key <> "-down:active") val
657+ }
658+ )
659+ down'.meat
660+
661+ pure $ meatClasses <> map (_ <> "-hover") (Array.concat hoverClasses) <> map (_ <> "-down") (Array.concat downClasses)
662+
663+ case bones of
664+ Text t -> (\c -> string "span" c wiredNerves t) <$> (skn Span)
665+ Wrapper x -> do
666+ classes <- (skn (Flexbox X) <> sk "display-flex" "display" "flex" <> sk "flex-direction-row" "flex-direction" "row")
667+ x' <- growSkin fire mempty x
668+ pure $ h "div" classes wiredNerves [ x' ]
669+ Stack children -> do
670+ classes <- (skn Grid <> sk "display-grid" "display" "grid")
671+ extraSkin <- sk "grid-row-1" "grid-row" "1" <> sk "grid-column-1" "grid-column" "1"
672+ children' <- (traverse (growSkin fire $ Mutation { extraSkin }) children)
673+ pure $ h "div" classes wiredNerves children'
674+
675+ Row children -> do
676+ classes <- (skn (Flexbox X) <> sk "display-flex" "display" "flex" <> sk "flex-direction-row" "flex-direction" "row")
677+ children' <- traverse (growSkin fire mempty) children
678+ pure $ h "div" classes wiredNerves children'
679+ Column children -> do
680+ classes <- (skn (Flexbox Y) <> sk "display-flex" "display" "flex" <> sk "flex-direction-column" "flex-direction" "column")
681+ children' <- traverse (growSkin fire mempty) children
682+ pure $ h "div" classes wiredNerves children'
683+ Link href { newTab } child -> do
684+ classes <- (skn (Flexbox X) <> sk "display-flex" "display" "flex" <> sk "flex-direction-row" "flex-direction" "row")
685+ child' <- growSkin fire mempty child
686+ pure $ hWith "a"
687+ { href
688+ , rel: "noopener noreferrer"
689+ , target: if newTab then "_blank" else "_self"
690+ }
691+ classes
692+ wiredNerves
693+ [ child' ]
694+
695+ Download href { filename } child -> do
696+ classes <- (skn (Flexbox X) <> sk "display-flex" "display" "flex" <> sk "flex-direction-row" "flex-direction" "row")
697+ child' <- growSkin fire mempty child
698+ pure $ hWith "a"
699+ { href
700+ , download: Maybe.fromMaybe "" filename
701+ }
702+ classes
703+ wiredNerves
704+ [ child' ]
705+ Image src { description } -> (\c -> hWith "img" { src, alt: description } c wiredNerves []) <$> (skn Generic)
706+ TextInput { value, onChange } -> do
707+ classes <- skn Generic
708+ let
709+ onInputNerve = WiredNerves $ Object.singleton "input" $ \ev ->
710+ case Event.currentTarget ev >>= HTMLInputElement.fromEventTarget of
711+ Nothing -> pure unit
712+ Just inputEl -> do
713+ val <- HTMLInputElement.value inputEl
714+ fire $ onChange val
715+ pure $ hWith "input" { value } classes (wiredNerves <> onInputNerve) []
716+ None -> pure $ h "div" mempty wiredNerves []
717+
718+grow :: forall msg. (msg -> Effect Unit) -> View msg -> { node :: VNode, style :: String }
719+grow fire v =
720+ let
721+ node /\ skinGrowth = runWriter (growSkin fire mempty v)
722+ in
723+ { node, style: styleSkinGrowth skinGrowth }
724+
src/ProjectM36.pursnew file+527
@@ -0,0 +1,527 @@
1+module ProjectM36
2+ ( withTransaction
3+ , Connection(..)
4+ , Transaction
5+ , define
6+ , insert
7+ , query
8+ , union
9+ , difference
10+ , join
11+ , group
12+ , ungroup
13+ , project
14+ , rename
15+ , class Relatable
16+ , attributeTypes
17+ , encodeRelation
18+ , class RelVar
19+ , relVar
20+ , AtomType(..)
21+ , Rel
22+ , rel
23+ , class Atomable
24+ , atomType
25+ , encodeAtom
26+ , decodeAtom
27+ , class LiteralRelation
28+ , lit
29+ , Expr
30+ , Attribute
31+ , class BuildRelation
32+ , decodeRelationFromObject
33+ , class AssertNoConflict
34+ , class GroupRel
35+ , class DropFields
36+ , class ReifyFields
37+ , reifyFields
38+ , class AssertNoDuplicates
39+ , class ProjectRel
40+ , class RenameRel
41+ , class ReifyRename
42+ , reifyRename
43+ ) where
44+
45+import Prelude
46+import Prim.Row
47+import Prim.RowList
48+import Type.Prelude
49+
50+import Control.Monad.Reader (ReaderT(..), runReaderT)
51+import Data.Argonaut (class DecodeJson, class EncodeJson, Json, JsonDecodeError(..), decodeJson, encodeJson, (.:))
52+import Data.Argonaut as Argonaut
53+import Data.Array as Array
54+import Data.ArrayBuffer.Types (ArrayBuffer)
55+import Data.Base64 (decodeBase64, encodeBase64, runBase64)
56+import Data.Base64 as Base64
57+import Data.Date (Date)
58+import Data.DateTime (DateTime(..), date)
59+import Data.DateTime.ISO (ISO(..), unwrapISO)
60+import Data.Either (Either(..))
61+import Data.Maybe (Maybe(..))
62+import Data.Newtype (class Newtype, unwrap)
63+import Data.Set (Set)
64+import Data.Set as Set
65+import Data.Traversable (traverse)
66+import Data.Tuple.Nested (type (/\), (/\))
67+import Data.URL (URL, addSegment)
68+import Debug (traceM)
69+import Effect.Aff (Aff, bracket, error, throwError)
70+import Effect.Aff.HTTP (Method(..), fetch)
71+import Effect.Aff.HTTP.Request as Request
72+import Effect.Aff.HTTP.Response (Response)
73+import Effect.Aff.HTTP.Response as Response
74+import Effect.Class.Console (log)
75+import Foreign (Foreign, unsafeFromForeign, unsafeToForeign)
76+import Foreign.Object (Object)
77+import Foreign.Object as Object
78+import Prim.Row as Row
79+import Prim.RowList as RowList
80+import Record as Record
81+import Simple.JSON (class WriteForeign)
82+import Unsafe.Coerce (unsafeCoerce)
83+
84+data Expr
85+ = Join Expr Expr
86+ | Union Expr Expr
87+ | Project (Set Attribute) Expr
88+ | Rename (Object Attribute) Expr
89+ | Difference Expr Expr
90+ | Group (Set Attribute) Attribute Expr
91+ | Ungroup Attribute Expr
92+ | RelationVariable RelVarName
93+ | Lit Json
94+
95+instance EncodeJson Expr where
96+ encodeJson = case _ of
97+ Lit l -> encodeJson l
98+ Join x y -> encodeJson { join: [ x, y ] }
99+ Union x y -> encodeJson { union: [ x, y ] }
100+ Project proj expr -> encodeJson { proj: { proj: proj, expr: expr } }
101+ Rename mapping expr -> encodeJson { rename: { mapping: mapping, expr: expr } }
102+ Difference x y -> encodeJson { diff: [ x, y ] }
103+ Group attrs attr expr -> encodeJson { group: { attrs: attrs, attr: attr, expr: expr } }
104+ Ungroup attr expr -> encodeJson { ungroup: { attr: attr, expr: expr } }
105+ RelationVariable var -> encodeJson { var: encodeJson var }
106+
107+type RelVarName = String
108+type Attribute = String
109+
110+class RelVar :: forall k. k -> Constraint
111+class RelVar rel where
112+ relVar :: String
113+
114+class LiteralRelation :: Type -> Row Type -> Constraint
115+class LiteralRelation r fields | r -> fields where
116+ lit :: r -> Rel fields
117+
118+instance (RowList.RowToList fields fields', Relatable fields fields') => LiteralRelation (Array (Record fields)) fields where
119+ lit r = Rel $ Lit $ encodeJson { lit: { attrs: attributeTypes @fields @fields', vals: encodeRelation @fields @fields' <$> r } }
120+
121+else instance
122+ ( Newtype r (Record fields)
123+ , LiteralRelation (Array (Record field)) fields
124+ , RowToList fields fields'
125+ , Relatable fields fields'
126+ ) =>
127+ LiteralRelation (Array r) fields where
128+ lit = map unwrap >>> lit
129+
130+rel :: forall @rel fields. Newtype rel (Record fields) => RelVar rel => Rel fields
131+rel = Rel $ RelationVariable (relVar @rel)
132+
133+newtype Rel (fields :: Row Type) = Rel Expr
134+
135+derive newtype instance EncodeJson (Rel fields)
136+
137+union :: forall fields. Rel fields -> Rel fields -> Rel fields
138+union (Rel x) (Rel y) = Rel $ Union x y
139+
140+difference :: forall fields. Rel fields -> Rel fields -> Rel fields
141+difference (Rel x) (Rel y) = Rel $ Difference x y
142+
143+join
144+ :: forall lhs rhs res lhs' rhs' res'
145+ . Union lhs rhs res
146+ => RowToList lhs lhs'
147+ => RowToList rhs rhs'
148+ => AssertNoConflict lhs' res'
149+ => AssertNoConflict rhs' res'
150+ => Nub res res'
151+ => Rel lhs
152+ -> Rel rhs
153+ -> Rel res'
154+join (Rel lhs) (Rel rhs) = Rel $ Join lhs rhs
155+
156+class AssertNoConflict :: forall k. RowList k -> Row k -> Constraint
157+class AssertNoConflict xs ys
158+
159+instance AssertNoConflict Nil xs
160+instance (AssertNoConflict ys xs, Row.Cons l y xs' xs) => AssertNoConflict (RowList.Cons l y ys) xs
161+
162+rename
163+ :: forall @rename rename' fields fields'
164+ . RowList.RowToList rename rename'
165+ => RenameRel rename' fields fields'
166+ => ReifyRename rename'
167+ => Rel fields
168+ -> Rel fields'
169+rename (Rel x) = Rel $ Rename (reifyRename @rename') x
170+
171+class ReifyRename :: RowList Symbol -> Constraint
172+class ReifyRename rename where
173+ reifyRename :: Object Attribute
174+
175+instance ReifyRename RowList.Nil where
176+ reifyRename = Object.empty
177+
178+instance (ReifyRename rest, IsSymbol from, IsSymbol to) => ReifyRename (RowList.Cons from to rest) where
179+ reifyRename = Object.insert (reflectSymbol @from Proxy) (reflectSymbol @to Proxy) (reifyRename @rest)
180+
181+class RenameRel :: forall k. RowList Symbol -> Row k -> Row k -> Constraint
182+class RenameRel rename fields fields' | rename fields -> fields'
183+
184+instance RenameRel RowList.Nil fields fields
185+instance
186+ ( Row.Cons from t fields' fields
187+ , Row.Cons to t fields' fields''
188+ ) =>
189+ RenameRel (RowList.Cons from to rest) fields fields''
190+
191+project
192+ :: forall @projection projection' fields fields'
193+ . ProjectRel projection' fields fields'
194+ => RowList.RowToList projection projection'
195+ => ReifyFields projection'
196+ => Rel fields
197+ -> Rel fields'
198+project (Rel x) = Rel $ Project (reifyFields @projection') x
199+
200+class ProjectRel :: forall k l. RowList k -> Row l -> Row l -> Constraint
201+class ProjectRel projection fields fields' | projection fields -> fields'
202+
203+instance ProjectRel RowList.Nil fields ()
204+instance
205+ ( ProjectRel rest fields fields''
206+ , Row.Cons field value f fields
207+ , Row.Cons field value fields'' fields'
208+ ) =>
209+ ProjectRel (RowList.Cons field v rest) fields fields'
210+
211+class ReifyFields :: forall k. RowList k -> Constraint
212+class ReifyFields row where
213+ reifyFields :: Set Attribute
214+
215+instance ReifyFields RowList.Nil where
216+ reifyFields = Set.empty
217+
218+instance (IsSymbol field, ReifyFields rest) => ReifyFields (RowList.Cons field v rest) where
219+ reifyFields = Set.insert (reflectSymbol @field Proxy) (reifyFields @rest)
220+
221+group
222+ :: forall @group (@field :: Symbol) group' groupped fields fields' fields''
223+ . RowList.RowToList group group'
224+ => GroupRel group' fields groupped
225+ => Row.Cons field (Array (Rel groupped)) fields'' fields'
226+ => DropFields group' fields fields''
227+ => ReifyFields group'
228+ => IsSymbol field
229+ => Rel fields
230+ -> Rel fields'
231+group (Rel x) = Rel $ Group (reifyFields @group') (reflectSymbol @field Proxy) x
232+
233+class GroupRel :: forall k l. RowList l -> Row k -> Row k -> Constraint
234+class GroupRel group fields groupped | group fields -> groupped
235+
236+instance GroupRel RowList.Nil fields ()
237+
238+instance
239+ ( GroupRel rest fields fields''
240+ , Row.Cons field t f fields
241+ , Row.Cons field t fields'' fields'
242+ ) =>
243+ GroupRel (RowList.Cons field u rest) fields fields'
244+
245+class DropFields :: forall l k. RowList l -> Row k -> Row k -> Constraint
246+class DropFields drop fields fields' | drop fields -> fields'
247+
248+instance DropFields RowList.Nil fields fields
249+
250+instance
251+ ( DropFields rest fields fields''
252+ , Row.Cons field t' fields' fields''
253+ ) =>
254+ DropFields (RowList.Cons field t rest) fields fields'
255+
256+ungroup
257+ :: forall (@field :: Symbol) fields fields' fields'' group group'
258+ . IsSymbol field
259+ => Row.Cons field (Array (Record group)) fields'' fields
260+ => Row.Union group fields'' fields'
261+ => RowList.RowToList group group'
262+ => AssertNoDuplicates group' fields''
263+ => Rel fields
264+ -> Rel fields'
265+ungroup (Rel x) = Rel $ Ungroup (reflectSymbol @field Proxy) x
266+
267+class AssertNoDuplicates :: forall k. RowList k -> Row k -> Constraint
268+class AssertNoDuplicates xs ys
269+
270+instance AssertNoDuplicates RowList.Nil ys
271+instance
272+ ( AssertNoDuplicates rest ys
273+ , Row.Lacks field ys
274+ ) =>
275+ AssertNoDuplicates (RowList.Cons field t rest) ys
276+
277+data AtomType
278+ = IntAtomType
279+ | IntegerAtomType
280+ | ScientificAtomType
281+ | DoubleAtomType
282+ | TextAtomType
283+ | DayAtomType
284+ | DateTimeAtomType
285+ | ByteStringAtomType
286+ | BoolAtomType
287+ | UUIDAtomType
288+ | RelationAtomType (Array (Attribute /\ AtomType))
289+
290+instance EncodeJson AtomType where
291+ encodeJson = case _ of
292+ IntAtomType -> Argonaut.fromString "int"
293+ IntegerAtomType -> Argonaut.fromString "integer"
294+ ScientificAtomType -> Argonaut.fromString "scientific"
295+ DoubleAtomType -> Argonaut.fromString "double"
296+ TextAtomType -> Argonaut.fromString "text"
297+ DayAtomType -> Argonaut.fromString "day"
298+ DateTimeAtomType -> Argonaut.fromString "datetime"
299+ ByteStringAtomType -> Argonaut.fromString "bytestring"
300+ BoolAtomType -> Argonaut.fromString "bool"
301+ UUIDAtomType -> Argonaut.fromString "uuid"
302+ RelationAtomType r -> encodeJson r
303+
304+-- instance DecodeJson AtomType where
305+-- decodeJson j =
306+-- ( decodeJson j >>= case _ of
307+-- "int" -> pure IntegerAtomType
308+-- "integer" -> pure IntegerAtomType
309+-- "scientific" -> pure ScientificAtomType
310+-- "double" -> pure DoubleAtomType
311+-- "text" -> pure TextAtomType
312+-- "day" -> pure DayAtomType
313+-- "datetime" -> pure DateTimeAtomType
314+-- "bytestring" -> pure ByteStringAtomType
315+-- "bool" -> pure BoolAtomType
316+-- "uuid" -> pure UUIDAtomType
317+-- _ -> Left $ TypeMismatch $ "Unknown atom type " <> stringify j
318+-- )
319+-- <|>
320+-- ( decodeRelation j
321+-- )
322+
323+instance WriteForeign AtomType where
324+ writeImpl = unsafeToForeign <<< encodeJson
325+
326+class Atomable :: Type -> Constraint
327+class Atomable a where
328+ atomType :: AtomType
329+ encodeAtom :: a -> Json
330+ decodeAtom :: Json -> Either JsonDecodeError a
331+
332+instance Atomable Int where
333+ atomType = IntAtomType
334+ encodeAtom = encodeJson
335+ decodeAtom = decodeJson
336+
337+instance Atomable Number where
338+ atomType = DoubleAtomType
339+ encodeAtom = encodeJson
340+ decodeAtom = decodeJson
341+
342+instance Atomable String where
343+ atomType = TextAtomType
344+ encodeAtom = encodeJson
345+ decodeAtom = decodeJson
346+
347+instance Atomable UUID where
348+ atomType = UUIDAtomType
349+ encodeAtom (UUID uuid) = encodeJson uuid
350+ decodeAtom = map UUID <<< decodeJson
351+
352+instance Atomable Boolean where
353+ atomType = BoolAtomType
354+ encodeAtom = encodeJson
355+ decodeAtom = decodeJson
356+
357+instance Atomable Date where
358+ atomType = DayAtomType
359+ encodeAtom date = encodeJson $ ISO $ DateTime date bottom
360+ decodeAtom = decodeJson >>> map (unwrapISO >>> date)
361+
362+instance Atomable DateTime where
363+ atomType = DateTimeAtomType
364+ encodeAtom = encodeJson <<< ISO
365+ decodeAtom = map unwrapISO <<< decodeJson
366+
367+instance Atomable ArrayBuffer where
368+ atomType = ByteStringAtomType
369+ encodeAtom = encodeBase64 >>> runBase64 >>> encodeJson
370+ decodeAtom j =
371+ map Base64.fromString (decodeJson j) >>= case _ of
372+ Just b -> pure $ decodeBase64 b
373+ Nothing -> Left $ TypeMismatch "Could not decode base64"
374+
375+instance
376+ ( RowList.RowToList fields fields'
377+ , Relatable fields fields'
378+ , BuildRelation fields fields'
379+ ) =>
380+ Atomable (Array (Record fields)) where
381+ atomType = RelationAtomType (attributeTypes @fields @fields')
382+ encodeAtom = map (encodeRelation @fields @fields') >>> encodeJson
383+ decodeAtom = decodeRelationJson >=> traverse (decodeRelationFromObject @fields @fields')
384+
385+class Relatable :: Row Type -> RowList Type -> Constraint
386+class Relatable fields fields' where
387+ attributeTypes :: Array (Attribute /\ AtomType)
388+ encodeRelation :: Record fields -> Array Json
389+
390+instance Relatable fields RowList.Nil where
391+ attributeTypes = []
392+ encodeRelation _ = []
393+
394+instance
395+ ( Atomable t
396+ , IsSymbol field
397+ , Relatable fields rest
398+ , Row.Cons field t tail fields
399+ ) =>
400+ Relatable fields (RowList.Cons field t rest) where
401+ attributeTypes = Array.snoc (attributeTypes @fields @rest) ((reflectSymbol @field Proxy) /\ (atomType @t))
402+ encodeRelation r = Array.snoc (encodeRelation @fields @rest r) (encodeAtom (Record.get (Proxy @field) r))
403+
404+decodeRelationJson :: Json -> Either JsonDecodeError (Array (Object Json))
405+decodeRelationJson = decodeJson >=> \o -> do
406+ attrs :: Array Attribute <- o .: "attrs"
407+ (map <<< map) (Object.fromFoldable <<< Array.zip attrs) $ o .: "vals"
408+
409+class BuildRelation :: Row Type -> RowList Type -> Constraint
410+class BuildRelation fields fields' | fields' -> fields where
411+ decodeRelationFromObject :: Object Json -> Either JsonDecodeError (Record fields)
412+
413+instance BuildRelation () RowList.Nil where
414+ decodeRelationFromObject _ = pure {}
415+
416+instance
417+ ( Row.Cons field r rest fields
418+ , BuildRelation rest rest'
419+ , IsSymbol field
420+ , Atomable r
421+ , Row.Lacks field rest
422+ ) =>
423+ BuildRelation fields (RowList.Cons field t rest') where
424+ decodeRelationFromObject o = do
425+ rest :: Record rest <- decodeRelationFromObject @rest @rest' o
426+ atom <- case Object.lookup (reflectSymbol @field Proxy) o of
427+ Just js -> decodeAtom js
428+ Nothing -> Left MissingValue
429+ pure $ Record.insert (Proxy @field) atom rest
430+
431+newtype Connection = Connection URL
432+
433+newtype Transaction a = Transaction (ReaderT { conn :: Connection, sess :: SessionId } Aff a)
434+
435+derive newtype instance Functor Transaction
436+derive newtype instance Apply Transaction
437+derive newtype instance Applicative Transaction
438+derive newtype instance Bind Transaction
439+derive newtype instance Monad Transaction
440+
441+newtype UUID = UUID String
442+
443+instance DecodeJson UUID where
444+ decodeJson = map UUID <$> decodeJson
445+
446+newtype SessionId = SessionId UUID
447+
448+sessionString :: SessionId -> String
449+sessionString (SessionId (UUID uuid)) = uuid
450+
451+withTransaction :: forall a. Connection -> Transaction a -> Aff a
452+withTransaction conn@(Connection c) (Transaction tr) = do
453+ bracket
454+ ( do
455+ resp <- fetch POST (c `addSegment` "transaction") {}
456+ Response.guardStatusOk resp
457+ uuid :: UUID <- json resp >>= \j -> case decodeJson j of
458+ Left _ -> throwError $ error "Could not decode transaction session UUID"
459+ Right sess -> pure sess
460+ pure $ SessionId uuid
461+ )
462+ ( \sess ->
463+ fetch DELETE (c `addSegment` "transaction" `addSegment` sessionString sess) {}
464+ >>= Response.guardStatusOk
465+ )
466+ ( \sess -> do
467+ a <- runReaderT tr { conn: conn, sess: sess }
468+ fetch PUT (c `addSegment` "transaction" `addSegment` sessionString sess) {}
469+ >>= Response.guardStatusOk
470+ pure a
471+ )
472+
473+json :: Response -> Aff Json
474+json resp = unsafeFromForeign <$> Response.json resp
475+
476+define
477+ :: forall @rel fields fields'
478+ . RowList.RowToList fields fields'
479+ => Newtype rel (Record fields)
480+ => Relatable fields fields'
481+ => RelVar rel
482+ => Transaction Unit
483+define = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do
484+ fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)
485+ { body: Request.json $ jsonToForeign $ encodeJson { define: { name: relVar @rel, attrs: attributeTypes @fields @fields' } } }
486+ >>= Response.guardStatusOk
487+ pure unit
488+
489+insert
490+ :: forall @rel fields
491+ . RelVar rel
492+ => Newtype rel (Record fields)
493+ => Rel fields
494+ -> Transaction Unit
495+insert (Rel r) = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do
496+ traceM $ jsonToForeign $ encodeJson { insert: { name: relVar @rel, rel: r } }
497+ fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)
498+ { body: Request.json $ jsonToForeign $ encodeJson { insert: { name: relVar @rel, rel: r } } }
499+ >>= Response.guardStatusOk
500+ pure unit
501+
502+query
503+ :: forall fields fields'
504+ . RowList.RowToList fields fields'
505+ => BuildRelation fields fields'
506+ => Rel fields
507+ -> Transaction (Array (Record fields))
508+query (Rel r) = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do
509+ resp <- fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)
510+ { body: Request.json $ jsonToForeign $ encodeJson { query: r } }
511+ Response.guardStatusOk resp
512+ j <- json resp
513+ case decodeRelation @fields @fields' j of
514+ Right rec -> pure rec
515+ Left err -> throwError $ error $ show err
516+
517+decodeRelation
518+ :: forall @fields @fields'
519+ . BuildRelation fields fields'
520+ => Json
521+ -> Either JsonDecodeError (Array (Record fields))
522+decodeRelation j = do
523+ decodeRelationJson j >>= traverse (decodeRelationFromObject @fields @fields')
524+
525+jsonToForeign :: Json -> Foreign
526+jsonToForeign = unsafeCoerce
527+
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/Cookie.pursnew file+57
@@ -0,0 +1,57 @@
1+-- | This module allows parsing and generating cookie headers. You'll generally use
2+-- | the `Cookie.new` function to create a cookie from a name/value pair and the
3+-- | `Cookie.set*` functions to set attributes on a cookie.
4+-- |
5+-- | `Cookie.stringify` generates the string representation of a cookie, suitable for
6+-- | writing to an HTTP header.
7+-- |
8+-- | `Cookie.parse` parses the string representation of a cookie, returning an
9+-- | `Either ParseError Cookie`.
10+-- |
11+-- | ```purescript
12+-- | import PureStack.Cookie as Cookie
13+-- |
14+-- | > Cookie.stringify $ Cookie.setSecure $ Cookie.new "key" "value"
15+-- | key=value; Secure
16+-- |
17+-- | > Cookie.parse "key=value; Secure"
18+-- | (Right { name: "key", value: "value", secure: true, ... })
19+-- | ```
20+module PureStack.Cookie
21+ ( module PureStack.Cookie.Generator
22+ , module PureStack.Cookie.Parser
23+ , module PureStack.Cookie.Types
24+ ) where
25+
26+import PureStack.Cookie.Generator (stringify)
27+import PureStack.Cookie.Parser (parse, parseMany)
28+import PureStack.Cookie.Types
29+ ( Cookie
30+ , SameSite(..)
31+ , _domain
32+ , _expires
33+ , _httpOnly
34+ , _maxAge
35+ , _name
36+ , _path
37+ , _secure
38+ , _value
39+ , expire
40+ , fromFields
41+ , getDomain
42+ , getExpires
43+ , getHttpOnly
44+ , getMaxAge
45+ , getName
46+ , getPath
47+ , getSecure
48+ , getValue
49+ , new
50+ , setDomain
51+ , setExpires
52+ , setHttpOnly
53+ , setMaxAge
54+ , setPath
55+ , setSameSite
56+ , setSecure
57+ )
src/PureStack/Cookie/Formatter.pursnew file+65
@@ -0,0 +1,65 @@
1+-- | This module is responsible for formatting and parsing the `Expires`
2+-- | attribute of a `Cookie`.
3+module PureStack.Cookie.Formatter
4+ ( domainTag
5+ , expiresTag
6+ , formatDateTime
7+ , httpOnlyTag
8+ , maxAgeTag
9+ , pathTag
10+ , sameSiteTag
11+ , secureTag
12+ , unformatDateTime
13+ ) where
14+
15+import Data.DateTime (DateTime)
16+import Data.Either (Either)
17+import Data.Formatter.DateTime (Formatter, FormatterCommand(..))
18+import Data.Formatter.DateTime as Formatter
19+import Data.List as List
20+
21+domainTag :: String
22+domainTag = "Domain"
23+
24+expiresTag :: String
25+expiresTag = "Expires"
26+
27+httpOnlyTag :: String
28+httpOnlyTag = "HttpOnly"
29+
30+maxAgeTag :: String
31+maxAgeTag = "Max-Age"
32+
33+pathTag :: String
34+pathTag = "Path"
35+
36+secureTag :: String
37+secureTag = "Secure"
38+
39+sameSiteTag :: String
40+sameSiteTag = "SameSite"
41+
42+expiresFormatter :: Formatter
43+expiresFormatter =
44+ List.fromFoldable
45+ [ DayOfWeekNameShort
46+ , Placeholder ", "
47+ , DayOfMonthTwoDigits
48+ , Placeholder " "
49+ , MonthShort
50+ , Placeholder " "
51+ , YearFull
52+ , Placeholder " "
53+ , Hours24
54+ , Placeholder ":"
55+ , MinutesTwoDigits
56+ , Placeholder ":"
57+ , SecondsTwoDigits
58+ , Placeholder " GMT"
59+ ]
60+
61+formatDateTime :: DateTime -> String
62+formatDateTime = Formatter.format expiresFormatter
63+
64+unformatDateTime :: String -> Either String DateTime
65+unformatDateTime = Formatter.unformat expiresFormatter
src/PureStack/Cookie/Generator.pursnew file+62
@@ -0,0 +1,62 @@
1+-- | This module is responsible for generating the string representation
2+-- | of a `Cookie`.
3+module PureStack.Cookie.Generator
4+ ( stringify
5+ ) where
6+
7+import Prelude
8+import PureStack.Cookie.Formatter
9+ ( domainTag
10+ , expiresTag
11+ , formatDateTime
12+ , httpOnlyTag
13+ , maxAgeTag
14+ , pathTag
15+ , sameSiteTag
16+ , secureTag
17+ )
18+import PureStack.Cookie.Types
19+ ( Cookie
20+ , getDomain
21+ , getExpires
22+ , getHttpOnly
23+ , getMaxAge
24+ , getName
25+ , getPath
26+ , getSameSite
27+ , getSecure
28+ , getValue
29+ )
30+import Data.Array (catMaybes)
31+import Data.Foldable (intercalate)
32+import Data.Maybe (Maybe(..))
33+
34+-- | Return the `String` representation of a `Cookie`.
35+-- |
36+-- | ```purescript
37+-- | > Generator.stringify $ Cookie.setSecure $ Cookie.new "key" "value"
38+-- | key=value; Secure
39+-- | ```
40+stringify :: Cookie -> String
41+stringify cookie =
42+ intercalate "; "
43+ $ catMaybes
44+ [ attr (getName cookie) $ Just (getValue cookie)
45+ , attr domainTag $ getDomain cookie
46+ , attr pathTag $ getPath cookie
47+ , attr expiresTag $ formatDateTime <$> getExpires cookie
48+ , attr maxAgeTag $ show <$> getMaxAge cookie
49+ , attr sameSiteTag $ show <$> getSameSite cookie
50+ , flag secureTag $ getSecure cookie
51+ , flag httpOnlyTag $ getHttpOnly cookie
52+ ]
53+
54+attr :: String -> Maybe String -> Maybe String
55+attr name = case _ of
56+ Nothing -> Nothing
57+ Just value -> Just $ name <> "=" <> value
58+
59+flag :: String -> Boolean -> Maybe String
60+flag name = case _ of
61+ false -> Nothing
62+ true -> Just name
src/PureStack/Cookie/Parser.pursnew file+128
@@ -0,0 +1,128 @@
1+-- | This module is responsible for parsing a string into an
2+-- | `Either ParseError Cookie`.
3+module PureStack.Cookie.Parser
4+ ( parse
5+ , parseMany
6+ ) where
7+
8+import Prelude
9+
10+import Control.Alt ((<|>))
11+import Data.Array as Array
12+import Data.Either (Either(..))
13+import Data.Foldable (class Foldable, foldl)
14+import Data.Int as Int
15+import Data.List (List)
16+import Data.Maybe (Maybe(..))
17+import Data.String as String
18+import Parsing (ParseError, Parser, fail, runParser)
19+import Parsing.Combinators (many, sepBy)
20+import Parsing.String (eof, string)
21+import Parsing.String.Basic (noneOf)
22+import PureStack.Cookie.Formatter (domainTag, expiresTag, httpOnlyTag, maxAgeTag, pathTag, sameSiteTag, secureTag, unformatDateTime)
23+import PureStack.Cookie.Types (Cookie, SameSite(..))
24+import PureStack.Cookie.Types as Cookie
25+
26+type Attribute = Cookie -> Cookie
27+
28+dropSeperator :: Parser String Unit
29+dropSeperator = (string "; " $> unit) <|> (pure unit)
30+
31+asString :: forall f. Functor f => Foldable f => f Char -> String
32+asString = String.fromCodePointArray <<< Array.fromFoldable <<< map String.codePointFromChar
33+
34+stringWithout :: Array Char -> Parser String String
35+stringWithout = map asString <<< many <<< noneOf
36+
37+attributeValue :: Parser String String
38+attributeValue = stringWithout [ ';' ]
39+
40+whitespaceChars :: Array Char
41+whitespaceChars = [ ' ', '\n', '\r', '\t' ]
42+
43+parseDomain :: Parser String Attribute
44+parseDomain = do
45+ domain <- (string $ domainTag <> "=") *> attributeValue
46+ pure $ Cookie.setDomain domain
47+
48+parsePath :: Parser String Attribute
49+parsePath = do
50+ path <- (string $ pathTag <> "=") *> attributeValue
51+ pure $ Cookie.setPath path
52+
53+parseExpires :: Parser String Attribute
54+parseExpires = do
55+ expiresString <- (string $ expiresTag <> "=") *> attributeValue
56+ case unformatDateTime expiresString of
57+ Left e -> fail e
58+ Right expires -> pure $ Cookie.setExpires expires
59+
60+parseMaxAge :: Parser String Attribute
61+parseMaxAge = do
62+ maxAgeString <- (string $ maxAgeTag <> "=") *> attributeValue
63+ case Int.fromString maxAgeString of
64+ Nothing -> fail "invalid integer"
65+ Just maxAge -> pure $ Cookie.setMaxAge maxAge
66+
67+parseSecure :: Parser String Attribute
68+parseSecure = (string secureTag) $> Cookie.setSecure
69+
70+parseHttpOnly :: Parser String Attribute
71+parseHttpOnly = (string httpOnlyTag) $> Cookie.setHttpOnly
72+
73+parseSameSite :: Parser String Attribute
74+parseSameSite = do
75+ sameSiteString <- (string $ sameSiteTag <> "=") *> attributeValue
76+ case sameSiteString of
77+ "Strict" -> pure $ Cookie.setSameSite Strict
78+ "Lax" -> pure $ Cookie.setSameSite Lax
79+ "None" -> pure $ Cookie.setSameSite None
80+ val -> fail $ "unknown SiteSite value " <> val
81+
82+parseAttribute :: Parser String Attribute
83+parseAttribute =
84+ parseDomain
85+ <|> parsePath
86+ <|> parseExpires
87+ <|> parseMaxAge
88+ <|> parseSecure
89+ <|> parseHttpOnly
90+ <|> parseSameSite
91+
92+parseSimpleCookie :: Parser String Cookie
93+parseSimpleCookie = do
94+ name <- stringWithout ([ ';', ',', '=' ] <> whitespaceChars) <* string "="
95+ value <- stringWithout ([ ';', ',' ] <> whitespaceChars)
96+ pure $ Cookie.new name value
97+
98+parseCookie :: Parser String Cookie
99+parseCookie = do
100+ cookie <- parseSimpleCookie <* dropSeperator
101+ attributes <- sepBy parseAttribute (string "; ") <* eof
102+ pure $ foldl (#) cookie attributes
103+
104+parseCookies :: Parser String (List Cookie)
105+parseCookies = sepBy parseSimpleCookie (string "; ") <* eof
106+
107+-- | Parses a `String` into an `Either ParseError Cookie`. This
108+-- | function is primarily intended to parse the `Set-Cookie`
109+-- | header on the client.
110+-- |
111+-- | ```purescript
112+-- | > Parser.parse "key=value; Secure"
113+-- | (Right { name: "key", value: "value", secure: true, ... })
114+-- | ```
115+parse :: String -> Either ParseError Cookie
116+parse = flip runParser parseCookie
117+
118+-- | Parses a `String` into an `Either ParseError (List Cookie)`.
119+-- | HTTP requests can include multiple cookies in a single
120+-- | `Cookie` header consisting of only name/value pairs. This
121+-- | function can be used to parse this header.
122+-- |
123+-- | ```purescript
124+-- | > parseMany "key1=value1; key2=value2"
125+-- | (Right ({ name: "key1", value: "value1", ... } : { name: "key2", value: "value2", ... } : Nil))
126+-- | ```
127+parseMany :: String -> Either ParseError (List Cookie)
128+parseMany = flip runParser parseCookies
src/PureStack/Cookie/Types.pursnew file+189
@@ -0,0 +1,189 @@
1+-- | This module contains the `Cookie` type and functions for operating on data within it.
2+module PureStack.Cookie.Types
3+ ( Cookie
4+ , SameSite(..)
5+ , _domain
6+ , _expires
7+ , _httpOnly
8+ , _maxAge
9+ , _name
10+ , _path
11+ , _secure
12+ , _value
13+ , expire
14+ , fromFields
15+ , getDomain
16+ , getExpires
17+ , getHttpOnly
18+ , getMaxAge
19+ , getName
20+ , getPath
21+ , getSameSite
22+ , getSecure
23+ , getValue
24+ , new
25+ , setDomain
26+ , setExpires
27+ , setHttpOnly
28+ , setMaxAge
29+ , setPath
30+ , setSameSite
31+ , setSecure
32+ ) where
33+
34+import Prelude
35+import Data.DateTime (DateTime)
36+import Data.DateTime as DateTime
37+import Data.Either (Either(..))
38+import Data.Lens (Iso', Lens', iso)
39+import Data.Lens as Lens
40+import Data.Lens.Record (prop)
41+import Data.Maybe (Maybe(..))
42+import Data.Time.Duration (Days(..))
43+import Effect.Now (nowDateTime)
44+import Effect (Effect)
45+import Type.Prelude (Proxy(..))
46+
47+-- | Type representing a `Cookie`'s optional `SameSite` attribute.
48+data SameSite
49+ = Strict
50+ | Lax
51+ | None
52+
53+derive instance eqSameSite :: Eq SameSite
54+
55+derive instance ordSameSite :: Ord SameSite
56+
57+instance showSameSite :: Show SameSite where
58+ show :: SameSite -> String
59+ show Strict = "Strict"
60+ show Lax = "Lax"
61+ show None = "None"
62+
63+type CookieFields =
64+ { name :: String
65+ , value :: String
66+ , domain :: Maybe String
67+ , path :: Maybe String
68+ , expires :: Maybe DateTime
69+ , maxAge :: Maybe Int
70+ , sameSite :: Maybe SameSite
71+ , secure :: Boolean
72+ , httpOnly :: Boolean
73+ }
74+
75+-- | The `Cookie` type
76+newtype Cookie = Cookie CookieFields
77+
78+derive newtype instance eqCookie :: Eq Cookie
79+
80+derive newtype instance ordCookie :: Ord Cookie
81+
82+derive newtype instance showCookie :: Show Cookie
83+
84+-- | The constructor for `Cookie`
85+new :: String -> String -> Cookie
86+new name value =
87+ Cookie
88+ { name
89+ , value
90+ , domain: Nothing
91+ , path: Nothing
92+ , expires: Nothing
93+ , maxAge: Nothing
94+ , sameSite: Nothing
95+ , secure: false
96+ , httpOnly: false
97+ }
98+
99+fromFields :: CookieFields -> Cookie
100+fromFields = Cookie
101+
102+-- | Expire an existing `Cookie`. This sets the `Expires` attribute of
103+-- | the cookie to yesterday's date.
104+expire :: Cookie -> Effect (Either String Cookie)
105+expire cookie = do
106+ now <- nowDateTime
107+ let maybeDate = DateTime.adjust (Days $ -1.0) now
108+
109+ case maybeDate of
110+ Nothing -> pure $ Left "Invalid date"
111+ Just yesterday -> pure $ Right $ setExpires yesterday cookie
112+
113+getDomain :: Cookie -> Maybe String
114+getDomain = Lens.view _domain
115+
116+getExpires :: Cookie -> Maybe DateTime
117+getExpires = Lens.view _expires
118+
119+getHttpOnly :: Cookie -> Boolean
120+getHttpOnly = Lens.view _httpOnly
121+
122+getMaxAge :: Cookie -> Maybe Int
123+getMaxAge = Lens.view _maxAge
124+
125+getName :: Cookie -> String
126+getName = Lens.view _name
127+
128+getPath :: Cookie -> Maybe String
129+getPath = Lens.view _path
130+
131+getSameSite :: Cookie -> Maybe SameSite
132+getSameSite = Lens.view _sameSite
133+
134+getSecure :: Cookie -> Boolean
135+getSecure = Lens.view _secure
136+
137+getValue :: Cookie -> String
138+getValue = Lens.view _value
139+
140+setDomain :: String -> Cookie -> Cookie
141+setDomain = Lens.setJust _domain
142+
143+setExpires :: DateTime -> Cookie -> Cookie
144+setExpires = Lens.setJust _expires
145+
146+setHttpOnly :: Cookie -> Cookie
147+setHttpOnly = Lens.set _httpOnly true
148+
149+setMaxAge :: Int -> Cookie -> Cookie
150+setMaxAge = Lens.setJust _maxAge
151+
152+setPath :: String -> Cookie -> Cookie
153+setPath = Lens.setJust _path
154+
155+setSameSite :: SameSite -> Cookie -> Cookie
156+setSameSite = Lens.setJust _sameSite
157+
158+setSecure :: Cookie -> Cookie
159+setSecure = Lens.set _secure true
160+
161+_Cookie :: Iso' Cookie CookieFields
162+_Cookie = iso (\(Cookie fields) -> fields) Cookie
163+
164+_domain :: Lens' Cookie (Maybe String)
165+_domain = _Cookie <<< prop (Proxy :: Proxy "domain")
166+
167+_expires :: Lens' Cookie (Maybe DateTime)
168+_expires = _Cookie <<< prop (Proxy :: Proxy "expires")
169+
170+_httpOnly :: Lens' Cookie Boolean
171+_httpOnly = _Cookie <<< prop (Proxy :: Proxy "httpOnly")
172+
173+_maxAge :: Lens' Cookie (Maybe Int)
174+_maxAge = _Cookie <<< prop (Proxy :: Proxy "maxAge")
175+
176+_name :: Lens' Cookie String
177+_name = _Cookie <<< prop (Proxy :: Proxy "name")
178+
179+_path :: Lens' Cookie (Maybe String)
180+_path = _Cookie <<< prop (Proxy :: Proxy "path")
181+
182+_sameSite :: Lens' Cookie (Maybe SameSite)
183+_sameSite = _Cookie <<< prop (Proxy :: Proxy "sameSite")
184+
185+_secure :: Lens' Cookie Boolean
186+_secure = _Cookie <<< prop (Proxy :: Proxy "secure")
187+
188+_value :: Lens' Cookie String
189+_value = _Cookie <<< prop (Proxy :: Proxy "value")
src/PureStack/Route.pursnew file+177
@@ -0,0 +1,177 @@
1+module PureStack.Route
2+ ( type (/)
3+ , Slash
4+ , HttpMethod
5+ , class MethodName
6+ , methodName
7+ , GET
8+ , POST
9+ , PUT
10+ , DELETE
11+ , PATCH
12+ , Headers(..)
13+ , class ToHeaders
14+ , toHeaders
15+ , class ToHeader
16+ , toHeader
17+ , class FromHeaders
18+ , fromHeaders
19+ , class FromHeader
20+ , fromHeader
21+ , Middleware
22+ ) where
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+
42+data HttpMethod
43+
44+-- | The `req` can only ever be `Unit`
45+foreign import data GET :: Type -> Type -> HttpMethod
46+foreign import data POST :: Type -> Type -> HttpMethod
47+foreign import data PUT :: Type -> Type -> HttpMethod
48+foreign import data DELETE :: Type -> Type -> HttpMethod
49+foreign import data PATCH :: Type -> Type -> HttpMethod
50+
51+class MethodName :: HttpMethod -> Constraint
52+class MethodName method where
53+ methodName :: String
54+
55+instance MethodName (GET req resp) where
56+ methodName = "GET"
57+
58+instance MethodName (POST req resp) where
59+ methodName = "POST"
60+
61+instance MethodName (PUT req resp) where
62+ methodName = "PUT"
63+
64+instance MethodName (DELETE req resp) where
65+ methodName = "DELETE"
66+
67+instance MethodName (PATCH req resp) where
68+ methodName = "PATCH"
69+
70+data Slash :: forall k1 k2. k1 -> k2 -> Type
71+data Slash x y
72+
73+-- | Operator for separating path pieces when specisying APIs.
74+-- | `Symbol`s are treated as constant path pieces.
75+-- | `Record`s are treated as query parameters. `Array`s are lists, `Maybe`s are optional query parameters.
76+-- | Other types are captured path pieces.
77+infixr 1 type Slash as /
78+
79+data Headers headers r = Headers headers r
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
177+data Middleware tag
src/PureStack/Server.pursnew file+375
@@ -0,0 +1,375 @@
1+module PureStack.Server
2+ ( Server
3+ , Response(..)
4+ , ResponseBody(..)
5+ , class ToResponse
6+ , toResponse
7+ , class FromRequest
8+ , fromRequest
9+ , run
10+ , notFound
11+ , internalServerError
12+ , badRequest
13+ -------------------------------------------------------------------------------------------------
14+ , class ServeAPI
15+ , serveAPI
16+ , Nt(..)
17+ , class ServeRoute
18+ , serveRoute
19+ , class ServeQuery
20+ , serveQuery
21+ , class ParsePathPiece
22+ , parsePathPiece
23+ , module PureStack.Route
24+ ) where
25+
26+import Prelude
27+import PureStack.Route
28+
29+import Bun.Request (Request)
30+import Bun.Request as Bun
31+import Bun.Request as Request
32+import Bun.Response as Bun.Response
33+import Control.Alternative (class Plus, empty)
34+import Control.Monad.Except (ExceptT, runExceptT)
35+import Data.Argonaut (class DecodeJson, class EncodeJson, Json, decodeJson, encodeJson)
36+import Data.Array as Array
37+import Data.Either (Either(..), either)
38+import Data.Int as Int
39+import Data.Map (Map)
40+import Data.Map as Map
41+import Data.Maybe (Maybe(..))
42+import Data.Number as Number
43+import Data.String as String
44+import Data.Symbol (class IsSymbol, reflectSymbol)
45+import Data.Traversable (traverse)
46+import Data.URL as URL
47+import Effect.Aff (Aff)
48+import Effect.Aff.Class (liftAff)
49+import Foreign.Object (Object)
50+import Foreign.Object as Object
51+import Prim.Row as Row
52+import Prim.RowList (class RowToList, RowList)
53+import Prim.RowList as RowList
54+import PureStack.Cookie (Cookie)
55+import PureStack.Cookie as Cookie
56+import Record as Record
57+import Record.Builder (Builder)
58+import Record.Builder as Builder
59+import Type.Proxy (Proxy(..))
60+
61+type Route =
62+ { path :: Array String
63+ , verb :: String
64+ , query :: Map String (Array String)
65+ , originalRequest :: Bun.Request
66+ }
67+
68+routeFromRequest :: Request -> Route
69+routeFromRequest req =
70+ let
71+ url = URL.fromString $ Request.url req
72+ in
73+ { verb: Request.method req
74+ , path: case url of
75+ Nothing -> []
76+ Just u -> case URL.path u of
77+ URL.PathEmpty -> []
78+ URL.PathAbsolute p -> p
79+ URL.PathRelative p -> p
80+ , query: case url of
81+ Nothing -> Map.empty
82+ Just u -> URL.query u
83+ , originalRequest: req
84+ }
85+
86+type Server a = ExceptT Response Aff a
87+
88+newtype Nt m = Nt (forall x. m x -> Server x)
89+
90+class ServeRoute :: forall k. k -> Type -> Row Type -> (Type -> Type) -> Constraint
91+class ServeRoute route handler middlewares m | route middlewares -> handler, handler -> m where
92+ serveRoute :: Route -> Maybe (Nt m -> handler -> Record middlewares -> Request -> Server Response)
93+
94+instance (ServeRoute rest handler middlewares m, IsSymbol path) => ServeRoute (path / rest) handler middlewares m where
95+ serveRoute route@{ path } = do
96+ { head: h, tail } <- Array.uncons path
97+ assert $ h == (reflectSymbol @path Proxy)
98+ serveRoute @rest route { path = tail }
99+
100+else instance
101+ ( ServeRoute rest handler middlewares m
102+ , ServeQuery row list
103+ , RowToList row list
104+ ) =>
105+ ServeRoute (Record row / rest) (Record row -> handler) middlewares m where
106+ serveRoute route@{ query } = do
107+ builder <- serveQuery @row @list query
108+ serveRoute @rest route <#> (\f nt handler req -> f nt (handler $ Builder.buildFromScratch builder) req)
109+
110+else instance
111+ ( ServeRoute rest handler middlewares m
112+ , IsSymbol field
113+ , Row.Cons field (Bun.Request -> m x) tail middlewares
114+ ) =>
115+ ServeRoute (Middleware field / rest) (x -> handler) middlewares m where
116+ serveRoute route@{ originalRequest } = do
117+ serveRoute @rest route <#>
118+ ( \f nt@(Nt ntf) handler middlewares req -> do
119+ x <- ntf $ Record.get (Proxy @field) middlewares originalRequest
120+ f nt (handler x) middlewares req
121+ )
122+
123+else instance (ServeRoute rest handler middlewares m, ParsePathPiece t) => ServeRoute (t / rest) (t -> handler) middlewares m where
124+ serveRoute route@{ path } = do
125+ { head: h, tail } <- Array.uncons path
126+ t <- parsePathPiece @t h
127+ serveRoute @rest route { path = tail } <#> (\f nt handler mws req -> f nt (handler t) mws req)
128+
129+else instance MethodName (meth Unit Unit) => ServeRoute (meth Unit Unit) (m Unit) middlewares m where
130+ serveRoute { path, verb } = do
131+ assert $ verb == methodName @(meth Unit Unit)
132+ assert $ path == []
133+ pure $ \(Nt nt) handler _middlewares _req -> do
134+ nt handler
135+ pure $ ok
136+else instance (ToResponse resp, MethodName (meth Unit resp)) => ServeRoute (meth Unit resp) (m resp) middlewares m where
137+ serveRoute { path, verb } = do
138+ assert $ verb == methodName @(meth Unit resp)
139+ assert $ path == []
140+ pure $ \(Nt nt) handler _middlewares _req -> do
141+ resp <- nt handler
142+ pure $ toResponse resp
143+else instance (FromRequest req, MethodName (meth resp Unit)) => ServeRoute (meth req Unit) (req -> m Unit) middlewares m where
144+ serveRoute { path, verb } = do
145+ assert $ verb == methodName @(meth resp Unit)
146+ assert $ path == []
147+ pure $ \(Nt nt) handler _middlewares req -> do
148+ liftAff (fromRequest req) >>= case _ of
149+ Nothing -> pure $ badRequest
150+ Just r -> do
151+ nt $ handler r
152+ pure $ ok
153+else instance (FromRequest req, ToResponse resp, MethodName (meth req resp)) => ServeRoute (meth req resp) (req -> m resp) middlewares m where
154+ serveRoute { path, verb } = do
155+ assert $ verb == methodName @(meth req resp)
156+ assert $ path == []
157+ pure $ \(Nt nt) handler _middlewares req -> do
158+ liftAff (fromRequest req) >>= case _ of
159+ Nothing -> pure $ badRequest
160+ Just r -> do
161+ resp <- nt $ handler r
162+ pure $ toResponse resp
163+
164+else instance
165+ ( ServeAPI routes list handlers middlewares m
166+ , RowToList routes list
167+ ) =>
168+ ServeRoute routes (Record handlers) middlewares m where
169+ serveRoute route = pure $ \nt handlers middlewares req ->
170+ serveAPI @routes @list nt handlers middlewares route req
171+
172+class ServeQuery :: Row Type -> RowList Type -> Constraint
173+class ServeQuery row list | list -> row where
174+ serveQuery :: Map String (Array String) -> Maybe (Builder (Record ()) (Record row))
175+
176+instance ServeQuery () RowList.Nil where
177+ serveQuery _ = Just $ identity
178+
179+instance
180+ ( ParsePathPiece t
181+ , ServeQuery tail rest
182+ , IsSymbol field
183+ , Row.Cons field (Array t) tail row
184+ , Row.Lacks field tail
185+ ) =>
186+ ServeQuery row (RowList.Cons field (Array t) rest) where
187+ serveQuery m = do
188+ r <- serveQuery @tail @rest m
189+ case Map.lookup (reflectSymbol @field Proxy) m of
190+ Nothing -> pure $ Builder.insert (Proxy @field) [] <<< r
191+ Just a -> do
192+ v <- parsePathPiece @t `traverse` a
193+ pure $ Builder.insert (Proxy @field) v <<< r
194+
195+else instance
196+ ( ParsePathPiece t
197+ , ServeQuery tail rest
198+ , IsSymbol field
199+ , Row.Cons field (Maybe t) tail row
200+ , Row.Lacks field tail
201+ ) =>
202+ ServeQuery row (RowList.Cons field (Maybe t) rest) where
203+ serveQuery m = do
204+ r <- serveQuery @tail @rest m
205+ case Map.lookup (reflectSymbol @field Proxy) m of
206+ Nothing -> pure $ Builder.insert (Proxy @field) Nothing <<< r
207+ Just a -> do
208+ { head, tail } <- Array.uncons a
209+ assert $ tail == []
210+ v <- parsePathPiece @t head
211+ pure $ Builder.insert (Proxy @field) (Just v) <<< r
212+
213+else instance
214+ ( ParsePathPiece t
215+ , ServeQuery tail rest
216+ , IsSymbol field
217+ , Row.Cons field t tail row
218+ , Row.Lacks field tail
219+ ) =>
220+ ServeQuery row (RowList.Cons field t rest) where
221+ serveQuery m = do
222+ { head, tail } <- Map.lookup (reflectSymbol @field Proxy) m >>= Array.uncons
223+ assert $ tail == []
224+ v <- parsePathPiece @t head
225+ r <- serveQuery @tail @rest m
226+ pure $ Builder.insert (Proxy @field) v <<< r
227+
228+data ResponseBody
229+ = JsonResponseBody Json
230+ | EmptyResponseBody
231+ | StringResponseBody String
232+
233+newtype Response = Response { body :: ResponseBody, status :: Int, statusText :: String, headers :: Object String }
234+
235+class ToResponse r where
236+ toResponse :: r -> Response
237+
238+instance EncodeJson (Record row) => ToResponse (Record row) where
239+ toResponse rec = toResponse $ encodeJson rec
240+
241+instance EncodeJson t => ToResponse (Array t) where
242+ toResponse = encodeJson >>> toResponse
243+
244+instance ToResponse Response where
245+ toResponse resp = resp
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+
262+class FromRequest r where
263+ fromRequest :: Request -> Aff (Maybe r)
264+
265+instance DecodeJson (Record row) => FromRequest (Record row) where
266+ fromRequest req = Request.json req <#> \j -> case decodeJson j of
267+ Right r -> Just r
268+ Left _ -> Nothing
269+
270+instance FromRequest Request where
271+ fromRequest req = pure $ Just req
272+
273+instance FromRequest Unit where
274+ fromRequest _ = pure $ Just unit
275+
276+instance
277+ ( FromRequest req
278+ , FromHeader header
279+ ) =>
280+ FromRequest (Headers (Object header) req) where
281+ fromRequest req = do
282+ r <- fromRequest req
283+ pure $ do
284+ headers <- traverse fromHeader (Request.headers req)
285+ r' <- r
286+ pure $ Headers headers r'
287+
288+instance
289+ ( RowToList headers headersList
290+ , FromRequest req
291+ , FromHeaders headers headersList
292+ ) =>
293+ FromRequest (Headers (Record headers) req) where
294+ fromRequest req = do
295+ r <- fromRequest req
296+ pure $ do
297+ headers <- fromHeaders @headers @headersList (Request.headers req)
298+ r' <- r
299+ pure $ Headers (Builder.buildFromScratch headers) r'
300+
301+class ParsePathPiece t where
302+ parsePathPiece :: String -> Maybe t
303+
304+instance ParsePathPiece String where
305+ parsePathPiece = Just
306+
307+instance ParsePathPiece Int where
308+ parsePathPiece = Int.fromString
309+
310+instance ParsePathPiece Number where
311+ parsePathPiece = Number.fromString
312+
313+instance ParsePathPiece Boolean where
314+ parsePathPiece s = case String.toLower s of
315+ "true" -> Just true
316+ "1" -> Just true
317+ "false" -> Just false
318+ "0" -> Just false
319+ _ -> Nothing
320+
321+assert :: forall m. Applicative m => Plus m => Boolean -> m Unit
322+assert true = pure unit
323+assert false = empty
324+
325+class ServeAPI :: Row Type -> RowList Type -> Row Type -> Row Type -> (Type -> Type) -> Constraint
326+class ServeAPI row list handlers middlewares m | row -> handlers, handlers -> m where
327+ serveAPI :: Nt m -> Record handlers -> Record middlewares -> Route -> Request -> Server Response
328+
329+instance ServeAPI row RowList.Nil () middlewares m where
330+ serveAPI _ _ _ _ _ = pure notFound
331+
332+instance
333+ ( ServeRoute t handler middlewares m
334+ , Row.Cons field t tail row
335+ , ServeAPI row rest restHandlers middlewares m
336+ , IsSymbol field
337+ , Row.Cons field handler restHandlers handlers
338+ , Row.Lacks field restHandlers
339+ ) =>
340+ ServeAPI row (RowList.Cons field t rest) handlers middlewares m where
341+ serveAPI nt handlers middlewares route req =
342+ case serveRoute @t route of
343+ Nothing -> serveAPI @row @rest @restHandlers @middlewares nt (Record.delete (Proxy @field) handlers) middlewares route req
344+ Just f -> f nt (Record.get (Proxy @field) handlers) middlewares req
345+
346+notFound :: Response
347+notFound = Response { body: EmptyResponseBody, status: 404, statusText: "Not Found", headers: Object.empty }
348+
349+internalServerError :: Response
350+internalServerError = Response { body: EmptyResponseBody, status: 500, statusText: "Internal Server Error", headers: Object.empty }
351+
352+badRequest :: Response
353+badRequest = Response { body: EmptyResponseBody, status: 400, statusText: "Bad Request", headers: Object.empty }
354+
355+ok :: Response
356+ok = Response { body: EmptyResponseBody, status: 200, statusText: "OK", headers: Object.empty }
357+
358+-- | The first argument is used to run an arbitrary monad in handlers. To use the 'Server' monad
359+-- | instead you can just pass `identity` as the first argument.
360+run
361+ :: forall @row list handlers m middlewares
362+ . RowToList row list
363+ => ServeAPI row list handlers middlewares m
364+ => (forall x. m x -> Server x)
365+ -> { handlers :: Record handlers, middlewares :: Record middlewares }
366+ -> Request
367+ -> Aff Bun.Response.Response
368+run nt { handlers, middlewares } req = do
369+ Response { body, headers, status, statusText } <-
370+ map (either identity identity) $ runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers middlewares (routeFromRequest req) req
371+ let opts = { headers, status, statusText }
372+ pure $ case body of
373+ EmptyResponseBody -> Bun.Response.string "" opts
374+ JsonResponseBody json -> Bun.Response.json json opts
375+ StringResponseBody string -> Bun.Response.string string opts
src/Snabbdom.jsnew file+1
@@ -0,0 +1 @@
1+function m(f,G){let z,W=G.elm,X=f.data.attrs,Z=G.data.attrs;if(!X&&!Z)return;if(X===Z)return;X=X||{},Z=Z||{};for(z in Z){let K=Z[z];if(X[z]!==K)if(K===!0)W.setAttribute(z,"");else if(K===!1)W.removeAttribute(z);else if(z.charCodeAt(0)!==120)W.setAttribute(z,K);else if(z.charCodeAt(3)===58)W.setAttributeNS("http://www.w3.org/XML/1998/namespace",z,K);else if(z.charCodeAt(5)===58)z.charCodeAt(1)===109?W.setAttributeNS("http://www.w3.org/2000/xmlns/",z,K):W.setAttributeNS("http://www.w3.org/1999/xlink",z,K);else W.setAttribute(z,K)}for(z in X)if(!(z in Z))W.removeAttribute(z)}var s={create:m,update:m};function r(f,G,z){if(typeof f==="function")f.call(G,z,G);else if(typeof f==="object")for(let W=0;W<f.length;W++)r(f[W],G,z)}function G0(f,G){let z=f.type,W=G.data.on;if(W&&W[z])r(W[z],G,f)}function J0(){return function f(G){G0(G,f.vnode)}}function x(f,G){let z=f.data.on,W=f.listener,X=f.elm,Z=G&&G.data.on,K=G&&G.elm,U;if(z===Z)return;if(z&&W){if(!Z)for(U in z)X.removeEventListener(U,W,!1);else for(U in z)if(!Z[U])X.removeEventListener(U,W,!1)}if(Z){let D=G.listener=f.listener||J0();if(D.vnode=G,!z)for(U in Z)K.addEventListener(U,D,!1);else for(U in Z)if(!z[U])K.addEventListener(U,D,!1)}}var l={create:x,update:x,destroy:x};function N(f,G,z,W,X){let Z=G===void 0?void 0:G.key;return{sel:f,data:G,children:z,text:W,elm:X,key:Z}}var u=Array.isArray;function a(f){return typeof f==="string"||typeof f==="number"||f instanceof String||f instanceof Number}function Y0(f,G){return document.createElement(f,G)}function Z0(f,G,z){return document.createElementNS(f,G,z)}function $0(){return I(document.createDocumentFragment())}function B0(f){return document.createTextNode(f)}function q0(f){return document.createComment(f)}function K0(f,G,z){if(S(f)){let W=f;while(W&&S(W))W=I(W).parent;f=W!==null&&W!==void 0?W:f}if(S(G))G=I(G,f);if(z&&S(z))z=I(z).firstChildNode;f.insertBefore(G,z)}function P0(f,G){f.removeChild(G)}function H0(f,G){if(S(G))G=I(G,f);f.appendChild(G)}function t(f){if(S(f)){while(f&&S(f))f=I(f).parent;return f!==null&&f!==void 0?f:null}return f.parentNode}function O0(f){var G;if(S(f)){let z=I(f),W=t(z);if(W&&z.lastChildNode){let X=Array.from(W.childNodes),Z=X.indexOf(z.lastChildNode);return(G=X[Z+1])!==null&&G!==void 0?G:null}return null}return f.nextSibling}function U0(f){return f.tagName}function R0(f,G){f.textContent=G}function T0(f){return f.textContent}function L0(f){return f.nodeType===1}function M0(f){return f.nodeType===3}function D0(f){return f.nodeType===8}function S(f){return f.nodeType===11}function I(f,G){var z,W,X;let Z=f;return(z=Z.parent)!==null&&z!==void 0||(Z.parent=G!==null&&G!==void 0?G:null),(W=Z.firstChildNode)!==null&&W!==void 0||(Z.firstChildNode=f.firstChild),(X=Z.lastChildNode)!==null&&X!==void 0||(Z.lastChildNode=f.lastChild),Z}var E={createElement:Y0,createElementNS:Z0,createTextNode:B0,createDocumentFragment:$0,createComment:q0,insertBefore:K0,removeChild:P0,appendChild:H0,parentNode:t,nextSibling:O0,tagName:U0,setTextContent:R0,getTextContent:T0,isElement:L0,isText:M0,isComment:D0,isDocumentFragment:S};var V=N("",{},[],void 0,void 0);function w(f,G){var z,W;let X=f.key===G.key,Z=((z=f.data)===null||z===void 0?void 0:z.is)===((W=G.data)===null||W===void 0?void 0:W.is),K=f.sel===G.sel,U=!f.sel&&f.sel===G.sel?typeof f.text===typeof G.text:!0;return K&&X&&Z&&U}function A0(){throw new Error("The document fragment is not supported on this platform.")}function j0(f,G){return f.isElement(G)}function F0(f,G){return f.isDocumentFragment(G)}function Q0(f,G,z){var W;let X={};for(let Z=G;Z<=z;++Z){let K=(W=f[Z])===null||W===void 0?void 0:W.key;if(K!==void 0)X[K]=Z}return X}var g0=["create","update","remove","destroy","pre","post"];function n(f,G,z){let W={create:[],update:[],remove:[],destroy:[],pre:[],post:[]},X=G!==void 0?G:E;for(let J of g0)for(let Y of f){let $=Y[J];if($!==void 0)W[J].push($)}function Z(J){let Y=J.id?"#"+J.id:"",$=J.getAttribute("class"),B=$?"."+$.split(" ").join("."):"";return N(X.tagName(J).toLowerCase()+Y+B,{},[],void 0,J)}function K(J){return N(void 0,{},[],void 0,J)}function U(J,Y){return function $(){if(--Y===0){let B=X.parentNode(J);if(B!==null)X.removeChild(B,J)}}}function D(J,Y){var $,B,P,O,L;let q,R=J.data,M=R===null||R===void 0?void 0:R.hook;($=M===null||M===void 0?void 0:M.init)===null||$===void 0||$.call(M,J);let{children:T,sel:H}=J;if(H==="!")(B=J.text)!==null&&B!==void 0||(J.text=""),J.elm=X.createComment(J.text);else if(H==="")J.elm=X.createTextNode(J.text);else if(H!==void 0){let A=H.indexOf("#"),j=H.indexOf(".",A),F=A>0?A:H.length,b=j>0?j:H.length,i=A!==-1||j!==-1?H.slice(0,Math.min(F,b)):H,p=R===null||R===void 0?void 0:R.ns,_=p===void 0?X.createElement(i,R):X.createElementNS(p,i,R);if(J.elm=_,F<b)_.setAttribute("id",H.slice(F+1,b));if(j>0)_.setAttribute("class",H.slice(b+1).replace(/\./g," "));for(q=0;q<W.create.length;++q)W.create[q](V,J);if(a(J.text)&&(!u(T)||T.length===0))X.appendChild(_,X.createTextNode(J.text));if(u(T))for(q=0;q<T.length;++q){let v=T[q];if(v!=null)X.appendChild(_,D(v,Y))}if(M!==void 0){if((P=M.create)===null||P===void 0||P.call(M,V,J),M.insert!==void 0)Y.push(J)}}else if(((O=z===null||z===void 0?void 0:z.experimental)===null||O===void 0?void 0:O.fragments)&&J.children){J.elm=((L=X.createDocumentFragment)!==null&&L!==void 0?L:A0)();for(q=0;q<W.create.length;++q)W.create[q](V,J);for(q=0;q<J.children.length;++q){let A=J.children[q];if(A!=null)X.appendChild(J.elm,D(A,Y))}}else J.elm=X.createTextNode(J.text);return J.elm}function y(J,Y,$,B,P,O){for(;B<=P;++B){let L=$[B];if(L!=null)X.insertBefore(J,D(L,O),Y)}}function k(J){var Y,$;let B=J.data;if(B!==void 0){($=(Y=B===null||B===void 0?void 0:B.hook)===null||Y===void 0?void 0:Y.destroy)===null||$===void 0||$.call(Y,J);for(let P=0;P<W.destroy.length;++P)W.destroy[P](J);if(J.children!==void 0)for(let P=0;P<J.children.length;++P){let O=J.children[P];if(O!=null&&typeof O!=="string")k(O)}}}function g(J,Y,$,B){var P,O;for(;$<=B;++$){let L,q=Y[$];if(q!=null)if(q.sel!==void 0){k(q),L=W.remove.length+1;let R=U(q.elm,L);for(let T=0;T<W.remove.length;++T)W.remove[T](q,R);let M=(O=(P=q===null||q===void 0?void 0:q.data)===null||P===void 0?void 0:P.hook)===null||O===void 0?void 0:O.remove;if(M!==void 0)M(q,R);else R()}else if(q.children)k(q),g(J,q.children,0,q.children.length-1);else X.removeChild(J,q.elm)}}function C(J,Y,$,B){let P=0,O=0,L=Y.length-1,q=Y[0],R=Y[L],M=$.length-1,T=$[0],H=$[M],A,j,F,b;while(P<=L&&O<=M)if(q==null)q=Y[++P];else if(R==null)R=Y[--L];else if(T==null)T=$[++O];else if(H==null)H=$[--M];else if(w(q,T))Q(q,T,B),q=Y[++P],T=$[++O];else if(w(R,H))Q(R,H,B),R=Y[--L],H=$[--M];else if(w(q,H))Q(q,H,B),X.insertBefore(J,q.elm,X.nextSibling(R.elm)),q=Y[++P],H=$[--M];else if(w(R,T))Q(R,T,B),X.insertBefore(J,R.elm,q.elm),R=Y[--L],T=$[++O];else{if(A===void 0)A=Q0(Y,P,L);if(j=A[T.key],j===void 0)X.insertBefore(J,D(T,B),q.elm),T=$[++O];else if(A[H.key]===void 0)X.insertBefore(J,D(H,B),X.nextSibling(R.elm)),H=$[--M];else{if(F=Y[j],F.sel!==T.sel)X.insertBefore(J,D(T,B),q.elm);else Q(F,T,B),Y[j]=void 0,X.insertBefore(J,F.elm,q.elm);T=$[++O]}}if(O<=M)b=$[M+1]==null?null:$[M+1].elm,y(J,b,$,O,M,B);if(P<=L)g(J,Y,P,L)}function Q(J,Y,$){var B,P,O,L,q,R,M,T;let H=(B=Y.data)===null||B===void 0?void 0:B.hook;(P=H===null||H===void 0?void 0:H.prepatch)===null||P===void 0||P.call(H,J,Y);let A=Y.elm=J.elm;if(J===Y)return;if(Y.data!==void 0||Y.text!==void 0&&Y.text!==J.text){(O=Y.data)!==null&&O!==void 0||(Y.data={}),(L=J.data)!==null&&L!==void 0||(J.data={});for(let b=0;b<W.update.length;++b)W.update[b](J,Y);(M=(R=(q=Y.data)===null||q===void 0?void 0:q.hook)===null||R===void 0?void 0:R.update)===null||M===void 0||M.call(R,J,Y)}let j=J.children,F=Y.children;if(Y.text===void 0){if(j!==void 0&&F!==void 0){if(j!==F)C(A,j,F,$)}else if(F!==void 0){if(J.text!==void 0)X.setTextContent(A,"");y(A,null,F,0,F.length-1,$)}else if(j!==void 0)g(A,j,0,j.length-1);else if(J.text!==void 0)X.setTextContent(A,"")}else if(J.text!==Y.text){if(j!==void 0)g(A,j,0,j.length-1);X.setTextContent(A,Y.text)}(T=H===null||H===void 0?void 0:H.postpatch)===null||T===void 0||T.call(H,J,Y)}return function J(Y,$){let B,P,O,L=[];for(B=0;B<W.pre.length;++B)W.pre[B]();if(j0(X,Y))Y=Z(Y);else if(F0(X,Y))Y=K(Y);if(w(Y,$))Q(Y,$,L);else if(P=Y.elm,O=X.parentNode(P),D($,L),O!==null)X.insertBefore(O,$.elm,X.nextSibling(P)),g(O,[Y],0,0);for(B=0;B<L.length;++B)L[B].data.hook.insert(L[B]);for(B=0;B<W.post.length;++B)W.post[B]();return $}}var o=typeof(window===null||window===void 0?void 0:window.requestAnimationFrame)==="function"?window.requestAnimationFrame.bind(window):setTimeout,b0=(f)=>{o(()=>{o(f)})},c=!1;function k0(f,G,z){b0(()=>{f[G]=z})}function d(f,G){let z,W,X=G.elm,Z=f.data.style,K=G.data.style;if(!Z&&!K)return;if(Z===K)return;Z=Z||{},K=K||{};let U="delayed"in Z;for(W in Z)if(!(W in K))if(W[0]==="-"&&W[1]==="-")X.style.removeProperty(W);else X.style[W]="";for(W in K)if(z=K[W],W==="delayed"&&K.delayed){for(let D in K.delayed)if(z=K.delayed[D],!U||z!==Z.delayed[D])k0(X.style,D,z)}else if(W!=="remove"&&z!==Z[W])if(W[0]==="-"&&W[1]==="-")X.style.setProperty(W,z);else X.style[W]=z}function N0(f){let G,z,W=f.elm,X=f.data.style;if(!X||!(G=X.destroy))return;for(z in G)W.style[z]=G[z]}function S0(f,G){let z=f.data.style;if(!z||!z.remove){G();return}if(!c)f.elm.offsetLeft,c=!0;let W,X=f.elm,Z=0,K=z.remove,U=0,D=[];for(W in K)D.push(W),X.style[W]=K[W];let k=getComputedStyle(X)["transition-property"].split(", ");for(;Z<k.length;++Z)if(D.indexOf(k[Z])!==-1)U++;X.addEventListener("transitionend",(g)=>{if(g.target===X)--U;if(U===0)G()})}function y0(){c=!1}var e={pre:y0,create:d,update:d,destroy:N0,remove:S0};function f0(f,G){let z,W,X,Z=G.elm,K=f.data.props,U=G.data.props;if(!K&&!U)return;if(K===U)return;K=K||{},U=U||{};for(z in U)if(W=U[z],X=K[z],X!==W&&(z!=="value"||Z[z]!==W))Z[z]=W}var W0={create:f0,update:f0};function h(f,G,z){if(f.ns="http://www.w3.org/2000/svg",z!=="foreignObject"&&G!==void 0)for(let W=0;W<G.length;++W){let X=G[W];if(typeof X==="string")continue;let Z=X.data;if(Z!==void 0)h(Z,X.children,X.sel)}}function I0(f){return f.slice(5).replace(/-([a-z])/g,(G,z)=>z.toUpperCase())}function z0(f,G){var z;let W=G!==void 0?G:E,X;if(W.isElement(f)){let Z=f.id?"#"+f.id:"",K=(z=f.getAttribute("class"))===null||z===void 0?void 0:z.match(/[^\t\r\n\f ]+/g),U=K?"."+K.join("."):"",D=W.tagName(f).toLowerCase()+Z+U,y={},k={},g={},C=[],Q,J,Y,$=f.attributes,B=f.childNodes;for(J=0,Y=$.length;J<Y;J++)if(Q=$[J].nodeName,Q.startsWith("data-"))k[I0(Q)]=$[J].nodeValue||"";else if(Q!=="id"&&Q!=="class")y[Q]=$[J].nodeValue;for(J=0,Y=B.length;J<Y;J++)C.push(z0(B[J],G));if(Object.keys(y).length>0)g.attrs=y;if(Object.keys(k).length>0)g.dataset=k;if(D.startsWith("svg")&&(D.length===3||D[3]==="."||D[3]==="#"))h(g,C,D);return N(D,g,C,void 0,f)}else if(W.isText(f))return X=W.getTextContent(f),N(void 0,void 0,void 0,X,f);else if(W.isComment(f))return X=W.getTextContent(f),N("!",{},[],X,f);else return N("",{},[],void 0,f)}function o0(){return n([s,l,e,W0])}export{N as vnode,z0 as toVNode,o0 as initWithModules};
src/Snabbdom.pursnew file+45
@@ -0,0 +1,45 @@
1+module Snabbdom (h, VNode, init, toVNode) where
2+
3+import Prelude
4+
5+import Data.Function.Uncurried (Fn4, runFn4)
6+import Effect (Effect)
7+import Effect.Uncurried (EffectFn1, EffectFn2, mkEffectFn1, runEffectFn2)
8+import Foreign.Object (Object)
9+import Literals.Undefined (Undefined)
10+import Untagged.Union (type (|+|))
11+import Web.DOM (Element)
12+import Web.Event.Event (Event)
13+
14+foreign import data VNode :: Type
15+
16+foreign import initWithModules :: Effect (EffectFn2 VNode VNode VNode)
17+
18+init :: Effect (VNode -> VNode -> Effect VNode)
19+init = initWithModules <#> runEffectFn2
20+
21+foreign import vnode :: forall props. Fn4 String (Record props) (Array VNode) (String |+| Undefined) VNode
22+
23+h
24+ :: String
25+ -> { attrs :: Object String
26+ , on :: Object (Event -> Effect Unit)
27+ , style :: Object String
28+ , props :: Object String
29+ }
30+ -> Array VNode
31+ -> (String |+| Undefined)
32+ -> VNode
33+h tag props children text = runFn4 vnode
34+ tag
35+ ( props { on = mkEffectFn1 <$> props.on }
36+ :: { attrs :: Object String
37+ , on :: Object (EffectFn1 Event Unit)
38+ , style :: Object String
39+ , props :: Object String
40+ }
41+ )
42+ children
43+ text
44+
45+foreign import toVNode :: Element -> VNode