git.iko.soy/purestack-dev/todomvc
on master help sign in
Copied all sources
commit12b152b9d99d2c66a63ddda23451287ee5862eff authoriko <mail@iko.soy> dateMon 23 Jun 2025, 19:24 (1 year ago) parent0bca6d2
22 files changed+2741−1
compare with master
unifiedsplit
spago.dhall+52−1 src/Bun/Request.js+15 src/Bun/Request.purs+28 src/Bun/Response.js+35 src/Bun/Response.purs+18 src/Bun/Server.js+9 src/Bun/Server.purs+15 src/Data/Base64.js+53 src/Data/Base64.purs+45 src/Data/DateTime/ISO.purs+156 src/Plum.purs+86 src/Plum/View.purs+700 src/ProjectM36.purs+517 src/PureStack/Cookie.purs+57 src/PureStack/Cookie/Formatter.purs+65 src/PureStack/Cookie/Generator.purs+62 src/PureStack/Cookie/Parser.purs+128 src/PureStack/Cookie/Types.purs+189 src/PureStack/Route.purs+55 src/PureStack/Server.purs+410 src/Snabbdom.js+1 src/Snabbdom.purs+45
spago.dhall+52−1
@@ -1,5 +1,56 @@
11{ 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+ , "ezfetch"
19+ , "foldable-traversable"
20+ , "foreign"
21+ , "foreign-object"
22+ , "formatters"
23+ , "functions"
24+ , "integers"
25+ , "lists"
26+ , "literals"
27+ , "maybe"
28+ , "newtype"
29+ , "now"
30+ , "numbers"
31+ , "ordered-collections"
32+ , "parsing"
33+ , "partial"
34+ , "prelude"
35+ , "profunctor-lenses"
36+ , "record"
37+ , "refs"
38+ , "run"
39+ , "safe-coerce"
40+ , "simple-json"
41+ , "strings"
42+ , "strings-extra"
43+ , "transformers"
44+ , "tuples"
45+ , "typelevel-prelude"
46+ , "unsafe-coerce"
47+ , "untagged-union"
48+ , "url-immutable"
49+ , "web-dom"
50+ , "web-events"
51+ , "web-html"
52+ , "web-uievents"
53+ ]
354, packages = ./packages.dhall
455, sources = [ "src/**/*.purs", "test/**/*.purs" ]
556}
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/Plum.pursnew file+86
@@ -0,0 +1,86 @@
1+module Plum (Plum, run) where
2+
3+import Prelude
4+
5+import Data.Array as Array
6+import Data.Maybe (Maybe(..))
7+import Effect (Effect)
8+import Effect.Console (log)
9+import Effect.Ref as Ref
10+import Foreign.Object as Object
11+import Literals.Undefined (undefined)
12+import Plum.View (GenericUI(..), UI, grow)
13+import Snabbdom as Snabbdom
14+import Untagged.Union (asOneOf)
15+import Web.DOM.NonElementParentNode (getElementById) as Web
16+import Web.HTML (window) as Web
17+import Web.HTML.HTMLDocument (toNonElementParentNode) as Web
18+import Web.HTML.Window (document) as Web
19+
20+type Plum msg model =
21+ { init :: Effect model
22+ , update :: msg -> model -> Effect model
23+ , view :: model -> UI msg Unit
24+ }
25+
26+run :: forall msg model. String -> Plum msg model -> Effect Unit
27+run id plum = do
28+ Web.window >>= Web.document >>= Web.getElementById id <<< Web.toNonElementParentNode >>= case _ of
29+ Just element -> do
30+ let node = Snabbdom.toVNode element
31+ patch <- Snabbdom.init
32+ initModel <- plum.init
33+ modelRef <- Ref.new { model: initModel, lastNode: node }
34+ let
35+ view model = do
36+ let UI { children } _ = plum.view model
37+ case Array.uncons children of
38+ Just { head: child } -> do
39+ let
40+ { node, style } = grow
41+ ( \msg -> do
42+ log "in"
43+ { model: m, lastNode } <- Ref.read modelRef
44+ m_ <- plum.update msg m
45+ node <- view m_
46+ newNode <- patch lastNode node
47+ Ref.write { model: m_, lastNode: newNode } modelRef
48+ pure unit
49+ )
50+ child
51+ pure $
52+ Snabbdom.h "div"
53+ { attrs: Object.empty
54+ , on: Object.empty
55+ , style: Object.empty
56+ , props: Object.empty
57+ }
58+ [ Snabbdom.h "style"
59+ { attrs: Object.empty
60+ , on: Object.empty
61+ , style: Object.empty
62+ , props: Object.empty
63+ }
64+ []
65+ (asOneOf $ outerStyle <> style)
66+ , node
67+ ]
68+ (asOneOf undefined)
69+ Nothing -> pure $
70+ Snabbdom.h "div"
71+ { attrs: Object.empty
72+ , on: Object.empty
73+ , style: Object.empty
74+ , props: Object.empty
75+ }
76+ []
77+ (asOneOf undefined)
78+ newNode <- view initModel
79+ newNode_ <- patch node newNode
80+ log "patched"
81+ Ref.write { model: initModel, lastNode: newNode_ } modelRef
82+ pure unit
83+ Nothing -> pure unit
84+
85+outerStyle :: String
86+outerStyle = "html,body{height:100%;padding:0;margin:0;}"
src/Plum/View.pursnew file+700
@@ -0,0 +1,700 @@
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+ , fontSize
58+ , fontWeight
59+ , onClick
60+ ) where
61+
62+import Prelude
63+
64+import Control.Monad.Writer (Writer, runWriter, tell)
65+import Control.Monad.Writer.Trans (mapWriterT)
66+import Data.Array (foldMap)
67+import Data.Array as Array
68+import Data.Array.NonEmpty (concatMap)
69+import Data.Int as Int
70+import Data.Maybe (Maybe(..))
71+import Data.Maybe as Maybe
72+import Data.String as String
73+import Data.Traversable (traverse)
74+import Data.TraversableWithIndex (traverseWithIndex)
75+import Data.Tuple.Nested (type (/\), (/\))
76+import Effect (Effect)
77+import Foreign.Object (Object)
78+import Foreign.Object as Object
79+import Literals.Undefined (undefined)
80+import Prim.TypeError (class Warn)
81+import Prim.TypeError as TypeError
82+import Snabbdom (VNode)
83+import Snabbdom as Snabbdom
84+import Type.Row.Homogeneous (class Homogeneous)
85+import Unsafe.Coerce (unsafeCoerce)
86+import Untagged.Union (asOneOf)
87+import Web.DOM.Element as Element
88+import Web.DOM.ParentNode (firstElementChild)
89+import Web.Event.Event (Event)
90+import Web.Event.Event as Event
91+import Web.UIEvent.InputEvent as InputEvent
92+import Web.HTML.HTMLInputElement as HTMLInputElement
93+
94+type GenericUIView children msg =
95+ { nerves :: Array (Nerve msg)
96+ , meat :: Array Meat
97+ , hover :: Array Meat
98+ , down :: Array Meat
99+ , children :: children
100+ }
101+
102+type UIView msg = GenericUIView (Array (View msg)) msg
103+
104+data GenericUI children msg a = UI (GenericUIView children msg) a
105+
106+instance (Semigroup children, Semigroup a) => Semigroup (GenericUI children msg a) where
107+ append (UI v a) (UI v' a') = UI (v <> v') (a <> a')
108+
109+instance (Monoid children, Monoid a) => Monoid (GenericUI children msg a) where
110+ mempty = UI mempty mempty
111+
112+type UI msg a = GenericUI (Array (View msg)) msg a
113+
114+instance Functor (GenericUI children msg) where
115+ map f (UI v a) = UI v $ f a
116+
117+instance Monoid children => Apply (GenericUI children msg) where
118+ apply (UI views f) (UI views' a) = UI (views <> views') (f a)
119+
120+instance Monoid children => Applicative (GenericUI children msg) where
121+ pure = UI mempty
122+
123+instance Monoid children => Bind (GenericUI children msg) where
124+ bind (UI views a) f =
125+ let
126+ UI views' b = f a
127+ in
128+ UI (views <> views') b
129+
130+instance Monoid children => Monad (GenericUI children msg)
131+
132+column :: forall msg. UI msg Unit -> UI msg Unit
133+column (UI { nerves, meat, hover, down, children } _) =
134+ UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ Column children ] } unit
135+
136+row :: forall msg a. UI msg a -> UI msg a
137+row (UI { nerves, meat, hover, down, children } a) =
138+ UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ Row children ] } a
139+
140+stack :: forall msg a. UI msg a -> UI msg a
141+stack (UI { nerves, meat, hover, down, children } a) =
142+ UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ Stack children ] } a
143+
144+text :: forall msg. String -> GenericUI Unit msg Unit -> UI msg Unit
145+text s (UI { nerves, meat, hover, down } a) = UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ Text s ] } a
146+
147+link :: forall msg a. String -> UI msg a -> UI msg a
148+link url (UI { nerves, meat, hover, down, children } a) = UI
149+ (mempty :: UIView msg)
150+ { children =
151+ [ { meat
152+ , nerves
153+ , hover
154+ , down
155+ } /\ Link url { newTab: false } (Maybe.fromMaybe none $ Array.head children)
156+ ]
157+ }
158+ a
159+
160+newTabLink :: forall msg a. String -> UI msg a -> UI msg a
161+newTabLink url (UI { nerves, meat, hover, down, children } a) = UI
162+ (mempty :: UIView msg)
163+ { children =
164+ [ { meat
165+ , nerves
166+ , hover
167+ , down
168+ } /\ Link url { newTab: true } (Maybe.fromMaybe none $ Array.head children)
169+ ]
170+ }
171+ a
172+
173+download :: forall msg a. String -> UI msg a -> UI msg a
174+download url (UI { nerves, meat, children, down, hover } a) = UI
175+ (mempty :: UIView msg)
176+ { children =
177+ [ { meat
178+ , nerves
179+ , down
180+ , hover
181+ } /\ Download url { filename: Nothing } (Maybe.fromMaybe none $ Array.head children)
182+ ]
183+ }
184+ a
185+
186+downloadAs :: forall msg a. String -> { filename :: String } -> UI msg a -> UI msg a
187+downloadAs url { filename } (UI { nerves, meat, hover, down, children } a) = UI
188+ (mempty :: UIView msg)
189+ { children =
190+ [ { meat
191+ , nerves
192+ , hover
193+ , down
194+ } /\ Download url { filename: Just filename } (Maybe.fromMaybe none $ Array.head children)
195+ ]
196+ }
197+ a
198+
199+image :: forall msg a. String -> { description :: String } -> GenericUI Unit msg a -> UI msg a
200+image url description (UI { nerves, meat, hover, down } a) =
201+ UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ Image url description ] } a
202+
203+textInput :: forall msg a. { value :: String, onChange :: String -> msg } -> GenericUI Unit msg a -> UI msg a
204+textInput props (UI { nerves, meat, hover, down } a) =
205+ UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ TextInput props ] } a
206+
207+string :: String -> Classes -> WiredNerves -> String -> VNode
208+string elem classes (WiredNerves on) s =
209+ Snabbdom.h elem
210+ { attrs: Object.singleton "class" (Array.intercalate " " classes)
211+ , on
212+ , style: Object.empty
213+ , props: Object.empty
214+ }
215+ []
216+ (asOneOf s)
217+
218+h :: String -> Classes -> WiredNerves -> Array VNode -> VNode
219+h elem classes (WiredNerves on) children =
220+ Snabbdom.h elem
221+ { attrs: Object.singleton "class" (Array.intercalate " " classes)
222+ , on
223+ , props: Object.empty
224+ , style: Object.empty
225+ }
226+ children
227+ (asOneOf undefined)
228+
229+hWith :: forall props. Homogeneous props String => String -> Record props -> Classes -> WiredNerves -> Array VNode -> VNode
230+hWith elem props classes (WiredNerves on) children =
231+ Snabbdom.h elem
232+ { attrs: Object.singleton "class" (Array.intercalate " " classes)
233+ , on
234+ , props: Object.fromHomogeneous props
235+ , style: Object.empty
236+ }
237+ children
238+ (asOneOf undefined)
239+
240+data Length = Px Int | Fill | Fit | Max Int Length | Min Int Length
241+
242+data Alignment = Start | Center | End
243+
244+data Direction = X | Y
245+
246+n :: forall ch msg. Monoid ch => Nerve msg -> GenericUI ch msg Unit
247+n nerve = UI (mempty :: GenericUIView ch msg) { nerves = [ nerve ] } mempty
248+
249+onClick :: forall ch msg. Monoid ch => msg -> GenericUI ch msg Unit
250+onClick msg = n $ OnClick msg
251+
252+m :: forall ch msg. Monoid ch => Meat -> GenericUI ch msg Unit
253+m meat = UI (mempty :: GenericUIView ch msg) { meat = [ meat ] } mempty
254+
255+spacing :: forall ch msg. Monoid ch => { x :: Int, y :: Int } -> GenericUI ch msg Unit
256+spacing { x, y } = m $ Spacing x y
257+
258+explain :: forall ch msg. Monoid ch => Warn (TypeError.Text "Debug explain present") => GenericUI ch msg Unit
259+explain = m Explain
260+
261+align :: forall ch msg. Monoid ch => Direction -> Alignment -> GenericUI ch msg Unit
262+align dir al = m $ Align dir al
263+
264+width :: forall ch msg. Monoid ch => Length -> GenericUI ch msg Unit
265+width l = m $ Width l
266+
267+height :: forall ch msg. Monoid ch => Length -> GenericUI ch msg Unit
268+height l = m $ Height l
269+
270+wrapped :: forall ch msg. Monoid ch => GenericUI ch msg Unit
271+wrapped = m Wrapped
272+
273+bgColor :: forall ch msg. Monoid ch => Color -> GenericUI ch msg Unit
274+bgColor c = m $ BackgroundColor c
275+
276+padding :: forall ch msg. Monoid ch => Side -> Int -> GenericUI ch msg Unit
277+padding s l = m $ Padding s l
278+
279+spread :: forall ch msg. Monoid ch => GenericUI ch msg Unit
280+spread = m Spread
281+
282+opacity :: forall ch msg. Monoid ch => Number -> GenericUI ch msg Unit
283+opacity o = m $ Opacity o
284+
285+pointer :: forall ch msg. Monoid ch => GenericUI ch msg Unit
286+pointer = m Pointer
287+
288+move :: forall ch msg. Monoid ch => { x :: Int, y :: Int } -> GenericUI ch msg Unit
289+move a = m $ Move a
290+
291+clip :: forall ch msg. Monoid ch => Direction -> GenericUI ch msg Unit
292+clip dir = m $ Clip dir
293+
294+onHover :: forall ch msg. Monoid ch => GenericUI Unit msg Unit -> GenericUI ch msg Unit
295+onHover (UI { meat } a) = UI (mempty :: GenericUIView ch msg) { hover = meat } a
296+
297+onMouseDown :: forall ch msg. Monoid ch => GenericUI Unit msg Unit -> GenericUI ch msg Unit
298+onMouseDown (UI { meat } a) = UI (mempty :: GenericUIView ch msg) { down = meat } a
299+
300+borders :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
301+borders l = Array.foldMap (\s -> m $ BorderWidth s l) [ Top, Right, Bottom, Left ]
302+
303+border :: forall ch msg. Monoid ch => Side -> Int -> GenericUI ch msg Unit
304+border s l = m $ BorderWidth s l
305+
306+borderStyle :: forall ch msg. Monoid ch => BorderStyle -> GenericUI ch msg Unit
307+borderStyle s = m $ BorderStyle s
308+
309+roundAll :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
310+roundAll l = Array.foldMap (\c -> m $ Round c l) [ TopLeft, TopRight, BottomRight, BottomLeft ]
311+
312+round :: forall ch msg. Monoid ch => Corner -> Int -> GenericUI ch msg Unit
313+round c l = m $ Round c l
314+
315+shadow :: forall ch msg. Monoid ch => ShadowCfg -> GenericUI ch msg Unit
316+shadow cfg = m $ Shadow $ ShadowCfg cfg
317+
318+innerShadow :: forall ch msg. Monoid ch => ShadowCfg -> GenericUI ch msg Unit
319+innerShadow cfg = m $ InnerShadow $ ShadowCfg cfg
320+
321+font :: forall ch msg. Monoid ch => String -> GenericUI ch msg Unit
322+font f = m $ Font f
323+
324+fontSize :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
325+fontSize f = m $ FontSize f
326+
327+fontWeight :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
328+fontWeight f = m $ FontWeight f
329+
330+data Meat
331+ = Spacing Int Int
332+ | Explain
333+ | Align Direction Alignment
334+ | Width Length
335+ | Height Length
336+ | Wrapped
337+ | BackgroundColor Color
338+ | Padding Side Int
339+ | Spread
340+ | Opacity Number
341+ | Pointer
342+ | Move { x :: Int, y :: Int }
343+ | Clip Direction
344+ | BorderWidth Side Int
345+ | BorderStyle BorderStyle
346+ | Round Corner Int
347+ | Shadow Shadow
348+ | InnerShadow Shadow
349+ | FontColor Color
350+ | FontWeight Int
351+ | FontSize Int
352+ | Font Font
353+
354+type Font = String
355+
356+type ShadowCfg = { offset :: { x :: Int, y :: Int }, size :: Number, blur :: Number, color :: Color }
357+
358+newtype Shadow = ShadowCfg ShadowCfg
359+
360+instance Renderable Shadow where
361+ render (ShadowCfg s) = show s.offset.x <> "px " <> show s.offset.y <> "px " <> show s.blur <> "px " <> show s.size <> "px " <> render s.color
362+ renderKey (ShadowCfg s) = show s.offset.x <> "-" <> show s.offset.y <> "-" <> show s.blur <> "-" <> show s.size <> "-" <> renderKey s.color
363+
364+data Corner = TopLeft | TopRight | BottomRight | BottomLeft
365+
366+instance Renderable Corner where
367+ render = case _ of
368+ TopLeft -> "top-left"
369+ TopRight -> "top-right"
370+ BottomRight -> "bottom-right"
371+ BottomLeft -> "bottom-left"
372+ renderKey = case _ of
373+ TopLeft -> "top-left"
374+ TopRight -> "top-right"
375+ BottomRight -> "bottom-right"
376+ BottomLeft -> "bottom-left"
377+
378+data BorderStyle = Solid | Dashed | Dotted
379+
380+instance Renderable BorderStyle where
381+ render = case _ of
382+ Solid -> "solid"
383+ Dashed -> "dashed"
384+ Dotted -> "dotted"
385+ renderKey = case _ of
386+ Solid -> "solid"
387+ Dashed -> "dashed"
388+ Dotted -> "dotted"
389+
390+data Side = Top | Right | Bottom | Left
391+
392+instance Renderable Side where
393+ render = case _ of
394+ Top -> "top"
395+ Right -> "right"
396+ Bottom -> "bottom"
397+ Left -> "left"
398+ renderKey = case _ of
399+ Top -> "top"
400+ Right -> "right"
401+ Bottom -> "bottom"
402+ Left -> "left"
403+
404+data Nerve msg = OnClick msg
405+
406+newtype WiredNerves = WiredNerves (Object (Event -> Effect Unit))
407+
408+instance Semigroup WiredNerves where
409+ append (WiredNerves x) (WiredNerves y) =
410+ WiredNerves $ Object.unionWith (\f g ev -> f ev *> g ev) x y
411+
412+instance Monoid WiredNerves where
413+ mempty = WiredNerves Object.empty
414+
415+wireNerve :: forall msg. (msg -> Effect Unit) -> Nerve msg -> WiredNerves
416+wireNerve fire nerve = WiredNerves $ case nerve of
417+ OnClick msg -> Object.singleton "click" $ \_ev -> fire msg
418+
419+type View msg =
420+ { nerves :: Array (Nerve msg)
421+ , meat :: Array Meat
422+ , hover :: Array Meat
423+ , down :: Array Meat
424+ } /\ Bones msg
425+
426+none :: forall msg. View msg
427+none = mempty /\ None
428+
429+newtype Skin = Skin (Object String)
430+
431+sk :: String -> String -> String -> Writer SkinGrowth Classes
432+sk cName key value = do
433+ tell $ SkinGrowth $ { meat: Object.singleton cName { key, value }, hover: Object.empty, down: Object.empty }
434+ pure [ cName ]
435+
436+instance Semigroup Skin where
437+ append (Skin x) (Skin y) = Skin $ Object.union x y
438+
439+instance Monoid Skin where
440+ mempty = Skin Object.empty
441+
442+data Context = Grid | Flexbox Direction | Generic | Span
443+
444+skin :: Context -> Meat -> Writer SkinGrowth Classes
445+skin ctx = case _ of
446+ Spacing x y -> sk ("spacing-" <> show x <> "-" <> show y) "gap" (show x <> "px " <> show y <> "px")
447+ Explain -> sk "explain" "border" "dashed magenta"
448+ Align dir alignment -> case ctx of
449+ Generic -> mempty
450+ Span -> mempty
451+ Grid ->
452+ let
453+ k =
454+ ( case dir of
455+ X -> "justify-items"
456+ Y -> "align-items"
457+ )
458+ v =
459+ ( case alignment of
460+ Start -> "start"
461+ Center -> "center"
462+ End -> "end"
463+ )
464+ in
465+ sk ("align-grid-" <> k <> "-" <> v) k v
466+
467+ Flexbox flexDir ->
468+ let
469+ k =
470+ ( case flexDir /\ dir of
471+ X /\ X -> "justify-content"
472+ X /\ Y -> "align-items"
473+ Y /\ X -> "align-items"
474+ Y /\ Y -> "justify-content"
475+ )
476+
477+ v =
478+ ( case alignment of
479+ Start -> "flex-start"
480+ Center -> "center"
481+ End -> "flex-end"
482+ )
483+ in
484+ sk ("align-flexbox-" <> k <> "-" <> v) k v
485+ Width l -> sk ("width-" <> renderKey l) "width" (render l)
486+ Height l -> sk ("height-" <> renderKey l) "height" (render l)
487+ Wrapped -> case ctx of
488+ Flexbox _ -> sk "wrapped" "flex-wrap" "wrap"
489+ _ -> pure []
490+ BackgroundColor color -> sk ("bg-color-" <> renderKey color) "background-color" (render color)
491+ Padding side l ->
492+ sk
493+ ("padding-" <> renderKey side <> "-" <> show l)
494+ ("padding-" <> render side)
495+ (show l <> "px")
496+ Spread -> case ctx of
497+ Flexbox _ -> sk "spread" "justify-content" "space-between"
498+ _ -> pure []
499+ Opacity o -> sk ("opacity-" <> show o) "opacity" (show o)
500+ Pointer -> sk "pointer" "cursor" "pointer"
501+ Move { x, y } -> sk ("move-" <> show x <> "-" <> show y) "transform" ("translate(" <> show x <> "px, " <> show y <> "px)")
502+ Clip X -> sk "clip-x" "overflow-x" "hidden"
503+ Clip Y -> sk "clip-y" "overflow-y" "hidden"
504+ BorderWidth side l -> sk ("border-width-" <> renderKey side <> "-" <> show l) ("border-" <> render side <> "-width") (show l <> "px")
505+ BorderStyle s -> sk ("border-style-" <> renderKey s) "border-style" (render s)
506+ Round corner l -> sk ("round-" <> renderKey corner <> "-" <> show l) ("border-" <> render corner <> "-radius") (show l <> "px")
507+ Shadow s -> sk ("shadow-" <> renderKey s) "box-shadow" (render s)
508+ InnerShadow s -> sk ("inner-shadow-" <> renderKey s) "box-shadow" (render s <> " inset")
509+ FontColor c -> sk ("font-color-" <> renderKey c) "color" (render c)
510+ FontSize l -> sk ("font-size-" <> show l) "font-size" (show l <> "px")
511+ Font f -> sk ("font-" <> removeSpaces f) "font-family" f
512+ FontWeight w -> sk ("font-weight-" <> show w) "font-weight" (show w)
513+
514+removeSpaces :: String -> String
515+removeSpaces = String.replaceAll (String.Pattern " ") (String.Replacement "-")
516+
517+class Renderable x where
518+ render :: x -> String
519+ renderKey :: x -> String
520+
521+instance Renderable Length where
522+ render = case _ of
523+ Px px -> show px <> "px"
524+ Fit -> "fit-content"
525+ Fill -> "100%"
526+ Max px l -> "max(" <> show px <> "px," <> render l <> ")"
527+ Min px l -> "min(" <> show px <> "px," <> render l <> ")"
528+ renderKey = case _ of
529+ Px px -> show px
530+ Fit -> "fit-content"
531+ Fill -> "fill"
532+ Max px l -> "max-" <> show px <> "-" <> renderKey l
533+ Min px l -> "min-" <> show px <> "-" <> renderKey l
534+
535+newtype Color = Color { r :: Int, g :: Int, b :: Int, a :: Int }
536+
537+rgb255 :: Int -> Int -> Int -> Color
538+rgb255 r g b = Color { r, g, b, a: 100 }
539+
540+rgba255 :: Int -> Int -> Int -> Int -> Color
541+rgba255 r g b a = Color { r, g, b, a }
542+
543+rgb :: Number -> Number -> Number -> Color
544+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 }
545+
546+rgba :: Number -> Number -> Number -> Number -> Color
547+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) }
548+
549+instance Renderable Color where
550+ render (Color { r, g, b, a }) = "rgb(" <> show r <> "," <> show g <> "," <> show b <> "," <> show a <> "%)"
551+ renderKey (Color { r, g, b, a }) = show r <> "-" <> show g <> "-" <> show b <> "-" <> show a
552+
553+data Bones :: Type -> Type
554+data Bones msg
555+ = Column (Array (View msg))
556+ | Row (Array (View msg))
557+ | Stack (Array (View msg))
558+ | Wrapper (View msg)
559+ | Text String
560+ | Link String { newTab :: Boolean } (View msg)
561+ | Download String { filename :: Maybe String } (View msg)
562+ | Image String { description :: String }
563+ | TextInput { value :: String, onChange :: String -> msg }
564+ | None
565+
566+type Classes = Array String
567+
568+newtype Mutation = Mutation { extraSkin :: Classes }
569+
570+instance Semigroup Mutation where
571+ append (Mutation x) (Mutation y) = Mutation { extraSkin: x.extraSkin <> y.extraSkin }
572+
573+instance Monoid Mutation where
574+ mempty = Mutation { extraSkin: mempty }
575+
576+newtype SkinGrowth = SkinGrowth
577+ { meat :: Object { key :: String, value :: String }
578+ , hover :: Object { key :: String, value :: String }
579+ , down :: Object { key :: String, value :: String }
580+ }
581+
582+styleSkinGrowth :: SkinGrowth -> String
583+styleSkinGrowth (SkinGrowth o) =
584+ Object.foldMap (\className { key, value } -> "." <> className <> "{" <> key <> ":" <> value <> ";}") o.meat
585+ <> Object.foldMap (\className { key, value } -> "." <> className <> "{" <> key <> ":" <> value <> ";}") o.hover
586+ <> Object.foldMap (\className { key, value } -> "." <> className <> "{" <> key <> ":" <> value <> ";}") o.down
587+
588+instance Semigroup SkinGrowth where
589+ append (SkinGrowth x) (SkinGrowth y) = SkinGrowth $
590+ { meat: Object.union x.meat y.meat
591+ , hover: Object.union x.hover y.hover
592+ , down: Object.union x.down y.down
593+ }
594+
595+instance Monoid SkinGrowth where
596+ mempty = SkinGrowth mempty
597+
598+growSkin :: forall msg. (msg -> Effect Unit) -> Mutation -> View msg -> Writer SkinGrowth VNode
599+growSkin fire (Mutation mutation) ({ meat, hover, down, nerves } /\ bones) = do
600+ let
601+ wiredNerves = Array.foldMap (wireNerve fire) nerves
602+ alignCenter = [ Align X Center, Align Y Center ]
603+ widthFill = [ Width Fill, Height Fill ]
604+ skn ctx = do
605+ meatClasses <- ((_ <> mutation.extraSkin) <<< Array.concat) <$> traverse (skin ctx)
606+ ( meat
607+ <> case ctx of
608+ Span -> mempty
609+ Grid -> widthFill
610+ Flexbox _ -> widthFill
611+ Generic -> widthFill
612+ <> case ctx of
613+ Grid -> alignCenter
614+ Flexbox _ -> alignCenter
615+ Span -> mempty
616+ Generic -> alignCenter
617+ )
618+ let hoverClasses /\ (SkinGrowth hover') = runWriter $ traverse (skin ctx) hover
619+ _ <- traverseWithIndex
620+ ( \key val -> tell $ SkinGrowth $
621+ { meat: Object.empty
622+ , hover: Object.singleton (key <> "-hover:hover") val
623+ , down: Object.empty
624+ }
625+ )
626+ hover'.meat
627+ let downClasses /\ (SkinGrowth down') = runWriter $ traverse (skin ctx) down
628+ _ <- traverseWithIndex
629+ ( \key val -> tell $ SkinGrowth $
630+ { meat: Object.empty
631+ , hover: Object.empty
632+ , down: Object.singleton (key <> "-down:active") val
633+ }
634+ )
635+ down'.meat
636+
637+ pure $ meatClasses <> map (_ <> "-hover") (Array.concat hoverClasses) <> map (_ <> "-down") (Array.concat downClasses)
638+
639+ case bones of
640+ Text t -> (\c -> string "span" c wiredNerves t) <$> (skn Span)
641+ Wrapper x -> do
642+ classes <- (skn (Flexbox X) <> sk "display-flex" "display" "flex" <> sk "flex-direction-row" "flex-direction" "row")
643+ x' <- growSkin fire mempty x
644+ pure $ h "div" classes wiredNerves [ x' ]
645+ Stack children -> do
646+ classes <- (skn Grid <> sk "display-grid" "display" "grid")
647+ extraSkin <- sk "grid-row-1" "grid-row" "1" <> sk "grid-column-1" "grid-column" "1"
648+ children' <- (traverse (growSkin fire $ Mutation { extraSkin }) children)
649+ pure $ h "div" classes wiredNerves children'
650+
651+ Row children -> do
652+ classes <- (skn (Flexbox X) <> sk "display-flex" "display" "flex" <> sk "flex-direction-row" "flex-direction" "row")
653+ children' <- traverse (growSkin fire mempty) children
654+ pure $ h "div" classes wiredNerves children'
655+ Column children -> do
656+ classes <- (skn (Flexbox Y) <> sk "display-flex" "display" "flex" <> sk "flex-direction-column" "flex-direction" "column")
657+ children' <- traverse (growSkin fire mempty) children
658+ pure $ h "div" classes wiredNerves children'
659+ Link href { newTab } child -> do
660+ classes <- (skn (Flexbox X) <> sk "display-flex" "display" "flex" <> sk "flex-direction-row" "flex-direction" "row")
661+ child' <- growSkin fire mempty child
662+ pure $ hWith "a"
663+ { href
664+ , rel: "noopener noreferrer"
665+ , target: if newTab then "_blank" else "_self"
666+ }
667+ classes
668+ wiredNerves
669+ [ child' ]
670+
671+ Download href { filename } child -> do
672+ classes <- (skn (Flexbox X) <> sk "display-flex" "display" "flex" <> sk "flex-direction-row" "flex-direction" "row")
673+ child' <- growSkin fire mempty child
674+ pure $ hWith "a"
675+ { href
676+ , download: Maybe.fromMaybe "" filename
677+ }
678+ classes
679+ wiredNerves
680+ [ child' ]
681+ Image src { description } -> (\c -> hWith "img" { src, alt: description } c wiredNerves []) <$> (skn Generic)
682+ TextInput { value, onChange } -> do
683+ classes <- skn Generic
684+ let
685+ onInputNerve = WiredNerves $ Object.singleton "input" $ \ev ->
686+ case Event.currentTarget ev >>= HTMLInputElement.fromEventTarget of
687+ Nothing -> pure unit
688+ Just inputEl -> do
689+ val <- HTMLInputElement.value inputEl
690+ fire $ onChange val
691+ pure $ hWith "input" { value } classes (wiredNerves <> onInputNerve) []
692+ None -> pure $ h "div" mempty wiredNerves []
693+
694+grow :: forall msg. (msg -> Effect Unit) -> View msg -> { node :: VNode, style :: String }
695+grow fire v =
696+ let
697+ node /\ skinGrowth = runWriter (growSkin fire mempty v)
698+ in
699+ { node, style: styleSkinGrowth skinGrowth }
700+
src/ProjectM36.pursnew file+517
@@ -0,0 +1,517 @@
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 Effect.Aff (Aff, bracket, error, throwError)
69+import Effect.Aff.HTTP (Method(..), fetch)
70+import Effect.Aff.HTTP.Request as Request
71+import Effect.Aff.HTTP.Response (Response)
72+import Effect.Aff.HTTP.Response as Response
73+import Foreign (Foreign, unsafeFromForeign, unsafeToForeign)
74+import Foreign.Object (Object)
75+import Foreign.Object as Object
76+import Prim.Row as Row
77+import Prim.RowList as RowList
78+import Record as Record
79+import Simple.JSON (class WriteForeign)
80+import Unsafe.Coerce (unsafeCoerce)
81+
82+data Expr
83+ = Join Expr Expr
84+ | Union Expr Expr
85+ | Project (Set Attribute) Expr
86+ | Rename (Object Attribute) Expr
87+ | Difference Expr Expr
88+ | Group (Set Attribute) Attribute Expr
89+ | Ungroup Attribute Expr
90+ | RelationVariable RelVarName
91+ | Lit Json
92+
93+instance EncodeJson Expr where
94+ encodeJson = case _ of
95+ Lit l -> l
96+ Join x y -> encodeJson { join: [ x, y ] }
97+ Union x y -> encodeJson { union: [ x, y ] }
98+ Project proj expr -> encodeJson { proj: { proj: proj, expr: expr } }
99+ Rename mapping expr -> encodeJson { rename: { mapping: mapping, expr: expr } }
100+ Difference x y -> encodeJson { diff: [ x, y ] }
101+ Group attrs attr expr -> encodeJson { group: { attrs: attrs, attr: attr, expr: expr } }
102+ Ungroup attr expr -> encodeJson { ungroup: { attr: attr, expr: expr } }
103+ RelationVariable var -> encodeJson { var: encodeJson var }
104+
105+type RelVarName = String
106+type Attribute = String
107+
108+class RelVar :: forall k. k -> Constraint
109+class RelVar rel where
110+ relVar :: String
111+
112+class LiteralRelation :: Type -> Row Type -> Constraint
113+class LiteralRelation r fields | r -> fields where
114+ lit :: r -> Rel fields
115+
116+instance (RowList.RowToList fields fields', Relatable fields fields') => LiteralRelation (Array (Record fields)) fields where
117+ lit r = Rel $ Lit $ encodeJson { lit: { attrs: attributeTypes @fields @fields', vals: encodeRelation @fields @fields' <$> r } }
118+
119+else instance (LiteralRelation (Record fields) fields, Newtype r (Record fields)) => LiteralRelation r fields where
120+ lit = unwrap >>> lit
121+
122+rel :: forall @rel fields. Newtype rel (Record fields) => RelVar rel => Rel fields
123+rel = Rel $ RelationVariable (relVar @rel)
124+
125+newtype Rel (fields :: Row Type) = Rel Expr
126+
127+derive newtype instance EncodeJson (Rel fields)
128+
129+union :: forall fields. Rel fields -> Rel fields -> Rel fields
130+union (Rel x) (Rel y) = Rel $ Union x y
131+
132+difference :: forall fields. Rel fields -> Rel fields -> Rel fields
133+difference (Rel x) (Rel y) = Rel $ Difference x y
134+
135+join
136+ :: forall lhs rhs res lhs' rhs' res'
137+ . Union lhs rhs res
138+ => RowToList lhs lhs'
139+ => RowToList rhs rhs'
140+ => AssertNoConflict lhs' res'
141+ => AssertNoConflict rhs' res'
142+ => Nub res res'
143+ => Rel lhs
144+ -> Rel rhs
145+ -> Rel res'
146+join (Rel lhs) (Rel rhs) = Rel $ Join lhs rhs
147+
148+class AssertNoConflict :: forall k. RowList k -> Row k -> Constraint
149+class AssertNoConflict xs ys
150+
151+instance AssertNoConflict Nil xs
152+instance (AssertNoConflict ys xs, Row.Cons l y xs' xs) => AssertNoConflict (RowList.Cons l y ys) xs
153+
154+rename
155+ :: forall @rename rename' fields fields'
156+ . RowList.RowToList rename rename'
157+ => RenameRel rename' fields fields'
158+ => ReifyRename rename'
159+ => Rel fields
160+ -> Rel fields'
161+rename (Rel x) = Rel $ Rename (reifyRename @rename') x
162+
163+class ReifyRename :: RowList Symbol -> Constraint
164+class ReifyRename rename where
165+ reifyRename :: Object Attribute
166+
167+instance ReifyRename RowList.Nil where
168+ reifyRename = Object.empty
169+
170+instance (ReifyRename rest, IsSymbol from, IsSymbol to) => ReifyRename (RowList.Cons from to rest) where
171+ reifyRename = Object.insert (reflectSymbol @from Proxy) (reflectSymbol @to Proxy) (reifyRename @rest)
172+
173+class RenameRel :: forall k. RowList Symbol -> Row k -> Row k -> Constraint
174+class RenameRel rename fields fields' | rename fields -> fields'
175+
176+instance RenameRel RowList.Nil fields fields
177+instance
178+ ( Row.Cons from t fields' fields
179+ , Row.Cons to t fields' fields''
180+ ) =>
181+ RenameRel (RowList.Cons from to rest) fields fields''
182+
183+project
184+ :: forall @projection projection' fields fields'
185+ . ProjectRel projection' fields fields'
186+ => RowList.RowToList projection projection'
187+ => ReifyFields projection'
188+ => Rel fields
189+ -> Rel fields'
190+project (Rel x) = Rel $ Project (reifyFields @projection') x
191+
192+class ProjectRel :: forall k l. RowList k -> Row l -> Row l -> Constraint
193+class ProjectRel projection fields fields' | projection fields -> fields'
194+
195+instance ProjectRel RowList.Nil fields ()
196+instance
197+ ( ProjectRel rest fields fields''
198+ , Row.Cons field value f fields
199+ , Row.Cons field value fields'' fields'
200+ ) =>
201+ ProjectRel (RowList.Cons field v rest) fields fields'
202+
203+class ReifyFields :: forall k. RowList k -> Constraint
204+class ReifyFields row where
205+ reifyFields :: Set Attribute
206+
207+instance ReifyFields RowList.Nil where
208+ reifyFields = Set.empty
209+
210+instance (IsSymbol field, ReifyFields rest) => ReifyFields (RowList.Cons field v rest) where
211+ reifyFields = Set.insert (reflectSymbol @field Proxy) (reifyFields @rest)
212+
213+group
214+ :: forall @group (@field :: Symbol) group' groupped fields fields' fields''
215+ . RowList.RowToList group group'
216+ => GroupRel group' fields groupped
217+ => Row.Cons field (Array (Rel groupped)) fields'' fields'
218+ => DropFields group' fields fields''
219+ => ReifyFields group'
220+ => IsSymbol field
221+ => Rel fields
222+ -> Rel fields'
223+group (Rel x) = Rel $ Group (reifyFields @group') (reflectSymbol @field Proxy) x
224+
225+class GroupRel :: forall k l. RowList l -> Row k -> Row k -> Constraint
226+class GroupRel group fields groupped | group fields -> groupped
227+
228+instance GroupRel RowList.Nil fields ()
229+
230+instance
231+ ( GroupRel rest fields fields''
232+ , Row.Cons field t f fields
233+ , Row.Cons field t fields'' fields'
234+ ) =>
235+ GroupRel (RowList.Cons field u rest) fields fields'
236+
237+class DropFields :: forall l k. RowList l -> Row k -> Row k -> Constraint
238+class DropFields drop fields fields' | drop fields -> fields'
239+
240+instance DropFields RowList.Nil fields fields
241+
242+instance
243+ ( DropFields rest fields fields''
244+ , Row.Cons field t' fields' fields''
245+ ) =>
246+ DropFields (RowList.Cons field t rest) fields fields'
247+
248+ungroup
249+ :: forall (@field :: Symbol) fields fields' fields'' group group'
250+ . IsSymbol field
251+ => Row.Cons field (Array (Record group)) fields'' fields
252+ => Row.Union group fields'' fields'
253+ => RowList.RowToList group group'
254+ => AssertNoDuplicates group' fields''
255+ => Rel fields
256+ -> Rel fields'
257+ungroup (Rel x) = Rel $ Ungroup (reflectSymbol @field Proxy) x
258+
259+class AssertNoDuplicates :: forall k. RowList k -> Row k -> Constraint
260+class AssertNoDuplicates xs ys
261+
262+instance AssertNoDuplicates RowList.Nil ys
263+instance
264+ ( AssertNoDuplicates rest ys
265+ , Row.Lacks field ys
266+ ) =>
267+ AssertNoDuplicates (RowList.Cons field t rest) ys
268+
269+data AtomType
270+ = IntAtomType
271+ | IntegerAtomType
272+ | ScientificAtomType
273+ | DoubleAtomType
274+ | TextAtomType
275+ | DayAtomType
276+ | DateTimeAtomType
277+ | ByteStringAtomType
278+ | BoolAtomType
279+ | UUIDAtomType
280+ | RelationAtomType (Array (Attribute /\ AtomType))
281+
282+instance EncodeJson AtomType where
283+ encodeJson = case _ of
284+ IntAtomType -> Argonaut.fromString "int"
285+ IntegerAtomType -> Argonaut.fromString "integer"
286+ ScientificAtomType -> Argonaut.fromString "scientific"
287+ DoubleAtomType -> Argonaut.fromString "double"
288+ TextAtomType -> Argonaut.fromString "text"
289+ DayAtomType -> Argonaut.fromString "day"
290+ DateTimeAtomType -> Argonaut.fromString "datetime"
291+ ByteStringAtomType -> Argonaut.fromString "bytestring"
292+ BoolAtomType -> Argonaut.fromString "bool"
293+ UUIDAtomType -> Argonaut.fromString "uuid"
294+ RelationAtomType r -> encodeJson r
295+
296+-- instance DecodeJson AtomType where
297+-- decodeJson j =
298+-- ( decodeJson j >>= case _ of
299+-- "int" -> pure IntegerAtomType
300+-- "integer" -> pure IntegerAtomType
301+-- "scientific" -> pure ScientificAtomType
302+-- "double" -> pure DoubleAtomType
303+-- "text" -> pure TextAtomType
304+-- "day" -> pure DayAtomType
305+-- "datetime" -> pure DateTimeAtomType
306+-- "bytestring" -> pure ByteStringAtomType
307+-- "bool" -> pure BoolAtomType
308+-- "uuid" -> pure UUIDAtomType
309+-- _ -> Left $ TypeMismatch $ "Unknown atom type " <> stringify j
310+-- )
311+-- <|>
312+-- ( decodeRelation j
313+-- )
314+
315+instance WriteForeign AtomType where
316+ writeImpl = unsafeToForeign <<< encodeJson
317+
318+class Atomable :: Type -> Constraint
319+class Atomable a where
320+ atomType :: AtomType
321+ encodeAtom :: a -> Json
322+ decodeAtom :: Json -> Either JsonDecodeError a
323+
324+instance Atomable Int where
325+ atomType = IntAtomType
326+ encodeAtom = encodeJson
327+ decodeAtom = decodeJson
328+
329+instance Atomable Number where
330+ atomType = DoubleAtomType
331+ encodeAtom = encodeJson
332+ decodeAtom = decodeJson
333+
334+instance Atomable String where
335+ atomType = TextAtomType
336+ encodeAtom = encodeJson
337+ decodeAtom = decodeJson
338+
339+instance Atomable UUID where
340+ atomType = UUIDAtomType
341+ encodeAtom (UUID uuid) = encodeJson uuid
342+ decodeAtom = map UUID <<< decodeJson
343+
344+instance Atomable Boolean where
345+ atomType = BoolAtomType
346+ encodeAtom = encodeJson
347+ decodeAtom = decodeJson
348+
349+instance Atomable Date where
350+ atomType = DayAtomType
351+ encodeAtom date = encodeJson $ ISO $ DateTime date bottom
352+ decodeAtom = decodeJson >>> map (unwrapISO >>> date)
353+
354+instance Atomable DateTime where
355+ atomType = DateTimeAtomType
356+ encodeAtom = encodeJson <<< ISO
357+ decodeAtom = map unwrapISO <<< decodeJson
358+
359+instance Atomable ArrayBuffer where
360+ atomType = ByteStringAtomType
361+ encodeAtom = encodeBase64 >>> runBase64 >>> encodeJson
362+ decodeAtom j =
363+ map Base64.fromString (decodeJson j) >>= case _ of
364+ Just b -> pure $ decodeBase64 b
365+ Nothing -> Left $ TypeMismatch "Could not decode base64"
366+
367+instance
368+ ( RowList.RowToList fields fields'
369+ , Relatable fields fields'
370+ , BuildRelation fields fields'
371+ ) =>
372+ Atomable (Array (Record fields)) where
373+ atomType = RelationAtomType (attributeTypes @fields @fields')
374+ encodeAtom = map (encodeRelation @fields @fields') >>> encodeJson
375+ decodeAtom = decodeRelationJson >=> traverse (decodeRelationFromObject @fields @fields')
376+
377+class Relatable :: Row Type -> RowList Type -> Constraint
378+class Relatable fields fields' where
379+ attributeTypes :: Array (Attribute /\ AtomType)
380+ encodeRelation :: Record fields -> Array Json
381+
382+instance Relatable fields RowList.Nil where
383+ attributeTypes = []
384+ encodeRelation _ = []
385+
386+instance
387+ ( Atomable t
388+ , IsSymbol field
389+ , Relatable fields rest
390+ , Row.Cons field t tail fields
391+ ) =>
392+ Relatable fields (RowList.Cons field t rest) where
393+ attributeTypes = Array.snoc (attributeTypes @fields @rest) ((reflectSymbol @field Proxy) /\ (atomType @t))
394+ encodeRelation r = Array.snoc (encodeRelation @fields @rest r) (encodeAtom (Record.get (Proxy @field) r))
395+
396+decodeRelationJson :: Json -> Either JsonDecodeError (Array (Object Json))
397+decodeRelationJson = decodeJson >=> \o -> do
398+ attrs :: Array Attribute <- o .: "attrs"
399+ (map <<< map) (Object.fromFoldable <<< Array.zip attrs) $ o .: "vals"
400+
401+class BuildRelation :: Row Type -> RowList Type -> Constraint
402+class BuildRelation fields fields' | fields' -> fields where
403+ decodeRelationFromObject :: Object Json -> Either JsonDecodeError (Record fields)
404+
405+instance BuildRelation () RowList.Nil where
406+ decodeRelationFromObject _ = pure {}
407+
408+instance
409+ ( Row.Cons field r rest fields
410+ , BuildRelation rest rest'
411+ , IsSymbol field
412+ , Atomable r
413+ , Row.Lacks field rest
414+ ) =>
415+ BuildRelation fields (RowList.Cons field t rest') where
416+ decodeRelationFromObject o = do
417+ rest :: Record rest <- decodeRelationFromObject @rest @rest' o
418+ atom <- case Object.lookup (reflectSymbol @field Proxy) o of
419+ Just js -> decodeAtom js
420+ Nothing -> Left MissingValue
421+ pure $ Record.insert (Proxy @field) atom rest
422+
423+newtype Connection = Connection URL
424+
425+newtype Transaction a = Transaction (ReaderT { conn :: Connection, sess :: SessionId } Aff a)
426+
427+derive newtype instance Functor Transaction
428+derive newtype instance Apply Transaction
429+derive newtype instance Applicative Transaction
430+derive newtype instance Bind Transaction
431+derive newtype instance Monad Transaction
432+
433+newtype UUID = UUID String
434+
435+instance DecodeJson UUID where
436+ decodeJson = map UUID <$> decodeJson
437+
438+newtype SessionId = SessionId UUID
439+
440+sessionString :: SessionId -> String
441+sessionString (SessionId (UUID uuid)) = uuid
442+
443+withTransaction :: forall a. Connection -> Transaction a -> Aff a
444+withTransaction conn@(Connection c) (Transaction tr) = do
445+ bracket
446+ ( do
447+ resp <- fetch POST (c `addSegment` "transaction") {}
448+ Response.guardStatusOk resp
449+ uuid :: UUID <- json resp >>= \j -> case decodeJson j of
450+ Left _ -> throwError $ error "Could not decode transaction session UUID"
451+ Right sess -> pure sess
452+ pure $ SessionId uuid
453+ )
454+ ( \sess ->
455+ fetch DELETE (c `addSegment` "transaction" `addSegment` sessionString sess) {}
456+ >>= Response.guardStatusOk
457+ )
458+ ( \sess -> do
459+ a <- runReaderT tr { conn: conn, sess: sess }
460+ fetch PUT (c `addSegment` "transaction" `addSegment` sessionString sess) {}
461+ >>= Response.guardStatusOk
462+ pure a
463+ )
464+
465+json :: Response -> Aff Json
466+json resp = unsafeFromForeign <$> Response.json resp
467+
468+define
469+ :: forall @rel fields fields'
470+ . RowList.RowToList fields fields'
471+ => Newtype rel (Record fields)
472+ => Relatable fields fields'
473+ => RelVar rel
474+ => Transaction Unit
475+define = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do
476+ fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)
477+ { body: Request.json { define: { name: relVar @rel, attrs: Object.fromFoldable (attributeTypes @fields @fields') } } }
478+ >>= Response.guardStatusOk
479+ pure unit
480+
481+insert
482+ :: forall @rel fields
483+ . RelVar rel
484+ => Newtype rel (Record fields)
485+ => Rel fields
486+ -> Transaction Unit
487+insert (Rel r) = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do
488+ fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)
489+ { body: Request.json { insert: { name: relVar @rel, rel: jsonToForeign (encodeJson r) } } }
490+ >>= Response.guardStatusOk
491+ pure unit
492+
493+query
494+ :: forall fields fields'
495+ . RowList.RowToList fields fields'
496+ => BuildRelation fields fields'
497+ => Rel fields
498+ -> Transaction (Array (Record fields))
499+query (Rel r) = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do
500+ resp <- fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)
501+ { body: Request.json { query: jsonToForeign (encodeJson r) } }
502+ Response.guardStatusOk resp
503+ j <- json resp
504+ case decodeRelation @fields @fields' j of
505+ Right rec -> pure rec
506+ Left err -> throwError $ error $ show err
507+
508+decodeRelation
509+ :: forall @fields @fields'
510+ . BuildRelation fields fields'
511+ => Json
512+ -> Either JsonDecodeError (Array (Record fields))
513+decodeRelation j = decodeRelationJson j >>= traverse (decodeRelationFromObject @fields @fields')
514+
515+jsonToForeign :: Json -> Foreign
516+jsonToForeign = unsafeCoerce
517+
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+55
@@ -0,0 +1,55 @@
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+ , Middleware
14+ ) where
15+
16+data HttpMethod
17+
18+-- | The `req` can only ever be `Unit`
19+foreign import data GET :: Type -> Type -> HttpMethod
20+foreign import data POST :: Type -> Type -> HttpMethod
21+foreign import data PUT :: Type -> Type -> HttpMethod
22+foreign import data DELETE :: Type -> Type -> HttpMethod
23+foreign import data PATCH :: Type -> Type -> HttpMethod
24+
25+class MethodName :: HttpMethod -> Constraint
26+class MethodName method where
27+ methodName :: String
28+
29+instance MethodName (GET req resp) where
30+ methodName = "GET"
31+
32+instance MethodName (POST req resp) where
33+ methodName = "POST"
34+
35+instance MethodName (PUT req resp) where
36+ methodName = "PUT"
37+
38+instance MethodName (DELETE req resp) where
39+ methodName = "DELETE"
40+
41+instance MethodName (PATCH req resp) where
42+ methodName = "PATCH"
43+
44+data Slash :: forall k1 k2. k1 -> k2 -> Type
45+data Slash x y
46+
47+-- | Operator for separating path pieces when specisying APIs.
48+-- | `Symbol`s are treated as constant path pieces.
49+-- | `Record`s are treated as query parameters. `Array`s are lists, `Maybe`s are optional query parameters.
50+-- | Other types are captured path pieces.
51+infixr 1 type Slash as /
52+
53+data Headers headers r = Headers headers r
54+
55+data Middleware tag
src/PureStack/Server.pursnew file+410
@@ -0,0 +1,410 @@
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+ , class FromHeaders
24+ , fromHeaders
25+ , class FromHeader
26+ , fromHeader
27+ ) where
28+
29+import Prelude
30+import PureStack.Route
31+
32+import Bun.Request (Request)
33+import Bun.Request as Bun
34+import Bun.Request as Request
35+import Bun.Response as Bun.Response
36+import Control.Alternative (class Plus, empty)
37+import Control.Monad.Except (ExceptT, runExceptT)
38+import Data.Argonaut (class DecodeJson, class EncodeJson, Json, decodeJson, encodeJson)
39+import Data.Array as Array
40+import Data.Either (Either(..), either)
41+import Data.Int as Int
42+import Data.Map (Map)
43+import Data.Map as Map
44+import Data.Maybe (Maybe(..))
45+import Data.Number as Number
46+import Data.String as String
47+import Data.Symbol (class IsSymbol, reflectSymbol)
48+import Data.Traversable (traverse)
49+import Data.URL as URL
50+import Effect.Aff (Aff)
51+import Effect.Aff.Class (liftAff)
52+import Foreign.Object (Object)
53+import Foreign.Object as Object
54+import Prim.Row as Row
55+import Prim.RowList (class RowToList, RowList)
56+import Prim.RowList as RowList
57+import PureStack.Cookie (Cookie)
58+import PureStack.Cookie as Cookie
59+import Record as Record
60+import Record.Builder (Builder)
61+import Record.Builder as Builder
62+import Type.Proxy (Proxy(..))
63+
64+type Route =
65+ { path :: Array String
66+ , verb :: String
67+ , query :: Map String (Array String)
68+ , originalRequest :: Bun.Request
69+ }
70+
71+routeFromRequest :: Request -> Route
72+routeFromRequest req =
73+ let
74+ url = URL.fromString $ Request.url req
75+ in
76+ { verb: Request.method req
77+ , path: case url of
78+ Nothing -> []
79+ Just u -> case URL.path u of
80+ URL.PathEmpty -> []
81+ URL.PathAbsolute p -> p
82+ URL.PathRelative p -> p
83+ , query: case url of
84+ Nothing -> Map.empty
85+ Just u -> URL.query u
86+ , originalRequest: req
87+ }
88+
89+type Server a = ExceptT Response Aff a
90+
91+newtype Nt m = Nt (forall x. m x -> Server x)
92+
93+class ServeRoute :: forall k. k -> Type -> Row Type -> (Type -> Type) -> Constraint
94+class ServeRoute route handler middlewares m | route middlewares -> handler, handler -> m where
95+ serveRoute :: Route -> Maybe (Nt m -> handler -> Record middlewares -> Request -> Server Response)
96+
97+instance (ServeRoute rest handler middlewares m, IsSymbol path) => ServeRoute (path / rest) handler middlewares m where
98+ serveRoute route@{ path } = do
99+ { head: h, tail } <- Array.uncons path
100+ assert $ h == (reflectSymbol @path Proxy)
101+ serveRoute @rest route { path = tail }
102+
103+else instance
104+ ( ServeRoute rest handler middlewares m
105+ , ServeQuery row list
106+ , RowToList row list
107+ ) =>
108+ ServeRoute (Record row / rest) (Record row -> handler) middlewares m where
109+ serveRoute route@{ query } = do
110+ builder <- serveQuery @row @list query
111+ serveRoute @rest route <#> (\f nt handler req -> f nt (handler $ Builder.buildFromScratch builder) req)
112+
113+else instance
114+ ( ServeRoute rest handler middlewares m
115+ , IsSymbol field
116+ , Row.Cons field (Bun.Request -> m x) tail middlewares
117+ ) =>
118+ ServeRoute (Middleware field / rest) (x -> handler) middlewares m where
119+ serveRoute route@{ originalRequest } = do
120+ serveRoute @rest route <#>
121+ ( \f nt@(Nt ntf) handler middlewares req -> do
122+ x <- ntf $ Record.get (Proxy @field) middlewares originalRequest
123+ f nt (handler x) middlewares req
124+ )
125+
126+else instance (ServeRoute rest handler middlewares m, ParsePathPiece t) => ServeRoute (t / rest) (t -> handler) middlewares m where
127+ serveRoute route@{ path } = do
128+ { head: h, tail } <- Array.uncons path
129+ t <- parsePathPiece @t h
130+ serveRoute @rest route { path = tail } <#> (\f nt handler mws req -> f nt (handler t) mws req)
131+
132+else instance MethodName (meth Unit Unit) => ServeRoute (meth Unit Unit) (m Unit) middlewares m where
133+ serveRoute { path, verb } = do
134+ assert $ verb == methodName @(meth Unit Unit)
135+ assert $ path == []
136+ pure $ \(Nt nt) handler _middlewares _req -> do
137+ nt handler
138+ pure $ ok
139+else instance (ToResponse resp, MethodName (meth Unit resp)) => ServeRoute (meth Unit resp) (m resp) middlewares m where
140+ serveRoute { path, verb } = do
141+ assert $ verb == methodName @(meth Unit resp)
142+ assert $ path == []
143+ pure $ \(Nt nt) handler _middlewares _req -> do
144+ resp <- nt handler
145+ pure $ toResponse resp
146+else instance (FromRequest req, MethodName (meth resp Unit)) => ServeRoute (meth resp Unit) (req -> m Unit) middlewares m where
147+ serveRoute { path, verb } = do
148+ assert $ verb == methodName @(meth resp Unit)
149+ assert $ path == []
150+ pure $ \(Nt nt) handler _middlewares req -> do
151+ liftAff (fromRequest req) >>= case _ of
152+ Nothing -> pure $ badRequest
153+ Just r -> do
154+ nt $ handler r
155+ pure $ ok
156+else instance (FromRequest req, ToResponse resp, MethodName (meth req resp)) => ServeRoute (meth req resp) (req -> m resp) middlewares m where
157+ serveRoute { path, verb } = do
158+ assert $ verb == methodName @(meth req resp)
159+ assert $ path == []
160+ pure $ \(Nt nt) handler _middlewares req -> do
161+ liftAff (fromRequest req) >>= case _ of
162+ Nothing -> pure $ badRequest
163+ Just r -> do
164+ resp <- nt $ handler r
165+ pure $ toResponse resp
166+
167+else instance
168+ ( ServeAPI routes list handlers middlewares m
169+ , RowToList routes list
170+ ) =>
171+ ServeRoute routes (Record handlers) middlewares m where
172+ serveRoute route = pure $ \nt handlers middlewares req ->
173+ serveAPI @routes @list nt handlers middlewares route req
174+
175+class ServeQuery :: Row Type -> RowList Type -> Constraint
176+class ServeQuery row list | list -> row where
177+ serveQuery :: Map String (Array String) -> Maybe (Builder (Record ()) (Record row))
178+
179+instance ServeQuery () RowList.Nil where
180+ serveQuery _ = Just $ identity
181+
182+instance
183+ ( ParsePathPiece t
184+ , ServeQuery tail rest
185+ , IsSymbol field
186+ , Row.Cons field (Array t) tail row
187+ , Row.Lacks field tail
188+ ) =>
189+ ServeQuery row (RowList.Cons field (Array t) rest) where
190+ serveQuery m = do
191+ r <- serveQuery @tail @rest m
192+ case Map.lookup (reflectSymbol @field Proxy) m of
193+ Nothing -> pure $ Builder.insert (Proxy @field) [] <<< r
194+ Just a -> do
195+ v <- parsePathPiece @t `traverse` a
196+ pure $ Builder.insert (Proxy @field) v <<< r
197+
198+else instance
199+ ( ParsePathPiece t
200+ , ServeQuery tail rest
201+ , IsSymbol field
202+ , Row.Cons field (Maybe t) tail row
203+ , Row.Lacks field tail
204+ ) =>
205+ ServeQuery row (RowList.Cons field (Maybe t) rest) where
206+ serveQuery m = do
207+ r <- serveQuery @tail @rest m
208+ case Map.lookup (reflectSymbol @field Proxy) m of
209+ Nothing -> pure $ Builder.insert (Proxy @field) Nothing <<< r
210+ Just a -> do
211+ { head, tail } <- Array.uncons a
212+ assert $ tail == []
213+ v <- parsePathPiece @t head
214+ pure $ Builder.insert (Proxy @field) (Just v) <<< r
215+
216+else instance
217+ ( ParsePathPiece t
218+ , ServeQuery tail rest
219+ , IsSymbol field
220+ , Row.Cons field t tail row
221+ , Row.Lacks field tail
222+ ) =>
223+ ServeQuery row (RowList.Cons field t rest) where
224+ serveQuery m = do
225+ { head, tail } <- Map.lookup (reflectSymbol @field Proxy) m >>= Array.uncons
226+ assert $ tail == []
227+ v <- parsePathPiece @t head
228+ r <- serveQuery @tail @rest m
229+ pure $ Builder.insert (Proxy @field) v <<< r
230+
231+data ResponseBody
232+ = JsonResponseBody Json
233+ | EmptyResponseBody
234+ | StringResponseBody String
235+
236+newtype Response = Response { body :: ResponseBody, status :: Int, statusText :: String, headers :: Object String }
237+
238+class ToResponse r where
239+ toResponse :: r -> Response
240+
241+instance EncodeJson (Record row) => ToResponse (Record row) where
242+ toResponse rec = Response { body: JsonResponseBody $ encodeJson rec, status: 200, statusText: "OK", headers: Object.empty }
243+
244+instance ToResponse Response where
245+ toResponse resp = resp
246+
247+class FromRequest r where
248+ fromRequest :: Request -> Aff (Maybe r)
249+
250+instance DecodeJson (Record row) => FromRequest (Record row) where
251+ fromRequest req = Request.json req <#> \j -> case decodeJson j of
252+ Right r -> Just r
253+ Left _ -> Nothing
254+
255+instance FromRequest Request where
256+ fromRequest req = pure $ Just req
257+
258+instance FromRequest Unit where
259+ fromRequest _ = pure $ Just unit
260+
261+instance
262+ ( FromRequest req
263+ , FromHeader header
264+ ) =>
265+ FromRequest (Headers (Object header) req) where
266+ fromRequest req = do
267+ r <- fromRequest req
268+ pure $ do
269+ headers <- traverse fromHeader (Request.headers req)
270+ r' <- r
271+ pure $ Headers headers r'
272+
273+instance
274+ ( RowToList headers headersList
275+ , FromRequest req
276+ , FromHeaders headers headersList
277+ ) =>
278+ FromRequest (Headers (Record headers) req) where
279+ fromRequest req = do
280+ r <- fromRequest req
281+ pure $ do
282+ headers <- fromHeaders @headers @headersList (Request.headers req)
283+ r' <- r
284+ pure $ Headers (Builder.buildFromScratch headers) r'
285+
286+class FromHeader t where
287+ fromHeader :: String -> Maybe t
288+
289+instance FromHeader Cookie where
290+ fromHeader = Cookie.parse >>> case _ of
291+ Left _ -> Nothing
292+ Right x -> Just x
293+
294+instance FromHeader String where
295+ fromHeader = Just
296+
297+instance FromHeader Int where
298+ fromHeader = Int.fromString
299+
300+class FromHeaders :: Row Type -> RowList Type -> Constraint
301+class FromHeaders row list | list -> row where
302+ fromHeaders :: Object String -> Maybe (Builder {} (Record row))
303+
304+instance FromHeaders () RowList.Nil where
305+ fromHeaders _ = Just $ identity
306+
307+instance
308+ ( FromHeader t
309+ , IsSymbol field
310+ , FromHeaders tail rest
311+ , Row.Cons field (Maybe t) tail row
312+ , Row.Lacks field tail
313+ ) =>
314+ FromHeaders row (RowList.Cons field (Maybe t) rest) where
315+ fromHeaders headers = do
316+ r <- fromHeaders @tail @rest headers
317+ case Object.lookup (reflectSymbol @field Proxy) headers of
318+ Nothing -> pure $ Builder.insert (Proxy @field) Nothing <<< r
319+ Just t -> do
320+ v <- fromHeader t
321+ pure $ Builder.insert (Proxy @field) (Just v) <<< r
322+
323+else instance
324+ ( FromHeader t
325+ , IsSymbol field
326+ , FromHeaders tail rest
327+ , Row.Cons field t tail row
328+ , Row.Lacks field tail
329+ ) =>
330+ FromHeaders row (RowList.Cons field t rest) where
331+ fromHeaders headers = do
332+ t <- Object.lookup (reflectSymbol @field Proxy) headers >>= fromHeader
333+ r <- fromHeaders @tail @rest headers
334+ pure $ Builder.insert (Proxy @field) t <<< r
335+
336+class ParsePathPiece t where
337+ parsePathPiece :: String -> Maybe t
338+
339+instance ParsePathPiece String where
340+ parsePathPiece = Just
341+
342+instance ParsePathPiece Int where
343+ parsePathPiece = Int.fromString
344+
345+instance ParsePathPiece Number where
346+ parsePathPiece = Number.fromString
347+
348+instance ParsePathPiece Boolean where
349+ parsePathPiece s = case String.toLower s of
350+ "true" -> Just true
351+ "1" -> Just true
352+ "false" -> Just false
353+ "0" -> Just false
354+ _ -> Nothing
355+
356+assert :: forall m. Applicative m => Plus m => Boolean -> m Unit
357+assert true = pure unit
358+assert false = empty
359+
360+class ServeAPI :: Row Type -> RowList Type -> Row Type -> Row Type -> (Type -> Type) -> Constraint
361+class ServeAPI row list handlers middlewares m | row -> handlers, handlers -> m where
362+ serveAPI :: Nt m -> Record handlers -> Record middlewares -> Route -> Request -> Server Response
363+
364+instance ServeAPI row RowList.Nil () middlewares m where
365+ serveAPI _ _ _ _ _ = pure notFound
366+
367+instance
368+ ( ServeRoute t handler middlewares m
369+ , Row.Cons field t tail row
370+ , ServeAPI row rest restHandlers middlewares m
371+ , IsSymbol field
372+ , Row.Cons field handler restHandlers handlers
373+ , Row.Lacks field restHandlers
374+ ) =>
375+ ServeAPI row (RowList.Cons field t rest) handlers middlewares m where
376+ serveAPI nt handlers middlewares route req =
377+ case serveRoute @t route of
378+ Nothing -> serveAPI @row @rest @restHandlers @middlewares nt (Record.delete (Proxy @field) handlers) middlewares route req
379+ Just f -> f nt (Record.get (Proxy @field) handlers) middlewares req
380+
381+notFound :: Response
382+notFound = Response { body: EmptyResponseBody, status: 404, statusText: "Not Found", headers: Object.empty }
383+
384+internalServerError :: Response
385+internalServerError = Response { body: EmptyResponseBody, status: 500, statusText: "Internal Server Error", headers: Object.empty }
386+
387+badRequest :: Response
388+badRequest = Response { body: EmptyResponseBody, status: 400, statusText: "Bad Request", headers: Object.empty }
389+
390+ok :: Response
391+ok = Response { body: EmptyResponseBody, status: 200, statusText: "OK", headers: Object.empty }
392+
393+-- | The first argument is used to run an arbitrary monad in handlers. To use the 'Server' monad
394+-- | instead you can just pass `identity` as the first argument.
395+run
396+ :: forall @row list handlers m middlewares
397+ . RowToList row list
398+ => ServeAPI row list handlers middlewares m
399+ => (forall x. m x -> Server x)
400+ -> { handlers :: Record handlers, middlewares :: Record middlewares }
401+ -> Request
402+ -> Aff Bun.Response.Response
403+run nt { handlers, middlewares } req = do
404+ Response { body, headers, status, statusText } <-
405+ map (either identity identity) $ runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers middlewares (routeFromRequest req) req
406+ let opts = { headers, status, statusText }
407+ pure $ case body of
408+ EmptyResponseBody -> Bun.Response.string "" opts
409+ JsonResponseBody json -> Bun.Response.json json opts
410+ 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