├── logo.png ├── example ├── 300x300.png └── Main.purs ├── .gitignore ├── test.dhall ├── src ├── Bucketchain │ ├── ResponseBody.js │ ├── Stream.purs │ ├── Http.js │ ├── Test.purs │ ├── ResponseBody.purs │ ├── Middleware.purs │ └── Http.purs └── Bucketchain.purs ├── package.json ├── .github └── workflows │ └── ci.yml ├── README.md ├── spago.dhall ├── LICENSE ├── bower.json ├── packages.dhall └── test └── Main.purs /logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Bucketchain/purescript-bucketchain/HEAD/logo.png -------------------------------------------------------------------------------- /example/300x300.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Bucketchain/purescript-bucketchain/HEAD/example/300x300.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 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 | -------------------------------------------------------------------------------- /test.dhall: -------------------------------------------------------------------------------- 1 | let conf = ./spago.dhall 2 | 3 | in conf // { 4 | sources = conf.sources # [ "example/**/*.purs", "test/**/*.purs" ], 5 | dependencies = conf.dependencies # [ 6 | "assert", 7 | "node-fs" 8 | ] 9 | } 10 | -------------------------------------------------------------------------------- /src/Bucketchain/ResponseBody.js: -------------------------------------------------------------------------------- 1 | 'use strict'; 2 | 3 | import { Readable } from "stream"; 4 | 5 | export function body(str) { 6 | return function() { 7 | const readable = new Readable(); 8 | readable.push(str); 9 | readable.push(null); 10 | return readable; 11 | } 12 | } 13 | 14 | export function empty() { 15 | const readable = new Readable(); 16 | readable.push(null); 17 | return readable; 18 | } 19 | -------------------------------------------------------------------------------- /src/Bucketchain/Stream.purs: -------------------------------------------------------------------------------- 1 | module Bucketchain.Stream where 2 | 3 | import Prelude 4 | 5 | import Data.Either (Either(..)) 6 | import Effect.Aff (Aff, makeAff, nonCanceler) 7 | import Effect.Ref (modify_, new, read) 8 | import Node.Encoding (Encoding(..)) 9 | import Node.Stream (Readable, onDataString, onEnd, onError) 10 | 11 | -- | Convert a readable stream to a string asynchronously. 12 | convertToString :: forall r. Readable r -> Aff String 13 | convertToString readable = makeAff \cb -> do 14 | ref <- new "" 15 | onDataString readable UTF8 \chunk -> modify_ (flip append chunk) ref 16 | onError readable \err -> cb $ Left err 17 | onEnd readable $ Right <$> read ref >>= cb 18 | pure nonCanceler 19 | -------------------------------------------------------------------------------- /src/Bucketchain/Http.js: -------------------------------------------------------------------------------- 1 | 'use strict'; 2 | 3 | export function _setRequestURL(req) { 4 | return function(url) { 5 | return function() { 6 | req.originalUrl = req.originalUrl || req.url; 7 | req.url = url; 8 | return {}; 9 | } 10 | } 11 | } 12 | 13 | export function _requestOriginalURL(req) { 14 | return req.originalUrl || req.url; 15 | } 16 | 17 | export function _responseHeader(res) { 18 | return function(name) { 19 | return res.getHeader(name); 20 | } 21 | } 22 | 23 | export function _responseHeaders(res) { 24 | return function(name) { 25 | return res.getHeader(name) || []; 26 | } 27 | } 28 | 29 | export function _statusCode(res) { 30 | return res.statusCode; 31 | } 32 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "private": true, 3 | "name": "purescript-bucketchain", 4 | "scripts": { 5 | "spago": "spago", 6 | "watch": "spago build -w -u '--strict --stash --censor-lib --is-lib=.spago'", 7 | "clean": "rm -rf output", 8 | "test": "spago -x test.dhall test -u '--strict --stash --censor-lib --is-lib=.spago'", 9 | "start": "spago -x test.dhall run -u '--strict --stash --censor-lib --is-lib=.spago'", 10 | "bump-version": "LC_ALL=C.UTF-8 spago bump-version --no-dry-run", 11 | "pulp:publish": "pulp publish", 12 | "pulp:login": "pulp login" 13 | }, 14 | "dependencies": { 15 | "bower": "^1.8.14", 16 | "pulp": "^16.0.2", 17 | "purescript": "^0.15.6", 18 | "purescript-psa": "^0.8.2", 19 | "spago": "^0.20.9" 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /src/Bucketchain.purs: -------------------------------------------------------------------------------- 1 | module Bucketchain 2 | ( createServer 3 | , listen 4 | ) where 5 | 6 | import Prelude 7 | 8 | import Bucketchain.Middleware (Middleware, runMiddleware) 9 | import Effect (Effect) 10 | import Effect.Console (log) 11 | import Node.HTTP (ListenOptions, Server) 12 | import Node.HTTP as HTTP 13 | 14 | -- | Create a HTTP server. 15 | createServer :: Middleware -> Effect Server 16 | createServer = runMiddleware >>> HTTP.createServer 17 | 18 | -- | Listen on a port in order to start accepting HTTP requests. 19 | listen :: ListenOptions -> Server -> Effect Unit 20 | listen opts server = HTTP.listen server opts $ logListening opts 21 | 22 | logListening :: ListenOptions -> Effect Unit 23 | logListening { hostname, port } = do 24 | log $ "Listening on " <> hostname <> ":" <> show port 25 | log $ "Use Ctrl-C to stop" 26 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: push 4 | 5 | jobs: 6 | test: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v1 10 | 11 | - name: Setup nodejs 12 | uses: actions/setup-node@v1 13 | with: 14 | node-version: 16.17.1 15 | 16 | - name: Cache npm modules 17 | uses: actions/cache@v1 18 | with: 19 | path: ~/.npm 20 | key: ${{ runner.os }}-npm-${{ hashFiles('package-lock.json') }} 21 | restore-keys: | 22 | ${{ runner.os }}-npm- 23 | 24 | - name: Cache spago modules 25 | uses: actions/cache@v1 26 | with: 27 | path: .spago 28 | key: ${{ runner.os }}-deps-${{ hashFiles('packages.dhall') }}-${{ hashFiles('spago.dhall') }}-${{ hashFiles('test.dhall') }} 29 | restore-keys: | 30 | ${{ runner.os }}-deps- 31 | 32 | - name: Install dependencies 33 | run: npm ci 34 | 35 | - name: Test 36 | run: npm test 37 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 |

