master..8935650 · purestack-dev/purescript-purestack-server

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

13 files changed+187−760

unifiedsplit

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

spago.dhall−7

@@ -6,21 +6,14 @@

66 , "arrays"

77 , "console"

88 , "control"

9− , "datetime"

109 , "effect"

1110 , "either"

1211 , "foldable-traversable"

13− , "foreign-object"

14− , "formatters"

1512 , "integers"

16− , "lists"

1713 , "maybe"

18− , "now"

1914 , "numbers"

2015 , "ordered-collections"

21− , "parsing"

2216 , "prelude"

23− , "profunctor-lenses"

2417 , "record"

2518 , "run"

2619 , "strings"

src/Bun/Request.js−4

@@ -9,7 +9,3 @@ 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,7 +3,6 @@ module Bun.Request

33 , method

44 , url

55 , json

6− , headers

76 ) where

98import Prelude

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

1211import Control.Promise as Promise

1312import Data.Argonaut (Json)

1413import Effect.Aff (Aff)

15−import Foreign.Object (Object)

1614

1715foreign import data Request :: Type

1816

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

2422foreign import method :: Request -> String

2523

2624foreign import url :: Request -> String

27−

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

src/Bun/Response.js−23

@@ -10,26 +10,3 @@ 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+3−9

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

11module Bun.Response where

33import Data.Argonaut (Json)

4−import Foreign.Object (Object)

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

5+import Effect (Effect)

67foreign import data Response :: Type

7−foreign import data ReadableStream :: Type

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

9+type Options = { status :: Int, statusText :: String, headers :: Array (String /\ 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+7−10

@@ -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, Headers(..), Middleware, POST)

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

1111import PureStack.Route as Router

1212import PureStack.Server as Server

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

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

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

1717

1818type 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 }

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

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

2121 , deep ::

2222 "deep" /

23− ( something :: "something" / GET Unit { a :: String }

23+ ( something :: "something" / GET { a :: String }

2424 )

2525 )

2626

@@ -28,10 +28,7 @@ main :: Effect Unit

2828main = do

2929 log "🍝"

3030 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 }

31+ { foo: \x -> pure { a: 1, b: 1.0, c: x }

32+ , bar: pure { a: 8 }

33+ , deep: { something: pure { a: "something" } }

3734 }

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

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

11module PureStack.Route

22 ( type (/)

33 , Slash

4− , HttpMethod

5− , class MethodName

6− , methodName

74 , GET

85 , POST

96 , PUT

107 , DELETE

118 , PATCH

12− , Headers(..)

13− , Middleware

149 ) where

1510

16−data HttpMethod

11+data GET :: Type -> Type

12+data GET resp

1713

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

14+data POST :: Type -> Type -> Type

15+data POST req resp

2416

25−class MethodName :: HttpMethod -> Constraint

26−class MethodName method where

27− methodName :: String

17+data PUT :: Type -> Type -> Type

18+data PUT req resp

2819

29−instance MethodName (GET req resp) where

30− methodName = "GET"

20+data DELETE :: Type -> Type -> Type

21+data DELETE req resp

3122

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"

23+data PATCH :: Type -> Type -> Type

24+data PATCH req resp

4325

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

4527data Slash x y

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

5032-- | Other types are captured path pieces.

5133infixr 1 type Slash as /

5234

53−data Headers headers r = Headers headers r

54−

55−data Middleware tag

src/PureStack/Server.purs+167−171

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

11module PureStack.Server

22 ( Server

3− , Response(..)

4− , ResponseBody(..)

53 , class ToResponse

64 , toResponse

75 , class FromRequest

@@ -20,24 +18,20 @@ module PureStack.Server

2018 , serveQuery

2119 , class ParsePathPiece

2220 , parsePathPiece

23− , class FromHeaders

24− , fromHeaders

25− , class FromHeader

26− , fromHeader

2721 ) where

2822

