2a5d0f5..master · purestack-dev/purescript-purestack-server

git.iko.soy/purestack-dev/purescript-purestack-server

13 files changed+790−68

unifiedsplit

spago.dhall+10 src/Bun/Request.js+4 src/Bun/Request.purs+4 src/Bun/Response.js+23 src/Bun/Response.purs+9−3 src/Main.purs+13−5 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+31−10 src/PureStack/Server.purs+195−50

spago.dhall+10

@@ -6,14 +6,24 @@

66 , "arrays"

77 , "console"

88 , "control"

9+ , "datetime"

910 , "effect"

1011 , "either"

1112 , "foldable-traversable"

13+ , "foreign-object"

14+ , "formatters"

15+ , "integers"

16+ , "lists"

1217 , "maybe"

18+ , "now"

19+ , "numbers"

1320 , "ordered-collections"

21+ , "parsing"

1422 , "prelude"

23+ , "profunctor-lenses"

1524 , "record"

1625 , "run"

26+ , "strings"

1727 , "transformers"

1828 , "tuples"

1929 , "typelevel-prelude"

src/Bun/Request.js+4

@@ -9,3 +9,7 @@ export function method(req) {

99export function url(req) {

1010 return req.url

1111}

12+

13+export function headers(req) {

14+ return Object.fromEntries(req.headers.entries());

15+}

src/Bun/Request.purs+4

@@ -3,6 +3,7 @@ module Bun.Request

33 , method

44 , url

55 , json

6+ , headers

67 ) where

89import Prelude

@@ -11,6 +12,7 @@ import Control.Promise (Promise)

1112import Control.Promise as Promise

1213import Data.Argonaut (Json)

1314import Effect.Aff (Aff)

15+import Foreign.Object (Object)

1416

1517foreign import data Request :: Type

1618

@@ -22,3 +24,5 @@ json = jsonPromise >>> Promise.toAff

2224foreign import method :: Request -> String

2325

2426foreign import url :: Request -> String

27+

28+foreign import headers :: Request -> Object String

src/Bun/Response.js+23

@@ -10,3 +10,26 @@ export function string(s) {

1010 return new Response(s, options)

1111 }

1212}

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.purs+9−3

@@ -1,12 +1,18 @@

11module Bun.Response where

33import Data.Argonaut (Json)

4−import Data.Tuple.Nested (type (/\))

5−import Effect (Effect)

4+import Foreign.Object (Object)

76foreign import data Response :: Type

7+foreign import data ReadableStream :: Type

9−type Options = { status :: Int, statusText :: String, headers :: Array (String /\ String) }

9+type Options = { status :: Int, statusText :: String, headers :: Object String }

1010

1111foreign import json :: Json -> Options -> Response

1212foreign 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/Main.purs+13−5

@@ -7,7 +7,7 @@ import Data.Maybe (Maybe)

77import Effect (Effect)

88import Effect.Aff (Aff)

99import Effect.Console (log)

10−import PureStack.Route (type (/), GET, POST)

10+import PureStack.Route (type (/), GET, Headers(..), Middleware, POST)

1111import PureStack.Route as Router

1212import PureStack.Server as Server

1313import Run (AFF, Run(..), runBaseAff)

@@ -16,14 +16,22 @@ import Type.Row (type (+))

1616type Foo = { a :: String, b :: Maybe Int, c :: Array Number }

1717

1818type API =

19− ( foo :: "foo" / "bar" / Foo / GET { a :: Int, b :: Number, c :: Foo }

20− , bar :: "foo" / "qux" / POST Unit { a :: Int }

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+ )

2125 )

2226

2327main :: Effect Unit

2428main = do

2529 log "🍝"

2630 Bun.serve $ Server.run @API identity

27− { foo: \x -> pure { a: 1, b: 1.0, c: x }

28− , bar: pure { a: 8 }

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 }

2937 }

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

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

