├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── bower.json ├── generated-docs └── QuickServe.md ├── package.json ├── src └── QuickServe.purs └── test └── Main.purs /.gitignore: -------------------------------------------------------------------------------- 1 | .* 2 | !/.bowerrc 3 | !/.gitignore 4 | !/.travis.yml 5 | /output/ 6 | /node_modules/ 7 | /bower_components/ 8 | /tmp/ 9 | /example/index.js 10 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: node_js 2 | dist: trusty 3 | sudo: required 4 | node_js: 9 5 | install: 6 | - npm install -g bower 7 | - npm install 8 | - bower install --production 9 | script: 10 | - npm run -s build 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2017 Phil Freeman 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | 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, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # purescript-quickserve 2 | 3 | Quickly create HTTP servers from functions! 4 | 5 | [Module Documentation](generated-docs/QuickServe.md) 6 | 7 | ## Getting Started 8 | 9 | A single endpoint which returns plain text: 10 | 11 | ```purescript 12 | server :: GET String 13 | server = pure "Hello, World!" 14 | 15 | main = do 16 | let opts = { hostname: "localhost", port: 3000, backlog: Nothing } 17 | quickServe opts server 18 | ``` 19 | 20 | ## Parsing Requests 21 | 22 | Use a function argument with type `RequestBody a` to read the request body: 23 | 24 | ```purescript 25 | server :: RequestBody String -> POST String 26 | server (RequestBody s) = pure s 27 | ``` 28 | 29 | ## JSON 30 | 31 | Instead of `String`s, values which support the `Decode` and `Encode` classes 32 | from `purescript-foreign-generic` can be used as JSON request and response types 33 | respectively. See the [test project](test/Main.purs) for an example. 34 | 35 | ## Effects 36 | 37 | The `GET`/`POST` monad has instances for `MonadEffect` and `MonadAff` to lift 38 | synchronous and asynchronous effects. 39 | 40 | ## Routing 41 | 42 | Routing tables are defined using records of functions, where the record's labels 43 | are used to match routes. See the [test project](test/Main.purs) for an example. 44 | 45 | Routing tables can be nested. 46 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-quickserve", 3 | "ignore": [ 4 | "**/.*", 5 | "node_modules", 6 | "bower_components", 7 | "output" 8 | ], 9 | "license": "MIT", 10 | "repository": { 11 | "type": "git", 12 | "url": "git://github.com/paf31/purescript-quickserve.git" 13 | }, 14 | "dependencies": { 15 | "purescript-aff": "^5.0.0", 16 | "purescript-console": "^4.1.0", 17 | "purescript-node-http": "^5.0.0", 18 | "purescript-foreign-generic": "^7.0.0", 19 | "purescript-typelevel-prelude": "^3.0.0", 20 | "purescript-record": "^1.0.0" 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /generated-docs/QuickServe.md: -------------------------------------------------------------------------------- 1 | ## Module QuickServe 2 | 3 | #### `Servable` 4 | 5 | ``` purescript 6 | class Servable server where 7 | serveWith :: server -> Request -> Response -> List String -> Maybe (Effect Unit) 8 | ``` 9 | 10 | A type class for types of values which define 11 | servers. 12 | 13 | Servers are built from the `Method` data type, which 14 | defines the method, record types which define routes 15 | and function types which make things like the request 16 | body and query parameters available. 17 | 18 | ##### Instances 19 | ``` purescript 20 | (IsSymbol method, IsResponse response) => Servable (Method method response) 21 | (IsRequest request, Servable service) => Servable (RequestBody request -> service) 22 | (Servable service) => Servable (Capture -> service) 23 | (RowToList r l, ServableList l r) => Servable { | r } 24 | ``` 25 | 26 | #### `IsResponse` 27 | 28 | ``` purescript 29 | class IsResponse response where 30 | encodeResponse :: response -> String 31 | responseType :: Proxy response -> String 32 | ``` 33 | 34 | A type class for response data. 35 | 36 | ##### Instances 37 | ``` purescript 38 | IsResponse String 39 | (Encode a) => IsResponse (JSON a) 40 | ``` 41 | 42 | #### `IsRequest` 43 | 44 | ``` purescript 45 | class IsRequest request where 46 | decodeRequest :: String -> Either String request 47 | requestType :: Proxy request -> String 48 | ``` 49 | 50 | A type class for request data. 51 | 52 | ##### Instances 53 | ``` purescript 54 | IsRequest String 55 | (Decode a) => IsRequest (JSON a) 56 | ``` 57 | 58 | #### `JSON` 59 | 60 | ``` purescript 61 | newtype JSON a 62 | = JSON a 63 | ``` 64 | 65 | A request/response type which uses JSON as its 66 | data representation. 67 | 68 | ##### Instances 69 | ``` purescript 70 | Newtype (JSON a) _ 71 | (Encode a) => IsResponse (JSON a) 72 | (Decode a) => IsRequest (JSON a) 73 | ``` 74 | 75 | #### `Method` 76 | 77 | ``` purescript 78 | newtype Method (m :: Symbol) response 79 | = Method (Aff response) 80 | ``` 81 | 82 | A `Servable` type constructor which indicates the expected 83 | method (GET, POST, PUT, etc.) using a type-level string. 84 | 85 | ##### Instances 86 | ``` purescript 87 | Newtype (Method m response) _ 88 | Functor (Method m) 89 | Apply (Method m) 90 | Applicative (Method m) 91 | Bind (Method m) 92 | Monad (Method m) 93 | MonadEffect (Method m) 94 | MonadAff (Method m) 95 | (IsSymbol method, IsResponse response) => Servable (Method method response) 96 | ``` 97 | 98 | #### `GET` 99 | 100 | ``` purescript 101 | type GET = Method "GET" 102 | ``` 103 | 104 | A resource which responds to GET requests. 105 | 106 | #### `POST` 107 | 108 | ``` purescript 109 | type POST = Method "POST" 110 | ``` 111 | 112 | A resource which responds to POST requests. 113 | 114 | #### `PUT` 115 | 116 | ``` purescript 117 | type PUT = Method "PUT" 118 | ``` 119 | 120 | A resource which responds to PUT requests. 121 | 122 | #### `RequestBody` 123 | 124 | ``` purescript 125 | newtype RequestBody a 126 | = RequestBody a 127 | ``` 128 | 129 | `RequestBody` can be used to read the request body. 130 | 131 | To read the request body, use a function type with a function 132 | argument type which has an `IsRequest` instance: 133 | 134 | ```purescript 135 | main = quickServe opts echo where 136 | echo :: RequestBody String -> GET String 137 | echo (RequestBody s) = pure s 138 | ``` 139 | 140 | ##### Instances 141 | ``` purescript 142 | Newtype (RequestBody a) _ 143 | (IsRequest request, Servable service) => Servable (RequestBody request -> service) 144 | ``` 145 | 146 | #### `Capture` 147 | 148 | ``` purescript 149 | newtype Capture 150 | = Capture String 151 | ``` 152 | 153 | `Capture` can be used to capture a part of the route. 154 | 155 | Use a function type with a function 156 | argument of type `Capture`: 157 | 158 | ```purescript 159 | main = quickServe opts echo' where 160 | echo' :: Capture -> GET String 161 | echo' (Capture s) = pure s 162 | ``` 163 | 164 | ##### Instances 165 | ``` purescript 166 | Newtype Capture _ 167 | (Servable service) => Servable (Capture -> service) 168 | ``` 169 | 170 | #### `quickServe` 171 | 172 | ``` purescript 173 | quickServe :: forall server. Servable server => ListenOptions -> server -> Effect Unit 174 | ``` 175 | 176 | Start a web server given some `Servable` type 177 | and an implementation of that type. 178 | 179 | For example: 180 | 181 | ```purescript 182 | opts = { hostname: "localhost" 183 | , port: 3000 184 | , backlog: Nothing 185 | } 186 | 187 | main = quickServe opts hello where 188 | hello :: GET String 189 | hello = pure "Hello, World!"" 190 | ``` 191 | 192 | #### `ServableList` 193 | 194 | ``` purescript 195 | class ServableList (l :: RowList) (r :: # Type) | l -> r where 196 | serveListWith :: RLProxy l -> { | r } -> Request -> Response -> List String -> Maybe (Effect Unit) 197 | ``` 198 | 199 | ##### Instances 200 | ``` purescript 201 | ServableList Nil () 202 | (IsSymbol route, Servable s, ServableList l r1, Cons route s r1 r) => ServableList (Cons route s l) r 203 | ``` 204 | 205 | 206 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "private": true, 3 | "scripts": { 4 | "clean": "rimraf output && rimraf .pulp-cache", 5 | "build": "pulp build -- --censor-lib --strict" 6 | }, 7 | "devDependencies": { 8 | "pulp": "^12.2.0", 9 | "purescript-psa": "^0.5.0", 10 | "purescript": "^0.12.0", 11 | "rimraf": "^2.5.4" 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /src/QuickServe.purs: -------------------------------------------------------------------------------- 1 | module QuickServe 2 | ( class Servable 3 | , serveWith 4 | , class IsResponse 5 | , encodeResponse 6 | , responseType 7 | , class IsRequest 8 | , decodeRequest 9 | , requestType 10 | , JSON(..) 11 | , Method(..) 12 | , GET 13 | , POST 14 | , PUT 15 | , RequestBody(..) 16 | , Capture(..) 17 | , quickServe 18 | , class ServableList 19 | , serveListWith 20 | ) where 21 | 22 | import Prelude 23 | 24 | import Control.Comonad (extract) 25 | import Control.Monad.Except (runExcept) 26 | import Data.Bifunctor (bimap) 27 | import Data.Either (Either(..), either) 28 | import Data.List (List(..), fromFoldable, (:)) 29 | import Data.Maybe (Maybe(Nothing, Just), maybe) 30 | import Data.Newtype (class Newtype, unwrap, wrap) 31 | import Data.Nullable (toMaybe) 32 | import Data.String (split) 33 | import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) 34 | import Effect (Effect) 35 | import Effect.Aff (Aff, runAff) 36 | import Effect.Aff.Class (class MonadAff) 37 | import Effect.Class (class MonadEffect) 38 | import Effect.Console (log) 39 | import Effect.Exception (Error, catchException, message) 40 | import Effect.Ref as Ref 41 | import Foreign (renderForeignError) 42 | import Foreign.Class (class Decode, class Encode) 43 | import Foreign.Generic (decodeJSON, encodeJSON) 44 | import Node.Encoding (Encoding(..)) 45 | import Node.HTTP (ListenOptions, Request, Response, createServer, listen, requestAsStream, requestMethod, requestURL, responseAsStream, setHeader, setStatusCode, setStatusMessage) 46 | import Node.Stream (end, onDataString, onEnd, onError, writeString) 47 | import Node.URL (parse) 48 | import Prim.Row (class Cons) 49 | import Record (get) 50 | import Type.Proxy (Proxy(..)) 51 | import Type.Row (class RowToList, Cons, Nil, RLProxy(..), kind RowList) 52 | import Unsafe.Coerce (unsafeCoerce) 53 | 54 | -- | A type class for types of values which define 55 | -- | servers. 56 | -- | 57 | -- | Servers are built from the `Method` data type, which 58 | -- | defines the method, record types which define routes 59 | -- | and function types which make things like the request 60 | -- | body and query parameters available. 61 | class Servable server where 62 | serveWith 63 | :: server 64 | -> Request 65 | -> Response 66 | -> List String 67 | -> Maybe (Effect Unit) 68 | 69 | -- | Start a web server given some `Servable` type 70 | -- | and an implementation of that type. 71 | -- | 72 | -- | For example: 73 | -- | 74 | -- | ```purescript 75 | -- | opts = { hostname: "localhost" 76 | -- | , port: 3000 77 | -- | , backlog: Nothing 78 | -- | } 79 | -- | 80 | -- | main = quickServe opts hello where 81 | -- | hello :: GET String 82 | -- | hello = pure "Hello, World!"" 83 | -- | ``` 84 | quickServe 85 | :: forall server 86 | . Servable server 87 | => ListenOptions 88 | -> server 89 | -> Effect Unit 90 | quickServe opts serve = do 91 | server <- createServer \req res -> do 92 | let url = parse (requestURL req) 93 | path = maybe mempty toParts (toMaybe (url.path)) 94 | toParts = dropEmpty <<< fromFoldable <<< split (wrap "/") 95 | dropEmpty ("" : xs) = dropEmpty xs 96 | dropEmpty xs = xs 97 | log (requestMethod req <> " " <> show (url.path)) 98 | case serveWith serve req res path of 99 | Nothing -> badRoute res 100 | Just s -> s 101 | listen server opts (log ("Listening on port " <> show (_.port opts))) 102 | 103 | -- | A type class for response data. 104 | class IsResponse response where 105 | encodeResponse :: response -> String 106 | responseType :: Proxy response -> String 107 | 108 | instance isResponseString :: IsResponse String where 109 | encodeResponse = identity 110 | responseType _ = "text/plain" 111 | 112 | -- | A type class for request data. 113 | class IsRequest request where 114 | decodeRequest :: String -> Either String request 115 | requestType :: Proxy request -> String 116 | 117 | instance isRequestString :: IsRequest String where 118 | decodeRequest = Right 119 | requestType _ = "text/plain" 120 | 121 | -- | A request/response type which uses JSON as its 122 | -- | data representation. 123 | newtype JSON a = JSON a 124 | 125 | derive instance newtypeJSON :: Newtype (JSON a) _ 126 | 127 | instance isResponseJSON :: Encode a => IsResponse (JSON a) where 128 | encodeResponse = 129 | encodeResponse 130 | <<< encodeJSON 131 | <<< unwrap 132 | responseType _ = "application/json" 133 | 134 | instance isRequestJSON :: Decode a => IsRequest (JSON a) where 135 | decodeRequest = 136 | bimap (renderForeignError <<< extract) JSON 137 | <<< runExcept 138 | <<< decodeJSON 139 | <=< decodeRequest 140 | requestType _ = "application/json" 141 | 142 | -- | A `Servable` type constructor which indicates the expected 143 | -- | method (GET, POST, PUT, etc.) using a type-level string. 144 | newtype Method (m :: Symbol) response = Method (Aff response) 145 | 146 | derive instance newtypeMethod :: Newtype (Method m response) _ 147 | 148 | derive newtype instance functorMethod :: Functor (Method m) 149 | derive newtype instance applyMethod :: Apply (Method m) 150 | derive newtype instance applicativeMethod :: Applicative (Method m) 151 | derive newtype instance bindMethod :: Bind (Method m) 152 | derive newtype instance monadMethod :: Monad (Method m) 153 | derive newtype instance monadEffectMethod :: MonadEffect (Method m) 154 | derive newtype instance monadAffMethod :: MonadAff (Method m) 155 | 156 | -- | A resource which responds to GET requests. 157 | type GET = Method "GET" 158 | 159 | -- | A resource which responds to POST requests. 160 | type POST = Method "POST" 161 | 162 | -- | A resource which responds to PUT requests. 163 | type PUT = Method "PUT" 164 | 165 | instance servableMethod 166 | :: (IsSymbol method, IsResponse response) 167 | => Servable (Method method response) where 168 | serveWith respond req res Nil = pure do 169 | let outputStream = responseAsStream res 170 | 171 | handleError = sendError res 500 "Internal server error" <<< message 172 | 173 | handleResponse r = do 174 | setHeader res "Content-Type" (responseType (Proxy :: Proxy response)) 175 | _ <- writeString outputStream UTF8 (encodeResponse r) (pure unit) 176 | end outputStream (pure unit) 177 | let actual = requestMethod req 178 | expected = reflectSymbol (SProxy :: SProxy method) 179 | if actual == expected 180 | then void $ runAff (either handleError handleResponse) (unwrap respond) 181 | else sendError res 405 "Method not allowed" ("Expected " <> expected) 182 | serveWith _ _ _ _ = Nothing 183 | 184 | -- | `RequestBody` can be used to read the request body. 185 | -- | 186 | -- | To read the request body, use a function type with a function 187 | -- | argument type which has an `IsRequest` instance: 188 | -- | 189 | -- | ```purescript 190 | -- | main = quickServe opts echo where 191 | -- | echo :: RequestBody String -> GET String 192 | -- | echo (RequestBody s) = pure s 193 | -- | ``` 194 | newtype RequestBody a = RequestBody a 195 | 196 | derive instance newtypeRequestBody :: Newtype (RequestBody a) _ 197 | 198 | instance servableRequestBody 199 | :: (IsRequest request, Servable service) 200 | => Servable (RequestBody request -> service) where 201 | serveWith read req res path = Just $ void do 202 | buffer <- Ref.new "" 203 | 204 | let inputStream = requestAsStream req 205 | outputStream = responseAsStream res 206 | 207 | handleData str = (flip Ref.modify_) buffer (_ <> str) 208 | 209 | handleError :: Error -> Effect Unit 210 | handleError = sendError res 500 "Internal server error" <<< message 211 | 212 | handleEnd = do 213 | body <- Ref.read buffer 214 | case decodeRequest body of 215 | Left err -> 216 | sendError res 400 "Bad Request" err 217 | Right request -> 218 | case serveWith (read (RequestBody request)) req res path of 219 | Nothing -> badRoute res 220 | Just eff -> eff 221 | catchException handleError do 222 | onError inputStream handleError 223 | onDataString inputStream UTF8 handleData 224 | onEnd inputStream handleEnd 225 | 226 | -- | `Capture` can be used to capture a part of the route. 227 | -- | 228 | -- | Use a function type with a function 229 | -- | argument of type `Capture`: 230 | -- | 231 | -- | ```purescript 232 | -- | main = quickServe opts echo' where 233 | -- | echo' :: Capture -> GET String 234 | -- | echo' (Capture s) = pure s 235 | -- | ``` 236 | newtype Capture = Capture String 237 | 238 | derive instance newtypeCapture :: Newtype Capture _ 239 | 240 | instance servableCapture 241 | :: Servable service 242 | => Servable (Capture -> service) where 243 | serveWith read req res (part : path) = 244 | serveWith (read (Capture part)) req res path 245 | serveWith _ _ _ _ = Nothing 246 | 247 | sendError 248 | :: Response 249 | -> Int 250 | -> String 251 | -> String 252 | -> Effect Unit 253 | sendError res code msg body = do 254 | let outputStream = responseAsStream res 255 | setHeader res "Content-Type" "text/plain" 256 | setStatusCode res code 257 | setStatusMessage res msg 258 | _ <- writeString outputStream UTF8 body (pure unit) 259 | end outputStream (pure unit) 260 | 261 | badRoute :: Response -> Effect Unit 262 | badRoute res = sendError res 400 "Bad Request" "No such route" 263 | 264 | instance servableRecord :: (RowToList r l, ServableList l r) => Servable (Record r) where 265 | serveWith r = serveListWith (RLProxy :: RLProxy l) r 266 | 267 | class ServableList (l :: RowList) (r :: # Type) | l -> r where 268 | serveListWith 269 | :: RLProxy l 270 | -> Record r 271 | -> Request 272 | -> Response 273 | -> List String 274 | -> Maybe (Effect Unit) 275 | 276 | instance servableListNil :: ServableList Nil () where 277 | serveListWith _ _ _ _ _ = Nothing 278 | 279 | instance servableListCons 280 | :: (IsSymbol route, Servable s, ServableList l r1, Cons route s r1 r) 281 | => ServableList (Cons route s l) r where 282 | serveListWith _ rec req res (actual : xs) 283 | | actual == reflectSymbol (SProxy :: SProxy route) 284 | = serveWith (get (SProxy :: SProxy route) rec :: s) req res xs 285 | serveListWith _ rec req res xs = serveListWith (RLProxy :: RLProxy l) (unsafeCoerce rec) req res xs 286 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | import Data.Generic.Rep (class Generic) 5 | import Data.Maybe (Maybe(..)) 6 | import Effect (Effect) 7 | import Effect.Class (liftEffect) 8 | import Effect.Console (log) 9 | import Foreign.Class (class Decode, class Encode) 10 | import Foreign.Generic (defaultOptions, genericDecode, genericEncode) 11 | import Foreign.Generic.Types (Options) 12 | import QuickServe (Capture(..), GET, JSON(..), POST, RequestBody(..), quickServe) 13 | 14 | newtype Message = Message { message :: String } 15 | 16 | derive instance genericMessage :: Generic Message _ 17 | 18 | jsonOpts :: Options 19 | jsonOpts = defaultOptions { unwrapSingleConstructors = true } 20 | 21 | instance decodeMessage :: Decode Message where 22 | decode = genericDecode jsonOpts 23 | 24 | instance encodeMessage :: Encode Message where 25 | encode = genericEncode jsonOpts 26 | 27 | -- | This will serve three endpoints: 28 | -- | 29 | -- | - `/hello`, which returns the plain text string "Hello World!" 30 | -- | - `/echo1`, which receives a JSON message in a POST body 31 | -- | - `/echo2/`, which receives a plain text message to echo as a path argument 32 | -- | 33 | -- | Each of these can be tested with cURL: 34 | -- | 35 | -- | ``` 36 | -- | curl http://localhost:3000/hello 37 | -- | curl http://localhost:3000/echo1 -XPOST -d '{"message": "test"}' 38 | -- | curl http://localhost:3000/echo2/test 39 | -- | ``` 40 | main :: Effect Unit 41 | main = do 42 | let opts = { hostname: "localhost", port: 3000, backlog: Nothing } 43 | quickServe opts $ 44 | let 45 | echo1 :: RequestBody (JSON Message) 46 | -> POST (JSON Message) 47 | echo1 (RequestBody (JSON (Message { message }))) = do 48 | liftEffect (log message) 49 | pure (JSON (Message { message })) 50 | 51 | echo2 :: Capture -> GET String 52 | echo2 (Capture message) = pure message 53 | 54 | hello :: GET String 55 | hello = pure "Hello, World!" 56 | in { echo1, echo2, hello } 57 | --------------------------------------------------------------------------------