2923import Prelude

3024import PureStack.Route

3125

3226import Bun.Request (Request)

33−import Bun.Request as Bun

3427import Bun.Request as Request

35−import Bun.Response as Bun.Response

28+import Bun.Response (Response)

29+import Bun.Response as Response

3630import Control.Alternative (class Plus, empty)

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

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

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

3933import Data.Array as Array

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

34+import Data.Either (Either(..))

4135import Data.Int as Int

4236import Data.Map (Map)

4337import Data.Map as Map

@@ -49,24 +43,15 @@ import Data.Traversable (traverse)

4943import Data.URL as URL

5044import Effect.Aff (Aff)

5145import Effect.Aff.Class (liftAff)

52−import Foreign.Object (Object)

53−import Foreign.Object as Object

5446import Prim.Row as Row

5547import Prim.RowList (class RowToList, RowList)

5648import Prim.RowList as RowList

57−import PureStack.Cookie (Cookie)

58−import PureStack.Cookie as Cookie

5949import Record as Record

6050import Record.Builder (Builder)

6151import Record.Builder as Builder

6252import Type.Proxy (Proxy(..))

6353

64−type Route =

65− { path :: Array String

66− , verb :: String

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

68− , originalRequest :: Bun.Request

69− }

54+type Route = { path :: Array String, verb :: String, query :: Map String (Array String) }

7055

7156routeFromRequest :: Request -> Route

7257routeFromRequest req =

@@ -83,81 +68,180 @@ routeFromRequest req =

8368 , query: case url of

8469 Nothing -> Map.empty

8570 Just u -> URL.query u

86− , originalRequest: req

8771 }

8872

8973type Server a = ExceptT Response Aff a

9074

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

9276

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)

77+class ServeRoute :: forall k. k -> Type -> (Type -> Type) -> Constraint

78+class ServeRoute route handler m | route -> handler, handler -> m where

79+ serveRoute :: Route -> Maybe (Nt m -> handler -> Request -> Server Response)

9680

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

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

9882 serveRoute route@{ path } = do

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

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

10185 serveRoute @rest route { path = tail }

10286

10387else instance