8+import Prelude

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.purs+31−10

@@ -1,27 +1,45 @@

11module PureStack.Route

22 ( type (/)

33 , Slash

4+ , HttpMethod

5+ , class MethodName

6+ , methodName

47 , GET

58 , POST

69 , PUT

710 , DELETE

811 , PATCH

12+ , Headers(..)

13+ , Middleware

914 ) where

1015

11−data GET :: Type -> Type

12−data GET resp

16+data HttpMethod

1317

14−data POST :: Type -> Type -> Type

15−data POST req resp

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

1624

17−data PUT :: Type -> Type -> Type

18−data PUT req resp

25+class MethodName :: HttpMethod -> Constraint

26+class MethodName method where

27+ methodName :: String

1928

20−data DELETE :: Type -> Type -> Type

21−data DELETE req resp

29+instance MethodName (GET req resp) where

30+ methodName = "GET"

2231

23−data PATCH :: Type -> Type -> Type

24−data PATCH req resp

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"

2543

2644data Slash :: forall k1 k2. k1 -> k2 -> Type

2745data Slash x y

@@ -32,3 +50,6 @@ data Slash x y

3250-- | Other types are captured path pieces.

3351infixr 1 type Slash as /

3452

53+data Headers headers r = Headers headers r

54+

55+data Middleware tag

src/PureStack/Server.purs+195−50

@@ -1,5 +1,7 @@

11module PureStack.Server

22 ( Server

3+ , Response(..)

4+ , ResponseBody(..)

35 , class ToResponse

46 , toResponse

57 , class FromRequest

@@ -18,39 +20,53 @@ module PureStack.Server

1820 , serveQuery

1921 , class ParsePathPiece

2022 , parsePathPiece

23+ , class FromHeaders

24+ , fromHeaders

25+ , class FromHeader

26+ , fromHeader

2127 ) where

2228

2329import Prelude

2430import PureStack.Route

2531

2632import Bun.Request (Request)

33+import Bun.Request as Bun

2734import Bun.Request as Request

28−import Bun.Response (Response)

29−import Bun.Response as Response

35+import Bun.Response as Bun.Response

3036import Control.Alternative (class Plus, empty)

3137import Control.Monad.Except (ExceptT, runExceptT)

32−import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson)

38+import Data.Argonaut (class DecodeJson, class EncodeJson, Json, decodeJson, encodeJson)

3339import Data.Array as Array

34−import Data.Either (Either(..))

40+import Data.Either (Either(..), either)

3541import Data.Int as Int

3642import Data.Map (Map)

3743import Data.Map as Map

3844import Data.Maybe (Maybe(..))

3945import Data.Number as Number

46+import Data.String as String

4047import Data.Symbol (class IsSymbol, reflectSymbol)

4148import Data.Traversable (traverse)

4249import Data.URL as URL

4350import Effect.Aff (Aff)

4451import Effect.Aff.Class (liftAff)

52+import Foreign.Object (Object)

53+import Foreign.Object as Object

4554import Prim.Row as Row

4655import Prim.RowList (class RowToList, RowList)

4756import Prim.RowList as RowList

57+import PureStack.Cookie (Cookie)

58+import PureStack.Cookie as Cookie

4859import Record as Record

4960import Record.Builder (Builder)

5061import Record.Builder as Builder

5162import Type.Proxy (Proxy(..))

5263

53−type Route = { path :: Array String, verb :: String, query :: Map String (Array String) }

64+type Route =

65+ { path :: Array String

66+ , verb :: String

67+ , query :: Map String (Array String)

68+ , originalRequest :: Bun.Request

69+ }

5470

5571routeFromRequest :: Request -> Route

5672routeFromRequest req =

@@ -67,65 +83,95 @@ routeFromRequest req =

6783 , query: case url of

6884 Nothing -> Map.empty

6985 Just u -> URL.query u

86+ , originalRequest: req

7087 }

7188