2 | Bucketchain 3 |

4 | 5 | # purescript-bucketchain 6 | 7 | [![Latest release](http://img.shields.io/github/release/Bucketchain/purescript-bucketchain.svg)](https://github.com/Bucketchain/purescript-bucketchain/releases) 8 | 9 | A PureScript webserver interface based on asynchronous middlewares. 10 | 11 | This is just a interface to implement middlewares. 12 | 13 | See [simple examples](https://github.com/Bucketchain/purescript-bucketchain/blob/master/example/Main.purs) or [some middlewares](https://github.com/Bucketchain) ;) 14 | 15 | ## Installation 16 | 17 | ### Bower 18 | 19 | ``` 20 | $ bower install purescript-bucketchain 21 | ``` 22 | 23 | ### Spago 24 | 25 | ``` 26 | $ spago install bucketchain 27 | ``` 28 | 29 | ## Documentation 30 | 31 | Module documentation is [published on Pursuit](http://pursuit.purescript.org/packages/purescript-bucketchain). 32 | 33 | ## LICENSE 34 | 35 | MIT 36 | -------------------------------------------------------------------------------- /src/Bucketchain/Test.purs: -------------------------------------------------------------------------------- 1 | module Bucketchain.Test where 2 | 3 | import Prelude 4 | 5 | import Data.Either (Either(..)) 6 | import Data.Options (Options) 7 | import Effect.Aff (Aff, makeAff, nonCanceler) 8 | import Node.Encoding (Encoding(..)) 9 | import Node.HTTP.Client as C 10 | import Node.Stream (end, writeString) 11 | 12 | -- | A request test helper. 13 | request :: Options C.RequestOptions -> Aff C.Response 14 | request opts = makeAff \cb -> do 15 | let cb' res = cb $ Right res 16 | req <- C.request opts cb' 17 | end (C.requestAsStream req) $ const $ pure unit 18 | pure nonCanceler 19 | 20 | -- | A request test helper with request body. 21 | requestWithBody :: Options C.RequestOptions -> String -> Aff C.Response 22 | requestWithBody opts body = makeAff \cb -> do 23 | let cb' res = cb $ Right res 24 | req <- C.request opts cb' 25 | let writable = C.requestAsStream req 26 | void $ writeString writable UTF8 body $ const $ pure unit 27 | end writable $ const $ pure unit 28 | pure nonCanceler 29 | -------------------------------------------------------------------------------- /spago.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to a Spago project! 3 | You can edit this file as you like. 4 | 5 | Need help? See the following resources: 6 | - Spago documentation: https://github.com/purescript/spago 7 | - Dhall language tour: https://docs.dhall-lang.org/tutorials/Language-Tour.html 8 | 9 | When creating a new Spago project, you can use 10 | `spago init --no-comments` or `spago init -C` 11 | to generate this file without the comments in this block. 12 | -} 13 | { name = "bucketchain" 14 | , license = "MIT" 15 | , repository = "https://github.com/Bucketchain/purescript-bucketchain" 16 | , dependencies = 17 | [ "aff" 18 | , "console" 19 | , "control" 20 | , "effect" 21 | , "either" 22 | , "exceptions" 23 | , "foreign-object" 24 | , "maybe" 25 | , "node-buffer" 26 | , "node-http" 27 | , "node-streams" 28 | , "nullable" 29 | , "options" 30 | , "prelude" 31 | , "refs" 32 | , "tailrec" 33 | , "transformers" 34 | , "unsafe-coerce" 35 | ] 36 | , packages = ./packages.dhall 37 | , sources = [ "src/**/*.purs" ] 38 | } 39 | -------------------------------------------------------------------------------- /src/Bucketchain/ResponseBody.purs: -------------------------------------------------------------------------------- 1 | module Bucketchain.ResponseBody 2 | ( ResponseBody 3 | , toReadable 4 | , fromReadable 5 | , maybeToBody 6 | , body 7 | ) where 8 | 9 | import Prelude 10 | 11 | import Data.Maybe (Maybe(..)) 12 | import Effect (Effect) 13 | import Node.Stream (Readable) 14 | import Unsafe.Coerce (unsafeCoerce) 15 | 16 | -- | The type of a response body stream. 17 | foreign import data ResponseBody :: Type 18 | 19 | -- | Convert a response body stream to a Readable stream. 20 | toReadable :: ResponseBody -> Readable () 21 | toReadable = unsafeCoerce 22 | 23 | -- | Convert a Readable stream to a response body stream. 24 | fromReadable :: forall r. Readable r -> ResponseBody 25 | fromReadable = unsafeCoerce 26 | 27 | -- | This is for internal. Do not use it. 28 | maybeToBody :: Maybe ResponseBody -> Effect ResponseBody 29 | maybeToBody (Just x) = pure x 30 | maybeToBody Nothing = empty 31 | 32 | -- | Create a response body stream. 33 | foreign import body :: String -> Effect ResponseBody 34 | 35 | foreign import empty :: Effect ResponseBody 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2018 Shinya Takahashi 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-bucketchain", 3 | "license": [ 4 | "MIT" 5 | ], 6 | "repository": { 7 | "type": "git", 8 | "url": "https://github.com/Bucketchain/purescript-bucketchain" 9 | }, 10 | "ignore": [ 11 | "**/.*", 12 | "node_modules", 13 | "bower_components", 14 | "output" 15 | ], 16 | "dependencies": { 17 | "purescript-aff": "^v7.1.0", 18 | "purescript-console": "^v6.0.0", 19 | "purescript-control": "^v6.0.0", 20 | "purescript-effect": "^v4.0.0", 21 | "purescript-either": "^v6.1.0", 22 | "purescript-exceptions": "^v6.0.0", 23 | "purescript-foreign-object": "^v4.1.0", 24 | "purescript-maybe": "^v6.0.0", 25 | "purescript-node-buffer": "^v8.0.0", 26 | "purescript-node-http": "^v8.0.0", 27 | "purescript-node-streams": "^v7.0.0", 28 | "purescript-nullable": "^v6.0.0", 29 | "purescript-options": "^v7.0.0", 30 | "purescript-prelude": "^v6.0.1", 31 | "purescript-refs": "^v6.0.0", 32 | "purescript-tailrec": "^v6.1.0", 33 | "purescript-transformers": "^v6.0.0", 34 | "purescript-unsafe-coerce": "^v6.0.0" 35 | } 36 | } 37 | -------------------------------------------------------------------------------- /example/Main.purs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude 4 | 5 | import Bucketchain (createServer, listen) 6 | import Bucketchain.Middleware (Middleware) 7 | import Bucketchain.Http (requestMethod, requestURL, requestBody, setStatusCode, setHeader) 8 | import Bucketchain.ResponseBody (body, fromReadable) 9 | import Control.Monad.Error.Class (throwError) 10 | import Control.Monad.Reader (ask) 11 | import Data.Maybe (Maybe(..)) 12 | import Effect (Effect) 13 | import Effect.Aff.Class (liftAff) 14 | import Effect.Class (liftEffect) 15 | import Effect.Exception (error) 16 | import Node.FS.Stream (createReadStream) 17 | import Node.HTTP (ListenOptions, Server) 18 | 19 | main :: Effect Unit 20 | main = server >>= listen opts 21 | 22 | server :: Effect Server 23 | server = createServer middleware 24 | 25 | opts :: ListenOptions 26 | opts = 27 | { hostname: "127.0.0.1" 28 | , port: 3000 29 | , backlog: Nothing 30 | } 31 | 32 | middleware :: Middleware 33 | middleware = middleware1 <<< middleware2 <<< middleware3 <<< middleware4 34 | 35 | middleware1 :: Middleware 36 | middleware1 next = do 37 | http <- ask 38 | if requestMethod http == "GET" && requestURL http == "/test" 39 | then liftEffect do 40 | setStatusCode http 200 41 | setHeader http "Content-Type" "text/plain; charset=utf-8" 42 | Just <$> body "Hello world :)" 43 | else next 44 | 45 | middleware2 :: Middleware 46 | middleware2 next = do 47 | http <- ask 48 | if requestMethod http == "POST" && requestURL http == "/test" 49 | then do 50 | b <- liftAff $ requestBody http 51 | liftEffect do 52 | setStatusCode http 200 53 | setHeader http "Content-Type" "text/plain; charset=utf-8" 54 | Just <$> body b 55 | else next 56 | 57 | middleware3 :: Middleware 58 | middleware3 next = do 59 | http <- ask 60 | if requestMethod http == "GET" && requestURL http == "/img" 61 | then liftEffect do 62 | setStatusCode http 200 63 | setHeader http "Content-Type" "image/png" 64 | Just <<< fromReadable <$> createReadStream "example/300x300.png" 65 | else next 66 | 67 | middleware4 :: Middleware 68 | middleware4 next = do 69 | http <- ask 70 | if requestMethod http == "GET" && requestURL http == "/error" 71 | then throwError $ error "Internal Server Error" 72 | else next 73 | -------------------------------------------------------------------------------- /src/Bucketchain/Middleware.purs: -------------------------------------------------------------------------------- 1 | module Bucketchain.Middleware 2 | ( Handler 3 | , Middleware 4 | , runMiddleware 5 | ) where 6 | 7 | import Prelude 8 | 9 | import Bucketchain.Http (Http, httpStream, setHeader, setStatusCode, toWritable) 10 | import Bucketchain.ResponseBody (ResponseBody, toReadable, maybeToBody) 11 | import Control.Alt (class Alt) 12 | import Control.Monad.Error.Class (class MonadError, class MonadThrow) 13 | import Control.Monad.Reader (class MonadAsk, ReaderT, ask, runReaderT) 14 | import Control.Monad.Rec.Class (class MonadRec) 15 | import Control.Plus (class Plus) 16 | import Data.Either (Either(..)) 17 | import Data.Maybe (Maybe(..)) 18 | import Effect (Effect) 19 | import Effect.Aff (Aff, runAff_) 20 | import Effect.Aff.Class (class MonadAff) 21 | import Effect.Class (class MonadEffect, liftEffect) 22 | import Effect.Exception (Error) 23 | import Node.HTTP (Request, Response) 24 | import Node.Stream (end, onError, pipe) 25 | 26 | -- | The type of a HTTP handler. 27 | newtype Handler a = Handler (ReaderT Http Aff a) 28 | 29 | derive newtype instance functorHandler :: Functor Handler 30 | derive newtype instance applyHandler :: Apply Handler 31 | derive newtype instance applicativeHandler :: Applicative Handler 32 | derive newtype instance altHandler :: Alt Handler 33 | derive newtype instance plusHandler :: Plus Handler 34 | derive newtype instance bindHandler :: Bind Handler 35 | derive newtype instance monadHandler :: Monad Handler 36 | derive newtype instance semigroupHandler :: Semigroup a => Semigroup (Handler a) 37 | derive newtype instance monoidHandler :: Monoid a => Monoid (Handler a) 38 | derive newtype instance monadEffectHandler :: MonadEffect Handler 39 | derive newtype instance monadAffHandler :: MonadAff Handler 40 | derive newtype instance monadThrowHandler :: MonadThrow Error Handler 41 | derive newtype instance monadErrorHandler :: MonadError Error Handler 42 | derive newtype instance monadAskHandler :: MonadAsk Http Handler 43 | derive newtype instance monadRecHandler :: MonadRec Handler 44 | 45 | -- | The type of a middleware. 46 | type Middleware = Handler (Maybe ResponseBody) -> Handler (Maybe ResponseBody) 47 | 48 | -- | This is for internal. Do not use it. 49 | runMiddleware 50 | :: Middleware 51 | -> Request 52 | -> Response 53 | -> Effect Unit 54 | runMiddleware middleware = runHandler $ middleware empty 55 | 56 | runHandler 57 | :: Handler (Maybe ResponseBody) 58 | -> Request 59 | -> Response 60 | -> Effect Unit 61 | runHandler (Handler h) req res = 62 | runAff_ (handleAff http) $ runReaderT h http 63 | where 64 | http = httpStream req res 65 | 66 | handleAff :: Http -> Either Error (Maybe ResponseBody) -> Effect Unit 67 | handleAff http (Right x) = do 68 | readable <- toReadable <$> maybeToBody x 69 | onError readable $ Left >>> handleAff http 70 | void $ pipe readable $ toWritable http 71 | handleAff http _ = do 72 | setHeader http "Content-Type" "text/plain; charset=utf-8" 73 | setStatusCode http 500 74 | end (toWritable http) $ const $ pure unit 75 | 76 | empty :: Handler (Maybe ResponseBody) 77 | empty = do 78 | http <- ask 79 | liftEffect do 80 | setStatusCode http 404 81 | setHeader http "Content-Type" "text/plain; charset=utf-8" 82 | pure Nothing 83 | -------------------------------------------------------------------------------- /packages.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to your new Dhall package-set! 3 | 4 | Below are instructions for how to edit this file for most use 5 | cases, so that you don't need to know Dhall to use it. 6 | 7 | ## Use Cases 8 | 9 | Most will want to do one or both of these options: 10 | 1. Override/Patch a package's dependency 11 | 2. Add a package not already in the default package set 12 | 13 | This file will continue to work whether you use one or both options. 14 | Instructions for each option are explained below. 15 | 16 | ### Overriding/Patching a package 17 | 18 | Purpose: 19 | - Change a package's dependency to a newer/older release than the 20 | default package set's release 21 | - Use your own modified version of some dependency that may 22 | include new API, changed API, removed API by 23 | using your custom git repo of the library rather than 24 | the package set's repo 25 | 26 | Syntax: 27 | where `entityName` is one of the following: 28 | - dependencies 29 | - repo 30 | - version 31 | ------------------------------- 32 | let upstream = -- 33 | in upstream 34 | with packageName.entityName = "new value" 35 | ------------------------------- 36 | 37 | Example: 38 | ------------------------------- 39 | let upstream = -- 40 | in upstream 41 | with halogen.version = "master" 42 | with halogen.repo = "https://example.com/path/to/git/repo.git" 43 | 44 | with halogen-vdom.version = "v4.0.0" 45 | with halogen-vdom.dependencies = [ "extra-dependency" ] # halogen-vdom.dependencies 46 | ------------------------------- 47 | 48 | ### Additions 49 | 50 | Purpose: 51 | - Add packages that aren't already included in the default package set 52 | 53 | Syntax: 54 | where `` is: 55 | - a tag (i.e. "v4.0.0") 56 | - a branch (i.e. "master") 57 | - commit hash (i.e. "701f3e44aafb1a6459281714858fadf2c4c2a977") 58 | ------------------------------- 59 | let upstream = -- 60 | in upstream 61 | with new-package-name = 62 | { dependencies = 63 | [ "dependency1" 64 | , "dependency2" 65 | ] 66 | , repo = 67 | "https://example.com/path/to/git/repo.git" 68 | , version = 69 | "" 70 | } 71 | ------------------------------- 72 | 73 | Example: 74 | ------------------------------- 75 | let upstream = -- 76 | in upstream 77 | with benchotron = 78 | { dependencies = 79 | [ "arrays" 80 | , "exists" 81 | , "profunctor" 82 | , "strings" 83 | , "quickcheck" 84 | , "lcg" 85 | , "transformers" 86 | , "foldable-traversable" 87 | , "exceptions" 88 | , "node-fs" 89 | , "node-buffer" 90 | , "node-readline" 91 | , "datetime" 92 | , "now" 93 | ] 94 | , repo = 95 | "https://github.com/hdgarrood/purescript-benchotron.git" 96 | , version = 97 | "v7.0.0" 98 | } 99 | ------------------------------- 100 | -} 101 | let upstream = 102 | https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20221116/packages.dhall 103 | sha256:a0b88cbba414b046d9e7660fb77ed433d238d4c6ab20e75a479c9c6c823f2812 104 | 105 | in upstream 106 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | 5 | import Bucketchain.Stream (convertToString) 6 | import Bucketchain.Test (request, requestWithBody) 7 | import Data.Either (Either(..)) 8 | import Data.Maybe (Maybe(..)) 9 | import Data.Options ((:=)) 10 | import Effect (Effect) 11 | import Effect.Aff (Aff, runAff_) 12 | import Effect.Class (liftEffect) 13 | import Effect.Console (log) 14 | import Effect.Exception (Error, message) 15 | import Foreign.Object (lookup) 16 | import Main (server) 17 | import Node.FS.Stream (createReadStream) 18 | import Node.HTTP (Server, listen, close) 19 | import Node.HTTP.Client as C 20 | import Test.Assert (assert) 21 | 22 | main :: Effect Unit 23 | main = do 24 | s <- server 25 | listen s opts $ runAff_ (handleAff s) do 26 | testMiddleware1 27 | testMiddleware2 28 | testMiddleware3 29 | testMiddleware4 30 | test404 31 | where 32 | opts = 33 | { hostname: "localhost" 34 | , port: 3000 35 | , backlog: Nothing 36 | } 37 | 38 | handleAff :: Server -> Either Error Unit -> Effect Unit 39 | handleAff _ (Left err) = do 40 | log $ message err 41 | assert false 42 | handleAff s _ = close s $ pure unit 43 | 44 | testMiddleware1 :: Aff Unit 45 | testMiddleware1 = do 46 | res <- request opts 47 | body <- convertToString $ C.responseAsStream res 48 | liftEffect do 49 | assert $ body == "Hello world :)" 50 | assert $ C.statusCode res == 200 51 | case lookup "content-type" $ C.responseHeaders res of 52 | Just "text/plain; charset=utf-8" -> assert true 53 | _ -> assert false 54 | where 55 | opts = C.port := 3000 56 | <> C.method := "GET" 57 | <> C.path := "/test" 58 | 59 | testMiddleware2 :: Aff Unit 60 | testMiddleware2 = do 61 | res <- requestWithBody opts "TEST BODY" 62 | body <- convertToString $ C.responseAsStream res 63 | liftEffect do 64 | assert $ body == "TEST BODY" 65 | assert $ C.statusCode res == 200 66 | case lookup "content-type" $ C.responseHeaders res of 67 | Just "text/plain; charset=utf-8" -> assert true 68 | _ -> assert false 69 | where 70 | opts = C.port := 3000 71 | <> C.method := "POST" 72 | <> C.path := "/test" 73 | 74 | testMiddleware3 :: Aff Unit 75 | testMiddleware3 = do 76 | res <- request opts 77 | imgStream <- liftEffect $ createReadStream "example/300x300.png" 78 | expected <- convertToString imgStream 79 | body <- convertToString $ C.responseAsStream res 80 | liftEffect do 81 | assert $ body == expected 82 | assert $ C.statusCode res == 200 83 | case lookup "content-type" $ C.responseHeaders res of 84 | Just "image/png" -> assert true 85 | _ -> assert false 86 | where 87 | opts = C.port := 3000 88 | <> C.method := "GET" 89 | <> C.path := "/img" 90 | 91 | testMiddleware4 :: Aff Unit 92 | testMiddleware4 = do 93 | res <- request opts 94 | liftEffect $ assert $ C.statusCode res == 500 95 | where 96 | opts = C.port := 3000 97 | <> C.method := "GET" 98 | <> C.path := "/error" 99 | 100 | test404 :: Aff Unit 101 | test404 = do 102 | res <- request opts 103 | liftEffect $ assert $ C.statusCode res == 404 104 | where 105 | opts = C.port := 3000 106 | <> C.method := "GET" 107 | <> C.path := "/404" 108 | -------------------------------------------------------------------------------- /src/Bucketchain/Http.purs: -------------------------------------------------------------------------------- 1 | module Bucketchain.Http 2 | ( Http 3 | , toRequest 4 | , httpStream 5 | , httpVersion 6 | , requestHeaders 7 | , requestMethod 8 | , requestOriginalURL 9 | , requestURL 10 | , requestBody 11 | , toReadable 12 | , responseHeader 13 | , responseHeaders 14 | , statusCode 15 | , setHeader 16 | , setHeaders 17 | , setRequestURL 18 | , setStatusCode 19 | , setStatusMessage 20 | , toWritable 21 | , onFinish 22 | ) where 23 | 24 | import Prelude 25 | 26 | import Bucketchain.Stream (convertToString) 27 | import Data.Maybe (Maybe) 28 | import Data.Nullable (Nullable, toMaybe) 29 | import Effect (Effect) 30 | import Effect.Aff (Aff) 31 | import Foreign.Object (Object) 32 | import Node.HTTP as HTTP 33 | import Node.Stream (Readable, Writable) 34 | import Node.Stream as Stream 35 | 36 | -- | The type of a HTTP stream. 37 | newtype Http = Http 38 | { req :: HTTP.Request 39 | , res :: HTTP.Response 40 | } 41 | 42 | -- | Convert a HTTP stream to a Request stream. 43 | toRequest :: Http -> HTTP.Request 44 | toRequest (Http { req }) = req 45 | 46 | toResponse :: Http -> HTTP.Response 47 | toResponse (Http { res }) = res 48 | 49 | -- | Create a HTTP stream. 50 | httpStream :: HTTP.Request -> HTTP.Response -> Http 51 | httpStream req res = Http { req, res } 52 | 53 | -- | Get the request HTTP version. 54 | httpVersion :: Http -> String 55 | httpVersion = toRequest >>> HTTP.httpVersion 56 | 57 | -- | Get the request headers. 58 | requestHeaders :: Http -> Object String 59 | requestHeaders = toRequest >>> HTTP.requestHeaders 60 | 61 | -- | Get the request method (GET, POST, etc.). 62 | requestMethod :: Http -> String 63 | requestMethod = toRequest >>> HTTP.requestMethod 64 | 65 | -- | Get the request original URL. 66 | requestOriginalURL :: Http -> String 67 | requestOriginalURL = toRequest >>> _requestOriginalURL 68 | 69 | -- | Get the request URL. 70 | requestURL :: Http -> String 71 | requestURL = toRequest >>> HTTP.requestURL 72 | 73 | -- | Get the request body. 74 | requestBody :: Http -> Aff String 75 | requestBody = toReadable >>> convertToString 76 | 77 | -- | Convert a Http stream to a Readable stream. 78 | toReadable :: Http -> Readable () 79 | toReadable = toRequest >>> HTTP.requestAsStream 80 | 81 | -- | Get a response header value by header name. 82 | responseHeader :: Http -> String -> Maybe String 83 | responseHeader http = toMaybe <<< (_responseHeader $ toResponse http) 84 | 85 | -- | Get response header values by header name. 86 | responseHeaders :: Http -> String -> Array String 87 | responseHeaders = toResponse >>> _responseHeaders 88 | 89 | -- | Get the status code. 90 | statusCode :: Http -> Int 91 | statusCode = toResponse >>> _statusCode 92 | 93 | -- | Set a header with a single value. 94 | setHeader :: Http -> String -> String -> Effect Unit 95 | setHeader = toResponse >>> HTTP.setHeader 96 | 97 | -- | Set a header with multiple values. 98 | setHeaders :: Http -> String -> Array String -> Effect Unit 99 | setHeaders = toResponse >>> HTTP.setHeaders 100 | 101 | -- | Set the request URL. 102 | setRequestURL :: Http -> String -> Effect Unit 103 | setRequestURL = toRequest >>> _setRequestURL 104 | 105 | -- | Set the status code. 106 | setStatusCode :: Http -> Int -> Effect Unit 107 | setStatusCode = toResponse >>> HTTP.setStatusCode 108 | 109 | -- | Set the status message. 110 | setStatusMessage :: Http -> String -> Effect Unit 111 | setStatusMessage = toResponse >>> HTTP.setStatusMessage 112 | 113 | -- | This is for internal. Do not use it. 114 | toWritable :: Http -> Writable () 115 | toWritable = toResponse >>> HTTP.responseAsStream 116 | 117 | -- | Listen `finish` event of a response stream. 118 | onFinish :: Http -> Effect Unit -> Effect Unit 119 | onFinish = toWritable >>> Stream.onFinish 120 | 121 | foreign import _setRequestURL :: HTTP.Request -> String -> Effect Unit 122 | 123 | foreign import _requestOriginalURL :: HTTP.Request -> String 124 | 125 | foreign import _responseHeader :: HTTP.Response -> String -> Nullable String 126 | 127 | foreign import _responseHeaders :: HTTP.Response -> String -> Array String 128 | 129 | foreign import _statusCode :: HTTP.Response -> Int 130 | --------------------------------------------------------------------------------