git.iko.soy/purestack-dev/purescript-purestack-server
on f19863a help sign in
599c6d5
swap
0 ahead, 9 behind
.gitignoredeleted−11
since splitsnapshots
unifiedsplit
@@ -1,11 +0,0 @@
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.dhalldeleted−5
@@ -1,5 +0,0 @@
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.dhalldeleted−34
@@ -1,34 +0,0 @@
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.jsdeleted−15
@@ -1,15 +0,0 @@
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.pursdeleted−28
@@ -1,28 +0,0 @@
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.jsdeleted−35
@@ -1,35 +0,0 @@
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.pursdeleted−18
@@ -1,18 +0,0 @@
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.jsdeleted−9
@@ -1,9 +0,0 @@
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.pursdeleted−15
@@ -1,15 +0,0 @@
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.pursdeleted−37
@@ -1,37 +0,0 @@
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.pursdeleted−57
@@ -1,57 +0,0 @@
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.pursdeleted−65
@@ -1,65 +0,0 @@
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.pursdeleted−62
@@ -1,62 +0,0 @@
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.pursdeleted−128
@@ -1,128 +0,0 @@
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.pursdeleted−189
@@ -1,189 +0,0 @@
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.pursdeleted−55
@@ -1,55 +0,0 @@
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.pursdeleted−410
@@ -1,410 +0,0 @@
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.pursdeleted−11
@@ -1,11 +0,0 @@
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."