7289type Server a = ExceptT Response Aff a

7390

7491newtype Nt m = Nt (forall x. m x -> Server x)

7592

76−class ServeRoute :: forall k. k -> Type -> (Type -> Type) -> Constraint

77−class ServeRoute route handler m | route -> handler, handler -> m where

78− serveRoute :: Route -> Maybe (Nt m -> handler -> Request -> Server Response)

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)

7996

80−instance (ServeRoute rest handler m, IsSymbol path) => ServeRoute (path / rest) handler m where

97+instance (ServeRoute rest handler middlewares m, IsSymbol path) => ServeRoute (path / rest) handler middlewares m where

8198 serveRoute route@{ path } = do

8299 { head: h, tail } <- Array.uncons path

83100 assert $ h == (reflectSymbol @path Proxy)

84101 serveRoute @rest route { path = tail }

85102

86103else instance

87− ( ServeRoute rest handler m

104+ ( ServeRoute rest handler middlewares m

88105 , ServeQuery row list

89106 , RowToList row list

90107 ) =>

91− ServeRoute (Record row / rest) (Record row -> handler) m where

108+ ServeRoute (Record row / rest) (Record row -> handler) middlewares m where

92109 serveRoute route@{ query } = do

93110 builder <- serveQuery @row @list query

94111 serveRoute @rest route <#> (\f nt handler req -> f nt (handler $ Builder.buildFromScratch builder) req)

95112

96−else instance (ServeRoute rest handler m, ParsePathPiece t) => ServeRoute (t / rest) (t -> handler) m where

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

97127 serveRoute route@{ path } = do

98128 { head: h, tail } <- Array.uncons path

99129 t <- parsePathPiece @t h

100− serveRoute @rest route { path = tail } <#> (\f nt handler req -> f nt (handler t) req)

130+ serveRoute @rest route { path = tail } <#> (\f nt handler mws req -> f nt (handler t) mws req)

101131

102−else instance ToResponse resp => ServeRoute (GET resp) (m resp) m where

132+else instance MethodName (meth Unit Unit) => ServeRoute (meth Unit Unit) (m Unit) middlewares m where

103133 serveRoute { path, verb } = do

104− assert $ verb == "GET"

134+ assert $ verb == methodName @(meth Unit Unit)

105135 assert $ path == []

106− pure $ \(Nt nt) handler _req -> do

107− resp <- nt handler

108− pure $ toResponse resp

109−

110−else instance (ToResponse resp) => ServeRoute (POST Unit resp) (m resp) m where

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

111140 serveRoute { path, verb } = do

141+ assert $ verb == methodName @(meth Unit resp)

112142 assert $ path == []

113− assert $ verb == "POST"

114− pure $ \(Nt nt) handler _req -> do

143+ pure $ \(Nt nt) handler _middlewares _req -> do

115144 resp <- nt handler

116145 pure $ toResponse resp

117−

118−else instance (FromRequest req, ToResponse resp) => ServeRoute (POST req resp) (req -> m resp) m where

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

119157 serveRoute { path, verb } = do

158+ assert $ verb == methodName @(meth req resp)

120159 assert $ path == []

121− assert $ verb == "POST"

122− pure $ \(Nt nt) handler req -> do

160+ pure $ \(Nt nt) handler _middlewares req -> do

123161 liftAff (fromRequest req) >>= case _ of

124162 Nothing -> pure $ badRequest

125163 Just r -> do

126164 resp <- nt $ handler r

127165 pure $ toResponse resp

128166

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+

129175class ServeQuery :: Row Type -> RowList Type -> Constraint

130176class ServeQuery row list | list -> row where

131177 serveQuery :: Map String (Array String) -> Maybe (Builder (Record ()) (Record row))

@@ -182,11 +228,18 @@ else instance

182228 r <- serveQuery @tail @rest m

183229 pure $ Builder.insert (Proxy @field) v <<< r

184230

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+

185238class ToResponse r where

186239 toResponse :: r -> Response

187240

188241instance EncodeJson (Record row) => ToResponse (Record row) where

189− toResponse rec = Response.json (encodeJson rec) { status: 200, statusText: "OK", headers: [] }

242+ toResponse rec = Response { body: JsonResponseBody $ encodeJson rec, status: 200, statusText: "OK", headers: Object.empty }

190243

191244instance ToResponse Response where

192245 toResponse resp = resp

@@ -202,6 +255,84 @@ instance DecodeJson (Record row) => FromRequest (Record row) where

202255instance FromRequest Request where

203256 fromRequest req = pure $ Just req

204257

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+

205336class ParsePathPiece t where

206337 parsePathPiece :: String -> Maybe t

207338

@@ -214,52 +345,66 @@ instance ParsePathPiece Int where

214345instance ParsePathPiece Number where

215346 parsePathPiece = Number.fromString

216347

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+

217356assert :: forall m. Applicative m => Plus m => Boolean -> m Unit

218357assert true = pure unit

219358assert false = empty

220359

221−class ServeAPI :: Row Type -> RowList Type -> Row Type -> (Type -> Type) -> Constraint

222−class ServeAPI row list handlers m | row -> handlers, handlers -> m where

223− serveAPI :: Nt m -> Record handlers -> Route -> Request -> Server Response

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

224363

225−instance ServeAPI row RowList.Nil () m where

226− serveAPI _ _ _ _ = pure notFound

364+instance ServeAPI row RowList.Nil () middlewares m where

365+ serveAPI _ _ _ _ _ = pure notFound

227366

228367instance

229− ( ServeRoute t handler m

368+ ( ServeRoute t handler middlewares m

230369 , Row.Cons field t tail row

231− , ServeAPI row rest restHandlers m

370+ , ServeAPI row rest restHandlers middlewares m

232371 , IsSymbol field

233372 , Row.Cons field handler restHandlers handlers

234373 , Row.Lacks field restHandlers

235374 ) =>

236− ServeAPI row (RowList.Cons field t rest) handlers m where

237− serveAPI nt handlers route req =

375+ ServeAPI row (RowList.Cons field t rest) handlers middlewares m where

376+ serveAPI nt handlers middlewares route req =

238377 case serveRoute @t route of

239− Nothing -> serveAPI @row @rest @restHandlers nt (Record.delete (Proxy @field) handlers) route req

240− Just f -> f nt (Record.get (Proxy @field) handlers) req

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

241380

242381notFound :: Response

243−notFound = Response.string "" { status: 404, statusText: "Not Found", headers: [] }

382+notFound = Response { body: EmptyResponseBody, status: 404, statusText: "Not Found", headers: Object.empty }

244383

245384internalServerError :: Response

246−internalServerError = Response.string "" { status: 500, statusText: "Internal Server Error", headers: [] }

385+internalServerError = Response { body: EmptyResponseBody, status: 500, statusText: "Internal Server Error", headers: Object.empty }

247386

248387badRequest :: Response

249−badRequest = Response.string "" { status: 400, statusText: "Bad Request", headers: [] }

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 }

250392

251393-- | The first argument is used to run an arbitrary monad in handlers. To use the 'Server' monad

252394-- | instead you can just pass `identity` as the first argument.

253395run

254− :: forall @row list handlers m

396+ :: forall @row list handlers m middlewares

255397 . RowToList row list

256− => ServeAPI row list handlers m

398+ => ServeAPI row list handlers middlewares m

257399 => (forall x. m x -> Server x)

258− -> Record handlers

400+ -> { handlers :: Record handlers, middlewares :: Record middlewares }

259401 -> Request

260− -> Aff Response

261−run nt handlers req = do

262− res <- runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers (routeFromRequest req) req

263− pure case res of

264− Left resp -> resp

265− Right resp -> resp

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