git.iko.soy/purestack-dev/purescript-purestack-server
on master help sign in
swap
599c6d59 ahead, 0 behind
.gitignorenew file+11
since splitsnapshots
unifiedsplit
@@ -0,0 +1,11 @@
1+/bower_components/
2+/node_modules/
3+/.pulp-cache/
4+/output/
5+/generated-docs/
6+/.psc-package/
7+/.psc*
8+/.purs*
9+/.psa*
10+/.spago
11+index.js
packages.dhallnew file+5
@@ -0,0 +1,5 @@
1+let upstream =
2+ https://github.com/purescript/package-sets/releases/download/psc-0.15.15-20250523/packages.dhall
3+ sha256:1274f34a6328069aabf8a149e395c414d80999a73073330c436ba0739615c536
4+
5+in upstream
spago.dhallnew file+34
@@ -0,0 +1,34 @@
1+{ name = "my-project"
2+, dependencies =
3+ [ "aff"
4+ , "aff-promise"
5+ , "argonaut"
6+ , "arrays"
7+ , "console"
8+ , "control"
9+ , "datetime"
10+ , "effect"
11+ , "either"
12+ , "foldable-traversable"
13+ , "foreign-object"
14+ , "formatters"
15+ , "integers"
16+ , "lists"
17+ , "maybe"
18+ , "now"
19+ , "numbers"
20+ , "ordered-collections"
21+ , "parsing"
22+ , "prelude"
23+ , "profunctor-lenses"
24+ , "record"
25+ , "run"
26+ , "strings"
27+ , "transformers"
28+ , "tuples"
29+ , "typelevel-prelude"
30+ , "url-immutable"
31+ ]
32+, packages = ./packages.dhall
33+, sources = [ "src/**/*.purs", "test/**/*.purs" ]
34+}
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/Main.pursnew file+37
@@ -0,0 +1,37 @@
1+module Main where
2+
3+import Prelude
4+
5+import Bun.Server as Bun
6+import Data.Maybe (Maybe)
7+import Effect (Effect)
8+import Effect.Aff (Aff)
9+import Effect.Console (log)
10+import PureStack.Route (type (/), GET, Headers(..), Middleware, POST)
11+import PureStack.Route as Router
12+import PureStack.Server as Server
13+import Run (AFF, Run(..), runBaseAff)
14+import Type.Row (type (+))
15+
16+type Foo = { a :: String, b :: Maybe Int, c :: Array Number }
17+
18+type API =
19+ ( foo :: "foo" / "bar" / Foo / GET Unit { a :: Int, b :: Number, c :: Foo }
20+ , bar :: "foo" / Middleware "auth" / "qux" / POST (Headers { foo :: String } Unit) { a :: Int, s :: String }
21+ , deep ::
22+ "deep" /
23+ ( something :: "something" / GET Unit { a :: String }
24+ )
25+ )
26+
27+main :: Effect Unit
28+main = do
29+ log "🍝"
30+ Bun.serve $ Server.run @API identity
31+ { handlers:
32+ { foo: \x -> pure { a: 1, b: 1.0, c: x }
33+ , bar: \i (Headers x _) -> pure { a: 8, s: x.foo }
34+ , deep: { something: pure { a: "something" } }
35+ }
36+ , middlewares: { auth: \req -> pure 1 }
37+ }
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
test/Main.pursnew file+11
@@ -0,0 +1,11 @@
1+module Test.Main where
2+
3+import Prelude
4+
5+import Effect (Effect)
6+import Effect.Class.Console (log)
7+
8+main :: Effect Unit
9+main = do
10+ log "🍝"
11+ log "You should add some tests."