104− ( ServeRoute rest handler middlewares m

88+ ( ServeRoute rest handler m

10589 , ServeQuery row list

10690 , RowToList row list

10791 ) =>

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

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

10993 serveRoute route@{ query } = do

11094 builder <- serveQuery @row @list query

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

11296

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

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

12798 serveRoute route@{ path } = do

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

129100 t <- parsePathPiece @t h

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

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

102+

103+else instance ToResponse resp => ServeRoute (GET resp) (m resp) m where

104+ serveRoute { path, verb } = do

105+ assert $ verb == "GET"

106+ assert $ path == []

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

108+ resp <- nt handler

109+ pure $ toResponse resp

131110

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

111+else instance ServeRoute (POST Unit Unit) (m Unit) m where

133112 serveRoute { path, verb } = do

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

113+ assert $ verb == "POST"

135114 assert $ path == []

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

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

137116 nt handler

138117 pure $ ok

139−else instance (ToResponse resp, MethodName (meth Unit resp)) => ServeRoute (meth Unit resp) (m resp) middlewares m where

118+else instance (ToResponse resp) => ServeRoute (POST Unit resp) (m resp) m where

140119 serveRoute { path, verb } = do

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

120+ assert $ verb == "POST"

142121 assert $ path == []

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

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

144123 resp <- nt handler

145124 pure $ toResponse resp

146−else instance (FromRequest req, MethodName (meth resp Unit)) => ServeRoute (meth resp Unit) (req -> m Unit) middlewares m where

125+else instance (FromRequest req) => ServeRoute (POST resp Unit) (req -> m Unit) m where

147126 serveRoute { path, verb } = do

148− assert $ verb == methodName @(meth resp Unit)

127+ assert $ verb == "POST"

149128 assert $ path == []

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

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

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

152131 Nothing -> pure $ badRequest

153132 Just r -> do

154133 nt $ handler r

155134 pure $ ok

156−else instance (FromRequest req, ToResponse resp, MethodName (meth req resp)) => ServeRoute (meth req resp) (req -> m resp) middlewares m where

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

157136 serveRoute { path, verb } = do

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

137+ assert $ verb == "POST"

159138 assert $ path == []

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

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

140+ liftAff (fromRequest req) >>= case _ of

141+ Nothing -> pure $ badRequest

142+ Just r -> do

143+ resp <- nt $ handler r

144+ pure $ toResponse resp

145+

146+else instance ServeRoute (DELETE Unit Unit) (m Unit) m where

147+ serveRoute { path, verb } = do

148+ assert $ verb == "DELETE"

149+ assert $ path == []

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

151+ nt handler

152+ pure $ ok

153+else instance (ToResponse resp) => ServeRoute (DELETE Unit resp) (m resp) m where

154+ serveRoute { path, verb } = do

155+ assert $ verb == "DELETE"

156+ assert $ path == []

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

158+ resp <- nt handler

159+ pure $ toResponse resp

160+else instance (FromRequest req) => ServeRoute (DELETE resp Unit) (req -> m Unit) m where

161+ serveRoute { path, verb } = do

162+ assert $ verb == "DELETE"

163+ assert $ path == []

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

165+ liftAff (fromRequest req) >>= case _ of

166+ Nothing -> pure $ badRequest

167+ Just r -> do

168+ nt $ handler r

169+ pure $ ok

170+else instance (FromRequest req, ToResponse resp) => ServeRoute (DELETE req resp) (req -> m resp) m where

171+ serveRoute { path, verb } = do

172+ assert $ verb == "DELETE"

173+ assert $ path == []

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

175+ liftAff (fromRequest req) >>= case _ of

176+ Nothing -> pure $ badRequest

177+ Just r -> do

178+ resp <- nt $ handler r

179+ pure $ toResponse resp

180+

181+else instance ServeRoute (PUT Unit Unit) (m Unit) m where

182+ serveRoute { path, verb } = do

183+ assert $ verb == "PUT"

184+ assert $ path == []

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

186+ nt handler

187+ pure $ ok

188+else instance (ToResponse resp) => ServeRoute (PUT Unit resp) (m resp) m where

189+ serveRoute { path, verb } = do

190+ assert $ verb == "PUT"

191+ assert $ path == []

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

193+ resp <- nt handler

194+ pure $ toResponse resp

195+else instance (FromRequest req) => ServeRoute (PUT resp Unit) (req -> m Unit) m where

196+ serveRoute { path, verb } = do

197+ assert $ verb == "PUT"

198+ assert $ path == []

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

200+ liftAff (fromRequest req) >>= case _ of

201+ Nothing -> pure $ badRequest

202+ Just r -> do

203+ nt $ handler r

204+ pure $ ok

205+else instance (FromRequest req, ToResponse resp) => ServeRoute (PUT req resp) (req -> m resp) m where

206+ serveRoute { path, verb } = do

207+ assert $ verb == "PUT"

208+ assert $ path == []

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

210+ liftAff (fromRequest req) >>= case _ of

211+ Nothing -> pure $ badRequest

212+ Just r -> do

213+ resp <- nt $ handler r

214+ pure $ toResponse resp

215+

216+else instance ServeRoute (PATCH Unit Unit) (m Unit) m where

217+ serveRoute { path, verb } = do

218+ assert $ verb == "PATCH"

219+ assert $ path == []

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

221+ nt handler

222+ pure $ ok

223+else instance (ToResponse resp) => ServeRoute (PATCH Unit resp) (m resp) m where

224+ serveRoute { path, verb } = do

225+ assert $ verb == "PATCH"

226+ assert $ path == []

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

228+ resp <- nt handler

229+ pure $ toResponse resp

230+else instance (FromRequest req) => ServeRoute (PATCH resp Unit) (req -> m Unit) m where

231+ serveRoute { path, verb } = do

232+ assert $ verb == "PATCH"

233+ assert $ path == []

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

235+ liftAff (fromRequest req) >>= case _ of

236+ Nothing -> pure $ badRequest

237+ Just r -> do

238+ nt $ handler r

239+ pure $ ok

240+else instance (FromRequest req, ToResponse resp) => ServeRoute (PATCH req resp) (req -> m resp) m where

241+ serveRoute { path, verb } = do

242+ assert $ verb == "PATCH"

243+ assert $ path == []

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

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

162246 Nothing -> pure $ badRequest

163247 Just r -> do

@@ -165,12 +249,12 @@ else instance (FromRequest req, ToResponse resp, MethodName (meth req resp)) =>

165249 pure $ toResponse resp

166250

167251else instance

168− ( ServeAPI routes list handlers middlewares m

252+ ( ServeAPI routes list handlers m

169253 , RowToList routes list

170254 ) =>

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

255+ ServeRoute routes (Record handlers) m where

256+ serveRoute route = pure $ \nt handlers req ->

257+ serveAPI @routes @list nt handlers route req

174258

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

176260class ServeQuery row list | list -> row where

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

228312 r <- serveQuery @tail @rest m

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

230314

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−

238315class ToResponse r where

239316 toResponse :: r -> Response

240317

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

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

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

243320

244321instance ToResponse Response where

245322 toResponse resp = resp

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

255332instance FromRequest Request where

256333 fromRequest req = pure $ Just req

257334

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−

336335class ParsePathPiece t where

337336 parsePathPiece :: String -> Maybe t

338337

@@ -357,54 +356,51 @@ assert :: forall m. Applicative m => Plus m => Boolean -> m Unit

357356assert true = pure unit

358357assert false = empty

359358

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

359+class ServeAPI :: Row Type -> RowList Type -> Row Type -> (Type -> Type) -> Constraint

360+class ServeAPI row list handlers m | row -> handlers, handlers -> m where

361+ serveAPI :: Nt m -> Record handlers -> Route -> Request -> Server Response

363362

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

365− serveAPI _ _ _ _ _ = pure notFound

363+instance ServeAPI row RowList.Nil () m where

364+ serveAPI _ _ _ _ = pure notFound

366365

367366instance

368− ( ServeRoute t handler middlewares m

367+ ( ServeRoute t handler m

369368 , Row.Cons field t tail row

370− , ServeAPI row rest restHandlers middlewares m

369+ , ServeAPI row rest restHandlers m

371370 , IsSymbol field

372371 , Row.Cons field handler restHandlers handlers

373372 , Row.Lacks field restHandlers

374373 ) =>

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

376− serveAPI nt handlers middlewares route req =

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

375+ serveAPI nt handlers route req =

377376 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

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

378+ Just f -> f nt (Record.get (Proxy @field) handlers) req

380379

381380notFound :: Response

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

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

383382

384383internalServerError :: Response

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

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

386385

387386badRequest :: Response

388−badRequest = Response { body: EmptyResponseBody, status: 400, statusText: "Bad Request", headers: Object.empty }

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

389388

390389ok :: Response

391−ok = Response { body: EmptyResponseBody, status: 200, statusText: "OK", headers: Object.empty }

390+ok = Response.string "" { status: 200, statusText: "OK", headers: [] }

392391

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

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

395394run

396− :: forall @row list handlers m middlewares

395+ :: forall @row list handlers m

397396 . RowToList row list

398− => ServeAPI row list handlers middlewares m

397+ => ServeAPI row list handlers m

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

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

399+ -> Record handlers

401400 -> 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

401+ -> Aff Response

402+run nt handlers req = do

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

404+ pure case res of

405+ Left resp -> resp

406+ Right resp -> resp