├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── packages.dhall ├── spago.dhall └── src └── Erl ├── Attribute.purs ├── Cowboy.erl ├── Cowboy.purs └── Cowboy ├── Handler.purs ├── Handlers ├── Common.erl ├── Common.purs ├── Loop.erl ├── Loop.purs ├── Rest.erl ├── Rest.purs ├── Simple.erl ├── Simple.purs ├── WebSocket.erl └── WebSocket.purs ├── Req.erl ├── Req.purs ├── Req └── Monad.purs ├── Routes.erl ├── Routes.purs └── Static.purs /.travis.yml: -------------------------------------------------------------------------------- 1 | language: erlang 2 | dist: trusty 3 | sudo: required 4 | node_js: stable 5 | env: 6 | - PATH=$HOME/purescript:$HOME/purerl:$HOME:$PATH PURS_VERSION=v0.13.6 7 | otp_release: 8 | - 23.0 9 | branches: 10 | # Only build master and tagged versions, i.e. not feature branches; feature 11 | # branches already get built after opening a pull request. 12 | only: 13 | - master 14 | - /^v\d+\.\d+(\.\d+)?(-\S*)?$/ 15 | install: 16 | - curl -L https://github.com/purescript/purescript/releases/download/$PURS_VERSION/linux64.tar.gz -o $HOME/purescript.tar.gz 17 | - tar -xvf $HOME/purescript.tar.gz -C $HOME/ 18 | - curl -L https://github.com/purescript/spago/releases/latest/download/linux.tar.gz -o $HOME/spago.tar.gz 19 | - tar -xvf $HOME/spago.tar.gz -C $HOME/ 20 | - curl -L https://github.com/purerl/purerl/releases/latest/download/linux64.tar.gz -o $HOME/purerl.tar.gz 21 | - tar -xvf $HOME/purerl.tar.gz -C $HOME/ 22 | script: 23 | - make test 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2023 Purerl contributors 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 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, 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 THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: ps erl all test 2 | 3 | all: erl 4 | 5 | test: erl 6 | 7 | ps: 8 | spago build 9 | 10 | erl: ps 11 | mkdir -p ebin 12 | erlc -o ebin/ output/*/*.erl 13 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # purescript-erl-cowboy 2 | 3 | Bindings to the [cowboy](https://github.com/ninenines/cowboy) web server. Bindings currently tested against version `2.8`, but other versions may be used subject to underlying cowboy API compatibility. 4 | 5 | 6 | ## Usage 7 | 8 | Firstly this package contains bindings to `cowboy`, it must be used in an OTP application where `cowboy` is installed 9 | at a suitable version. 10 | 11 | To construct a working cowboy application, the definitions in `Erl.Cowboy` can be used with 12 | routing defined in `Erl.Cowboy.Routes`, and one of the handlers defind in submodules of 13 | `Erl.Cowboy.Handlers`. Core request processing is handled in `Erl.Cowboy.Req`. 14 | 15 | Examples can be found in the [pscowboytest](https://github.com/nwolverson/pscowboytest) test project. 16 | -------------------------------------------------------------------------------- /packages.dhall: -------------------------------------------------------------------------------- 1 | let upstream = 2 | https://github.com/purerl/package-sets/releases/download/erl-0.14.3-20210709/packages.dhall sha256:9b07e1fe89050620e2ad7f7623d409f19b5e571f43c2bdb61242377f7b89d941 3 | 4 | let overrides = {=} 5 | 6 | let additions = 7 | { erl-kernel = 8 | { dependencies = 9 | [ "convertable-options" 10 | , "datetime" 11 | , "effect" 12 | , "either" 13 | , "erl-atom" 14 | , "erl-binary" 15 | , "erl-lists" 16 | , "erl-process" 17 | , "erl-tuples" 18 | , "erl-untagged-union" 19 | , "foldable-traversable" 20 | , "foreign" 21 | , "functions" 22 | , "integers" 23 | , "maybe" 24 | , "newtype" 25 | , "partial" 26 | , "prelude" 27 | , "record" 28 | , "typelevel-prelude" 29 | , "unsafe-coerce" 30 | ] 31 | , repo = "https://github.com/id3as/purescript-erl-kernel.git" 32 | , version = "2c1f78a3aa6993e91e342a984c522b87b98bbb2b" 33 | } 34 | , convertable-options = 35 | { repo = "https://github.com/natefaubion/purescript-convertable-options" 36 | , dependencies = [ "effect", "maybe", "record" ] 37 | , version = "f20235d464e8767c469c3804cf6bec4501f970e6" 38 | } 39 | , erl-untagged-union = 40 | { dependencies = 41 | [ "erl-atom" 42 | , "erl-binary" 43 | , "erl-lists" 44 | , "erl-tuples" 45 | , "debug" 46 | , "foreign" 47 | , "typelevel-prelude" 48 | , "maybe" 49 | , "partial" 50 | , "prelude" 51 | , "unsafe-coerce" 52 | ] 53 | , repo = "https://github.com/id3as/purescript-erl-untagged-union.git" 54 | , version = "eb7a10c7930c4b99f1a6bfce767daa814d45dd2b" 55 | } 56 | , erl-ranch = 57 | { dependencies = 58 | [ "convertable-options" 59 | , "effect" 60 | , "either" 61 | , "erl-atom" 62 | , "erl-kernel" 63 | , "erl-lists" 64 | , "erl-maps" 65 | , "erl-otp-types" 66 | , "erl-process" 67 | , "erl-ssl" 68 | , "erl-tuples" 69 | , "exceptions" 70 | , "foreign" 71 | , "maybe" 72 | , "prelude" 73 | , "record" 74 | , "typelevel-prelude" 75 | , "unsafe-coerce" 76 | ] 77 | , repo = "https://github.com/id3as/purescript-erl-ranch.git" 78 | , version = "08a76bd850ba00c3a120c1d149bed07f9fcc165d" 79 | } 80 | , erl-otp-types = 81 | { dependencies = 82 | [ "erl-atom" 83 | , "erl-binary" 84 | , "erl-kernel" 85 | , "foreign" 86 | , "prelude" 87 | , "unsafe-reference" 88 | ] 89 | , repo = "https://github.com/id3as/purescript-erl-otp-types.git" 90 | , version = "6470bc379447c406456e8ef1e6a79c80e3c5e8d1" 91 | } 92 | , erl-ssl = 93 | { dependencies = 94 | [ "convertable-options" 95 | , "datetime" 96 | , "effect" 97 | , "either" 98 | , "maybe" 99 | , "erl-atom" 100 | , "erl-binary" 101 | , "erl-lists" 102 | , "erl-kernel" 103 | , "erl-tuples" 104 | , "erl-logger" 105 | , "erl-otp-types" 106 | , "foreign" 107 | , "maybe" 108 | , "partial" 109 | , "prelude" 110 | , "record" 111 | , "unsafe-reference" 112 | ] 113 | , repo = "https://github.com/id3as/purescript-erl-ssl.git" 114 | , version = "2bd94ce343448406e579425e1b4140a6b6dd7de0" 115 | } 116 | , unsafe-reference = 117 | { repo = "https://github.com/purerl/purescript-unsafe-reference.git" 118 | , dependencies = [ "prelude" ] 119 | , version = "464ee74d0c3ef50e7b661c13399697431f4b6251" 120 | } 121 | } 122 | 123 | 124 | in upstream // overrides // additions 125 | -------------------------------------------------------------------------------- /spago.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to a Spago project! 3 | You can edit this file as you like. 4 | -} 5 | { name = "purescript-erl-cowboy" 6 | , dependencies = 7 | [ "effect" 8 | , "either" 9 | , "erl-atom" 10 | , "erl-binary" 11 | , "erl-kernel" 12 | , "erl-lists" 13 | , "erl-maps" 14 | , "erl-modules" 15 | , "erl-ranch" 16 | , "erl-ssl" 17 | , "erl-tuples" 18 | , "foreign" 19 | , "functions" 20 | , "maybe" 21 | , "prelude" 22 | , "record" 23 | , "transformers" 24 | , "tuples" 25 | , "unsafe-coerce" 26 | ] 27 | , packages = ./packages.dhall 28 | , sources = [ "src/**/*.purs" ] 29 | , backend = "purerl" 30 | } 31 | -------------------------------------------------------------------------------- /src/Erl/Attribute.purs: -------------------------------------------------------------------------------- 1 | -- | Representation of erlang attributes with symbols and compiler magic. 2 | module Attribute where 3 | 4 | -- | An attribute with specified name and content 5 | data Attribute (name :: Symbol) (content :: Symbol) = Attribute 6 | 7 | -- | A behaviour attribute, e.g. ```Behaviour "gen_server"``` 8 | type Behaviour = Attribute "behaviour" 9 | -------------------------------------------------------------------------------- /src/Erl/Cowboy.erl: -------------------------------------------------------------------------------- 1 | -module(erl_cowboy@foreign). 2 | -export([startClear_/3, startTls_/3, stopListener/1]). 3 | 4 | startClear_(Name, TransOpts, ProtoOpts) -> 5 | fun () -> 6 | case cowboy:start_clear(Name, TransOpts, ProtoOpts) of 7 | {ok, _Pid} -> {right, unit}; 8 | {error, Reason} -> {left, Reason} 9 | end 10 | end. 11 | 12 | startTls_(Name, TransOpts, ProtoOpts) -> 13 | fun () -> 14 | case cowboy:start_tls(Name, TransOpts, ProtoOpts) of 15 | {ok, _Pid} -> {right, unit}; 16 | {error, Reason} -> {left, Reason} 17 | end 18 | end. 19 | 20 | stopListener(Name) -> 21 | fun() -> 22 | cowboy:stop_listener(Name), 23 | unit 24 | end. 25 | -------------------------------------------------------------------------------- /src/Erl/Cowboy.purs: -------------------------------------------------------------------------------- 1 | -- | Bindings for `cowboy`. 2 | -- | 3 | -- | To construct a working cowboy application, the definitions here can be used with 4 | -- | routing defined in `Erl.Cowboy.Routes`, and one of the handlers defind in submodules of 5 | -- | `Erl.Cowboy.Handlers`. Core request processing is handled in `Erl.Cowboy.Req`. 6 | module Erl.Cowboy 7 | ( 8 | ProtocolOpts, 9 | dispatch, 10 | Env, 11 | startClear, 12 | startTls, 13 | stopListener, 14 | defaultOptions 15 | ) where 16 | 17 | import Prelude 18 | 19 | import Data.Either (Either) 20 | import Data.Maybe (Maybe(..), maybe, maybe') 21 | import Effect (Effect) 22 | import Erl.Atom (Atom, atom) 23 | import Erl.Cowboy.Routes (Dispatch) 24 | import Erl.Data.List (List) 25 | import Erl.Data.Map (Map) 26 | import Erl.Data.Map as Map 27 | import Erl.Kernel.Inet as Inet 28 | import Erl.Kernel.Tcp as Tcp 29 | import Erl.ModuleName (NativeModuleName) 30 | import Erl.Ranch as Ranch 31 | import Erl.Ssl as Ssl 32 | import Foreign (Foreign, unsafeToForeign) 33 | import Foreign as Foreign 34 | import Record as Record 35 | import Type.Proxy (Proxy(..)) 36 | 37 | foreign import startClear_ :: Atom -> Foreign -> Map Atom Foreign -> Effect (Either Foreign Unit) 38 | foreign import startTls_ :: Atom -> Foreign -> Map Atom Foreign -> Effect (Either Foreign Unit) 39 | 40 | type RanchOptions socketOpts = 41 | ( 42 | socket_opts :: Maybe (Record socketOpts) 43 | | 44 | Ranch.Options 45 | ) 46 | 47 | defaultOptions :: forall a. Record (RanchOptions a) 48 | defaultOptions = Record.insert (Proxy :: _ "socket_opts") Nothing Ranch.defaultOptions 49 | 50 | type TcpOptions = Record (RanchOptions (Tcp.ListenOptions)) 51 | type SslOptions = Record (RanchOptions (Ssl.ListenOptions)) 52 | 53 | startClear :: Atom -> TcpOptions -> ProtocolOpts -> Effect (Either Foreign Unit) 54 | startClear name options protoOpts = 55 | let 56 | socketOptions = Inet.optionsToErl <<< Ranch.excludeOptions <$> options.socket_opts 57 | withoutSocketOptions = Record.delete (Proxy :: _ "socket_opts") options 58 | erlOptions = maybe' (\_ -> Ranch.optionsToErl withoutSocketOptions) (\opts -> Ranch.optionsToErl $ Record.insert (Proxy :: _ "socket_opts") opts withoutSocketOptions) socketOptions 59 | in 60 | startClear_ name erlOptions (convertProtocolOpts protoOpts) 61 | 62 | 63 | startTls :: Atom -> SslOptions -> ProtocolOpts -> Effect (Either Foreign Unit) 64 | startTls name options protoOpts = 65 | let 66 | socketOptions = Inet.optionsToErl <<< Ranch.excludeOptions <$> options.socket_opts 67 | withoutSocketOptions = Record.delete (Proxy :: _ "socket_opts") options 68 | erlOptions = maybe' (\_ -> Ranch.optionsToErl withoutSocketOptions) (\opts -> Ranch.optionsToErl $ Record.insert (Proxy :: _ "socket_opts") opts withoutSocketOptions) socketOptions 69 | in 70 | startTls_ name erlOptions (convertProtocolOpts protoOpts) 71 | 72 | 73 | foreign import stopListener :: Atom -> Effect Unit 74 | 75 | type Env = Map Atom Foreign 76 | 77 | type ProtocolOpts = 78 | { env :: Maybe Env 79 | , middlewares :: Maybe (List NativeModuleName) 80 | , streamHandlers :: Maybe (List NativeModuleName) 81 | } 82 | 83 | dispatch :: Dispatch -> Env -> Env 84 | dispatch = Map.insert (atom "dispatch") <<< Foreign.unsafeToForeign 85 | 86 | convertProtocolOpts :: ProtocolOpts -> Map Atom Foreign 87 | convertProtocolOpts { env, middlewares, streamHandlers } = 88 | Map.empty 89 | # opt "env" env 90 | # opt "middlewares" middlewares 91 | # opt "stream_handlers" streamHandlers 92 | where 93 | opt :: forall a. String -> Maybe a -> Map Atom Foreign -> Map Atom Foreign 94 | opt str = maybe identity (Map.insert (atom str) <<< unsafeToForeign) 95 | -------------------------------------------------------------------------------- /src/Erl/Cowboy/Handler.purs: -------------------------------------------------------------------------------- 1 | -- | Cowboy handlers. 2 | -- | 3 | -- | Submodules of `Erl.Cowboy.Handler` each present a number of type abbreviations which match the required callback methods for a cowboy behaviour/callback module, 4 | -- | along with bindings to construct/destruct native cowboy types where appropriate. 5 | -- | 6 | -- | To correctly define a cowboy callback module the correct named bindings must be present at the top level with the appropriate types, if the 7 | -- | `EffectFnX` based types in the handler modules are used along with correctly named top level bindings this should all work out, due to the way the 8 | -- | purerl compiler generates code for uncurried function overloads of `EffectFnX` and `FnX` types. A no-op behaviour 9 | -- | function is provided in each handler module to collect the mandatory callbacks with the correct names and types, *if* this is filled in with direct 10 | -- | reference to top-level bindings, "this should all work out". It cannot be stressed enough this is all "assistive" optional make-believe, the value-level 11 | -- | implementation of `whateverBehaviour` is a constant which will be ignored, all that matters is that you define values at the top level with the right names 12 | -- | and types that ensure they get compiled to Erlang functions of the correct arity and behaviour. 13 | -- | 14 | -- | An example for `Erl.Cowboy.Handlers.WebSocket`: 15 | -- | 16 | -- | ```purescript 17 | -- | _behaviour :: CowboyWebsocketBehaviour 18 | -- | _behaviour = cowboyWebsocketBehaviour { init, websocket_handle, websocket_info } 19 | -- | 20 | -- | init :: InitHandler Config HandlerState 21 | -- | init = ... 22 | -- | ``` 23 | -- | 24 | -- | This module also contains utilities to assist in defing handlers using a the state monad transfomer. See `Erl.Cowboy.Req.Monad` for related convenience wrappers 25 | -- | for working with request objects inside a state monad. 26 | module Erl.Cowboy.Handler where 27 | 28 | import Prelude 29 | 30 | import Control.Monad.State (StateT, runStateT) 31 | import Data.Tuple (uncurry) 32 | import Effect (Effect) 33 | import Erl.Cowboy.Req (Req) 34 | 35 | type HandlerM = StateT Req Effect 36 | 37 | runHandlerM :: forall a b. (a -> Req -> b) -> HandlerM a -> Req -> Effect b 38 | runHandlerM res h req = uncurry res <$> runStateT h req 39 | -------------------------------------------------------------------------------- /src/Erl/Cowboy/Handlers/Common.erl: -------------------------------------------------------------------------------- 1 | -module(erl_cowboy_handlers_common@foreign). 2 | -export([decodeReasonImpl/6, terminateResult/0]). 3 | 4 | decodeReasonImpl(Normal, Crash, Error, Exit, Throw, Reason) -> 5 | case Reason of 6 | normal -> Normal; 7 | { crash, error, _ } -> Crash(Error); 8 | { crash, exit, _ } -> Crash(Exit); 9 | { crash, throw, _ } -> Crash(Throw) 10 | end. 11 | 12 | terminateResult() -> ok. -------------------------------------------------------------------------------- /src/Erl/Cowboy/Handlers/Common.purs: -------------------------------------------------------------------------------- 1 | -- | Types/conversions shared between several callback handler behaviours 2 | module Erl.Cowboy.Handlers.Common 3 | ( CrashType(..) 4 | , TerminateReason(..) 5 | , decodeReason 6 | , RawReason 7 | , TerminateResult 8 | , terminateResult 9 | ) 10 | where 11 | 12 | data CrashType = Error | Exit | Throw 13 | 14 | -- | Reason for a crash. The Reason :: any() is currently discarded 15 | data TerminateReason = Normal | Crash CrashType 16 | 17 | foreign import data RawReason :: Type 18 | 19 | foreign import decodeReasonImpl :: TerminateReason -> (CrashType -> TerminateReason) -> CrashType -> CrashType -> CrashType -> RawReason -> TerminateReason 20 | 21 | decodeReason :: RawReason -> TerminateReason 22 | decodeReason = decodeReasonImpl Normal Crash Error Exit Throw 23 | 24 | foreign import data TerminateResult :: Type 25 | 26 | foreign import terminateResult :: TerminateResult -------------------------------------------------------------------------------- /src/Erl/Cowboy/Handlers/Loop.erl: -------------------------------------------------------------------------------- 1 | -module(erl_cowboy_handlers_loop@foreign). 2 | -export([initResult/2, hibernate/2, continueHibernate/2, continue/2, stop/2]). 3 | initResult(S, Req) -> {cowboy_loop, Req, S}. 4 | hibernate(S, Req) -> {cowboy_loop, Req, S, hibernate}. 5 | 6 | continue(S, Req) -> {ok, Req, S}. 7 | continueHibernate(S, Req) -> {ok, Req, S, hibernate}. 8 | stop(S, Req) -> {stop, Req, S}. -------------------------------------------------------------------------------- /src/Erl/Cowboy/Handlers/Loop.purs: -------------------------------------------------------------------------------- 1 | -- | Types and handlers for a cowboy_loop loop handler callback module. 2 | module Erl.Cowboy.Handlers.Loop ( 3 | InitResult 4 | , InitHandler 5 | , initResult 6 | , hibernate 7 | , InfoResult 8 | , InfoHandler 9 | , continue 10 | , continueHibernate 11 | , stop 12 | , module C 13 | , TerminateHandler 14 | , CowboyLoopBehaviour 15 | , cowboyLoopBehaviour 16 | ) where 17 | 18 | import Attribute (Attribute(..), Behaviour) 19 | import Effect.Uncurried (EffectFn2, EffectFn3) 20 | import Erl.Cowboy.Handlers.Common (CrashType(..), RawReason, TerminateReason(..), TerminateResult, decodeReason, terminateResult) as C 21 | import Erl.Cowboy.Req (Req) 22 | 23 | foreign import data InitResult :: Type -> Type 24 | 25 | foreign import initResult :: forall a. a -> Req -> InitResult a 26 | foreign import hibernate :: forall a. a -> Req -> InitResult a 27 | 28 | type InitHandler c s = EffectFn2 Req c (InitResult s) 29 | 30 | foreign import data InfoResult :: Type -> Type 31 | 32 | -- | ok response 33 | foreign import continue :: forall a. a -> Req -> InfoResult a 34 | 35 | -- | ok, hibernate response 36 | foreign import continueHibernate :: forall a. a -> Req -> InfoResult a 37 | 38 | -- | stop response 39 | foreign import stop :: forall a. a -> Req -> InfoResult a 40 | 41 | type InfoHandler a s = EffectFn3 a Req s (InfoResult s) 42 | 43 | type TerminateHandler s = EffectFn3 C.TerminateReason Req s C.TerminateResult 44 | 45 | type CowboyLoopBehaviour = Behaviour "cowboy_loop" 46 | 47 | -- | A cowboy_loop behaviour. A terminate callback is optional. 48 | cowboyLoopBehaviour :: forall a s. 49 | { init :: InitHandler a s 50 | , info :: InfoHandler a s 51 | } -> CowboyLoopBehaviour 52 | cowboyLoopBehaviour _ = Attribute -------------------------------------------------------------------------------- /src/Erl/Cowboy/Handlers/Rest.erl: -------------------------------------------------------------------------------- 1 | -module(erl_cowboy_handlers_rest@foreign). 2 | -export([initResult/2, restResult/3, stop/2, switchHandler/3, contentTypesAcceptedResult/1, contentTypesProvidedResult/1, authorized/0, unauthorized/1, notMoved/0, moved/1, optionsResponse/0]). 3 | 4 | initResult(S, Req) -> {cowboy_rest, Req, S}. 5 | 6 | restResult(R, S, Req) -> {R, Req, S}. 7 | 8 | stop(S, Req) -> {stop, Req, S}. 9 | 10 | switchHandler(Module, State, Req) -> {{switch_handler, Module}, Req, State}. 11 | 12 | convertContentType({{simpleContentType, ContentType}, CB}) -> 13 | {ContentType, CB}; 14 | 15 | convertContentType({{contentType, T, ST, Params}, CB}) -> 16 | Params1 = case Params of 17 | {anyParams} -> '*'; 18 | {contentTypeParams, ActualParams} -> ActualParams 19 | end, 20 | {{T, ST, Params1}, CB}. 21 | 22 | contentTypesAcceptedResult(List) -> lists:map(fun convertContentType/1, List). 23 | contentTypesProvidedResult(List) -> lists:map(fun convertContentType/1, List). 24 | 25 | authorized() -> true. 26 | unauthorized(Header) -> {false, Header}. 27 | 28 | notMoved() -> false. 29 | moved(Uri) -> {true, Uri}. 30 | 31 | optionsResponse() -> ok. 32 | -------------------------------------------------------------------------------- /src/Erl/Cowboy/Handlers/Rest.purs: -------------------------------------------------------------------------------- 1 | module Erl.Cowboy.Handlers.Rest 2 | 3 | where 4 | 5 | import Attribute (Attribute(..), Behaviour) 6 | import Effect.Uncurried (EffectFn2, EffectFn3) 7 | import Erl.Atom (Atom) 8 | import Erl.Cowboy.Handlers.Common as C 9 | import Erl.Cowboy.Req (Req) 10 | import Erl.Data.List (List) 11 | import Erl.Data.Tuple (Tuple2) 12 | import Erl.ModuleName (NativeModuleName) 13 | 14 | foreign import data InitResult :: Type -> Type 15 | 16 | foreign import initResult :: forall a. a -> Req -> InitResult a 17 | 18 | type InitHandler c s = EffectFn2 Req c (InitResult s) 19 | 20 | type TerminateHandler s = EffectFn3 C.TerminateReason Req s C.TerminateResult 21 | 22 | -- | RestResult r s is the result of a rest callback with result r and state s 23 | foreign import data RestResult :: Type -> Type -> Type 24 | 25 | foreign import restResult :: forall r s. r -> s -> Req -> RestResult r s 26 | 27 | foreign import stop :: forall r s. s -> Req -> RestResult r s 28 | 29 | foreign import switchHandler :: forall r s. NativeModuleName -> s -> Req -> RestResult r s 30 | 31 | type RestHandler r s = EffectFn2 Req s (RestResult r s) 32 | 33 | -- | Handler for allowed_methods callback 34 | type AllowedMethodsHandler s = RestHandler (List String) s 35 | 36 | -- | Handler for allow_missing_post callback 37 | type AllowedMissingPostHandler s = RestHandler Boolean s 38 | 39 | -- | Handler for charsets_provided callback 40 | type CharsetsProvidedHandler s = RestHandler (List String) s 41 | 42 | data ContentType = ContentType String String ContentTypeParams | SimpleContentType String 43 | 44 | data ContentTypeParams = AnyParams | ContentTypeParams (List (Tuple2 String String)) 45 | 46 | foreign import data ContentTypesAcceptedResult :: Type 47 | 48 | -- foreign import data AcceptCallbackResult :: Type -> Type 49 | 50 | -- type AcceptCallback s = EffectFn2 Req s (AcceptCallbackResult s) 51 | 52 | newtype AcceptCallback = AcceptCallback Atom 53 | 54 | foreign import contentTypesAcceptedResult :: List (Tuple2 ContentType AcceptCallback) -> ContentTypesAcceptedResult 55 | 56 | -- | Handler for content_types_accepted callback 57 | type ContentTypesAcceptedHandler s = RestHandler ContentTypesAcceptedResult s 58 | 59 | foreign import data ContentTypesProvidedResult :: Type 60 | 61 | -- foreign import data ProvideCallbackResult :: Type -> Type 62 | 63 | -- type ProvideCallback s = EffectFn2 Req s (ProvideCallbackResult s) 64 | 65 | newtype ProvideCallback = ProvideCallback Atom 66 | 67 | foreign import contentTypesProvidedResult :: List (Tuple2 ContentType ProvideCallback) -> ContentTypesProvidedResult 68 | 69 | -- | Handler for content_types_provided callback 70 | type ContentTypesProvidedHandler s = RestHandler ContentTypesProvidedResult s 71 | 72 | -- | Handler for delete_completed callback 73 | type DeleteCompletedHandler s = RestHandler Boolean s 74 | 75 | -- | Handler for delete_resource callback 76 | type DeleteResourceHandler s = RestHandler Boolean s 77 | 78 | -- TODO: Representation of calendar:datetime() 79 | -- | Handler for expires callback 80 | -- type ExpiresCallback = RestHandler 81 | 82 | -- | Handler for forbidden callback 83 | type ForbiddenHandler s = RestHandler Boolean s 84 | 85 | -- | Strong or weak etag 86 | data ETag = Strong String | Weak String 87 | 88 | -- | Handler for generate_etag callback 89 | type GenerateEtagHandler s = RestHandler ETag s 90 | 91 | foreign import data IsAuthorizedResponse :: Type 92 | 93 | foreign import authorized :: IsAuthorizedResponse 94 | foreign import unauthorized :: String -> IsAuthorizedResponse 95 | 96 | -- | Handler for is_authorized callback 97 | type IsAuthorizedHandler s = RestHandler IsAuthorizedResponse s 98 | 99 | -- | Handler for _ callback 100 | type IsConflictHandler s = RestHandler Boolean s 101 | 102 | -- | Handler for _ callback 103 | type KnownMethodsHandler s = RestHandler (List String) s 104 | 105 | -- | Handler for _ callback 106 | type LanguagesProvidedHandler s = RestHandler (List String) s 107 | 108 | -- TODO date 109 | -- | Handler for _ callback 110 | -- type LastModifiedHandler s = RestHandler ? 111 | 112 | -- | Handler for _ callback 113 | type MalformedRequestHandler s = RestHandler Boolean s 114 | 115 | 116 | foreign import data MovedResult :: Type 117 | 118 | foreign import notMoved :: MovedResult 119 | 120 | foreign import moved :: String -> MovedResult 121 | 122 | -- | Handler for moved_permanently callback 123 | type MovedPermanentlyHandler s = RestHandler MovedResult s 124 | 125 | -- | Handler for moved_temporarily callback 126 | type MovedTemporarilyHandler s = RestHandler MovedResult s 127 | 128 | -- | Handler for multiple_choices callback 129 | type MultipleChoicesHandler s = RestHandler Boolean s 130 | 131 | foreign import data OptionsResponse :: Type 132 | 133 | foreign import optionsResponse :: OptionsResponse 134 | 135 | -- | Handler for options callback 136 | type OptionsHandler s = RestHandler OptionsResponse s 137 | 138 | -- | Handler for previously_existed callback 139 | type PreviouslyExistedHandler s = RestHandler Boolean s 140 | 141 | -- | Handler for resource_exists callback 142 | type ResourceExistsHandler s = RestHandler Boolean s 143 | 144 | -- | Handler for service_available callback 145 | type ServiceAvailableHandler s = RestHandler Boolean s 146 | 147 | -- | Handler for uri_too_long callback 148 | type UriTooLongHandler s = RestHandler Boolean s 149 | 150 | -- | Handler for valid_content_headers callback 151 | type ValidContentHeadersHandler s = RestHandler Boolean s 152 | 153 | -- | Handler for valid_entity_length callback 154 | type ValidEntityLengthHandler s = RestHandler Boolean s 155 | 156 | -- | Handler for variances callback 157 | type VariancesHandler s = RestHandler (List String) s 158 | 159 | type CowboyRestBehaviour = Behaviour "cowboy_rest" 160 | 161 | -- | A cowboy_rest behaviour. Note that while may callbacks are defined only init is mandatory 162 | cowboyRestBehaviour :: forall a s. 163 | { init :: InitHandler a s 164 | } -> CowboyRestBehaviour 165 | cowboyRestBehaviour _ = Attribute 166 | -------------------------------------------------------------------------------- /src/Erl/Cowboy/Handlers/Simple.erl: -------------------------------------------------------------------------------- 1 | -module(erl_cowboy_handlers_simple@foreign). 2 | -export([initResult/2]). 3 | 4 | initResult(S, Req) -> {ok, Req, S}. 5 | 6 | 7 | -------------------------------------------------------------------------------- /src/Erl/Cowboy/Handlers/Simple.purs: -------------------------------------------------------------------------------- 1 | -- | Types and helpers for a cowboy_handler "Plain HTTP handler" callback module 2 | module Erl.Cowboy.Handlers.Simple ( 3 | InitResult 4 | , InitHandler 5 | , initResult 6 | , TerminateHandler 7 | , module C 8 | , CowboyHandlerBehaviour 9 | , cowboyHandlerBehaviour 10 | ) where 11 | 12 | import Attribute (Attribute(..), Behaviour) 13 | import Effect.Uncurried (EffectFn2, EffectFn3) 14 | import Erl.Cowboy.Handlers.Common (CrashType(..), RawReason, TerminateReason(..), TerminateResult, decodeReason, terminateResult) as C 15 | import Erl.Cowboy.Req (Req) 16 | 17 | foreign import data InitResult :: Type -> Type 18 | 19 | foreign import initResult :: forall a. a -> Req -> InitResult a 20 | 21 | type InitHandler c s = EffectFn2 Req c (InitResult s) 22 | 23 | type TerminateHandler s = EffectFn3 C.TerminateReason Req s C.TerminateResult 24 | 25 | type CowboyHandlerBehaviour = Behaviour "cowboy_handler" 26 | 27 | -- | A simple cowboy_handler behaviour. A terminate callback is optional. 28 | cowboyHandlerBehaviour :: forall a s. { init :: InitHandler a s } -> CowboyHandlerBehaviour 29 | cowboyHandlerBehaviour _ = Attribute -------------------------------------------------------------------------------- /src/Erl/Cowboy/Handlers/WebSocket.erl: -------------------------------------------------------------------------------- 1 | -module(erl_cowboy_handlers_webSocket@foreign). 2 | -export([initResult/2, okResult/1, hibernateResult/1, replyResult/2, replyAndHibernateResult/2, stopResult/1, decodeReasonImpl/17, decodeInFrameImpl/5, encodeOutFrameImpl/1]). 3 | 4 | okResult(S) -> {ok, S}. 5 | 6 | hibernateResult(S) -> {ok, S, hibernate}. 7 | 8 | replyResult(S, Frames) -> {reply, Frames, S}. 9 | 10 | replyAndHibernateResult(S, Frames) -> {reply, Frames, S, hibernate}. 11 | 12 | initResult(S, Req) -> {cowboy_websocket, Req, S}. 13 | 14 | stopResult(S) -> {stop, S}. 15 | 16 | decodeReasonImpl(Normal, 17 | Remote, 18 | Nothing, 19 | Just, 20 | RemotePayload, 21 | Stop, 22 | Timeout, 23 | Crash, 24 | CrashError, 25 | CrashExit, 26 | CrashThrow, 27 | Error, 28 | BadEncoding, 29 | BadFrame, 30 | Closed, 31 | OtherError, 32 | Reason) -> 33 | case Reason of 34 | normal -> Normal; 35 | remote -> Remote(Nothing); 36 | {remote, Code, Payload} -> Remote(Just( (RemotePayload(Code))(Payload) )); 37 | stop -> Stop; 38 | timeout -> Timeout; 39 | { crash, error, _ } -> Crash(CrashError); 40 | { crash, exit, _ } -> Crash(CrashExit); 41 | { crash, throw, _ } -> Crash(CrashThrow); 42 | { error, badencoding } -> Error(BadEncoding); 43 | { error, badframe } -> Error(BadFrame); 44 | { error, closed } -> Error(Closed); 45 | { error, X } -> Error(OtherError(X)) 46 | end. 47 | 48 | decodeInFrameImpl(Text, Binary, Ping, Pong, Frame) -> 49 | case Frame of 50 | {text, B} -> Text(B); 51 | {binary, B} -> Binary(B); 52 | {ping, B} -> Ping(B); 53 | {pong, B} -> Pong(B); 54 | ping -> Ping(<<>>); 55 | pong -> Pong(<<>>) 56 | end. 57 | 58 | encodeOutFrameImpl(FromFrame) -> 59 | FromFrame( 60 | fun (B) -> {text, B} end, 61 | fun (B) -> {binary, B} end, 62 | fun (B) -> {ping, B} end, 63 | fun (B) -> {pong, B} end 64 | ). 65 | -------------------------------------------------------------------------------- /src/Erl/Cowboy/Handlers/WebSocket.purs: -------------------------------------------------------------------------------- 1 | -- | Types and helpers for a cowboy_websocket Websockets callback module 2 | -- | 3 | -- | See `Erl.Cowboy.Handlers`. 4 | -- | 5 | -- | Example: 6 | -- | ```purescript 7 | -- | _behaviour :: CowboyWebsocketBehaviour 8 | -- | _behaviour = cowboyWebsocketBehaviour { init, websocket_handle, websocket_info } 9 | -- | 10 | -- | data Config 11 | -- | data HandlerState 12 | -- | 13 | -- | init :: InitHandler Config HandlerState 14 | -- | init = ... 15 | -- | websocket_handle :: FrameHandler HandlerState 16 | -- | websocket_handle = ... 17 | -- | websocket_info :: InfoHandler HandlerState 18 | -- | websocket_info = ... 19 | -- | ``` 20 | module Erl.Cowboy.Handlers.WebSocket ( 21 | InitResult 22 | , InitHandler 23 | , initResult 24 | , FrameHandler 25 | , Frame(..) 26 | , InFrame 27 | , decodeInFrame 28 | , OutFrame 29 | , outFrame 30 | , CallResult 31 | , okResult 32 | , hibernateResult 33 | , replyResult 34 | , replyAndHibernateResult 35 | , stopResult 36 | , WSInitHandler 37 | , InfoHandler 38 | , TerminateHandler 39 | , TerminateReason(..) 40 | , RemotePayload(..) 41 | , TerminateError(..) 42 | , CloseCode(..) 43 | , RawTerminateReason 44 | , decodeReason 45 | , PartialReq 46 | , CowboyWebsocketBehaviour 47 | , cowboyWebsocketBehaviour 48 | ) where 49 | 50 | import Attribute (Attribute(..), Behaviour) 51 | import Data.Function.Uncurried (Fn4, mkFn4) 52 | import Data.Maybe (Maybe(..)) 53 | import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn3) 54 | import Erl.Atom (Atom) 55 | import Erl.Cowboy.Handlers.Common (CrashType(..), TerminateResult) as C 56 | import Erl.Cowboy.Req (Req) 57 | import Erl.Data.Binary (Binary) 58 | import Erl.Data.List (List) 59 | 60 | foreign import data InitResult :: Type -> Type 61 | 62 | foreign import initResult :: forall a. a -> Req -> InitResult a 63 | 64 | -- | Init handler to upgrade to cowboy_websocket -- init() 65 | type InitHandler c s = EffectFn2 Req c (InitResult s) 66 | 67 | data Frame = 68 | TextFrame String 69 | | BinaryFrame Binary 70 | | PingFrame Binary 71 | | PongFrame Binary 72 | 73 | foreign import data InFrame :: Type 74 | 75 | foreign import decodeInFrameImpl :: 76 | (String -> Frame) 77 | -> (Binary -> Frame) 78 | -> (Binary -> Frame) 79 | -> (Binary -> Frame) 80 | -> InFrame 81 | -> Frame 82 | 83 | decodeInFrame :: InFrame -> Frame 84 | decodeInFrame = decodeInFrameImpl TextFrame BinaryFrame PingFrame PongFrame 85 | 86 | foreign import data OutFrame :: Type 87 | 88 | foreign import encodeOutFrameImpl :: (Fn4 89 | (String -> OutFrame) 90 | (Binary -> OutFrame) 91 | (Binary -> OutFrame) 92 | (Binary -> OutFrame) 93 | OutFrame) 94 | -> OutFrame 95 | 96 | -- | TODO: Can also output iodata() versions, but input always binary 97 | outFrame :: Frame -> OutFrame 98 | outFrame frame = encodeOutFrameImpl (mkFn4 \text binary ping pong -> 99 | case frame of 100 | TextFrame x -> text x 101 | BinaryFrame x -> binary x 102 | PingFrame x -> ping x 103 | PongFrame x -> pong x 104 | ) 105 | 106 | foreign import data CallResult :: Type -> Type 107 | 108 | foreign import okResult :: forall s. s -> CallResult s 109 | 110 | foreign import hibernateResult :: forall s. s -> CallResult s 111 | 112 | foreign import replyResult :: forall s. s -> List OutFrame -> CallResult s 113 | 114 | foreign import replyAndHibernateResult :: forall s. s -> List OutFrame -> CallResult s 115 | 116 | foreign import stopResult :: forall s. s -> CallResult s 117 | 118 | -- | Optional WS init handler (post-upgrade run in websocket process - websocket_init()) 119 | type WSInitHandler s = EffectFn1 s (CallResult s) 120 | 121 | -- | Main frame handler - websocket_handle() 122 | type FrameHandler s = EffectFn2 InFrame s (CallResult s) 123 | 124 | -- | Handler for erlang info messages - websocket_info() 125 | type InfoHandler a s = EffectFn2 a s (CallResult s) 126 | 127 | -- | Cowboy does not provide the full Req object to terminate, so currently completely opaque 128 | foreign import data PartialReq :: Type 129 | 130 | -- | ws:close_code() :: 1000..1003 | 1006..1011 | 3000..4999 131 | newtype CloseCode = CloseCode Int 132 | data RemotePayload = RemotePayload CloseCode Binary 133 | 134 | data TerminateError = 135 | BadEncoding 136 | | BadFrame 137 | | Closed 138 | | OtherError Atom 139 | data TerminateReason = 140 | Normal 141 | | Remote (Maybe RemotePayload) 142 | | Stop 143 | | Timeout 144 | | Crash C.CrashType 145 | | Error TerminateError 146 | 147 | -- | This is different from other callback modules terminate reasons 148 | foreign import data RawTerminateReason :: Type 149 | 150 | foreign import decodeReasonImpl 151 | :: TerminateReason 152 | -> (Maybe RemotePayload -> TerminateReason) 153 | -> (RemotePayload -> Maybe RemotePayload) 154 | -> Maybe RemotePayload 155 | -> (CloseCode -> Binary -> RemotePayload) 156 | -> TerminateReason 157 | -> TerminateReason 158 | -> (C.CrashType -> TerminateReason) 159 | -> C.CrashType 160 | -> C.CrashType 161 | -> C.CrashType 162 | -> (TerminateError -> TerminateReason) 163 | -> TerminateError 164 | -> TerminateError 165 | -> TerminateError 166 | -> (Atom -> TerminateError) 167 | -> RawTerminateReason 168 | -> TerminateReason 169 | 170 | decodeReason :: RawTerminateReason -> TerminateReason 171 | decodeReason = decodeReasonImpl Normal Remote Just Nothing RemotePayload Stop Timeout Crash C.Error C.Exit C.Throw Error BadEncoding BadFrame Closed OtherError 172 | 173 | type TerminateHandler s = EffectFn3 TerminateReason PartialReq s C.TerminateResult 174 | 175 | type CowboyWebsocketBehaviour = Behaviour "cowboy_websocket" 176 | 177 | cowboyWebsocketBehaviour :: forall a i s. 178 | { init :: InitHandler a s 179 | , websocket_handle :: FrameHandler s 180 | , websocket_info :: InfoHandler i s 181 | } -> CowboyWebsocketBehaviour 182 | cowboyWebsocketBehaviour _ = Attribute -------------------------------------------------------------------------------- /src/Erl/Cowboy/Req.erl: -------------------------------------------------------------------------------- 1 | -module(erl_cowboy_req@foreign). 2 | -export([reply/4,replyWithoutBody/3,replyWithFile/4,replyStatus/2,method/1,versionImpl/4,scheme/1,bindingWithDefault/3,bindingImpl/4,pathInfo/1,host/1,port/1,path/1,qs/1,headerImpl/4,headers/1,setHeader/3,setBody/2, setCookie/3, setCookieWithOpts/4, peer/1, readBodyImpl/3, readUrlEncodedBodyImpl/2, streamReply/3, streamBody/2, streamBodyFinal/2, parseCookies/1, setIdleTimeout_/2]). 3 | -include_lib("kernel/include/file.hrl"). 4 | 5 | reply(Status, Headers, Body, Req) -> fun () -> cowboy_req:reply(Status, Headers, Body, Req) end. 6 | 7 | replyWithFile(Status, Headers, Filename, Req) -> fun () -> 8 | {ok, #file_info{size = Size}} = file:read_file_info(Filename), 9 | cowboy_req:reply(Status, Headers, {sendfile, 0, Size, Filename}, Req) 10 | end. 11 | 12 | replyWithoutBody(Status, Headers, Req) -> fun () -> cowboy_req:reply(Status, Headers, Req) end. 13 | 14 | replyStatus(Status, Req) -> fun () -> cowboy_req:reply(Status, Req) end. 15 | 16 | method(Req) -> cowboy_req:method(Req). 17 | 18 | versionImpl(V10, V11, V20, Req) -> case cowboy_req:version(Req) of 19 | 'HTTP/1.0' -> V10; 20 | 'HTTP/1.1' -> V11; 21 | 'HTTP/2' -> V20 22 | end. 23 | 24 | scheme(Req) -> cowboy_req:scheme(Req). 25 | 26 | bindingWithDefault(Name, Req, Default) -> 27 | cowboy_req:binding(Name, Req, Default). 28 | 29 | bindingImpl(Nothing, Just, Name, Req) -> 30 | case cowboy_req:binding(Name, Req) of 31 | undefined -> Nothing; 32 | Val -> Just(Val) 33 | end. 34 | 35 | pathInfo(Req) -> cowboy_req:path_info(Req). 36 | 37 | host(Req) -> cowboy_req:host(Req). 38 | 39 | port(Req) -> cowboy_req:port(Req). 40 | 41 | path(Req) -> cowboy_req:path(Req). 42 | 43 | qs(Req) -> cowboy_req:qs(Req). 44 | 45 | headerImpl(Nothing, Just, H, Req) -> case cowboy_req:header(H, Req) of 46 | undefined -> Nothing; 47 | Val -> Just(Val) 48 | end. 49 | 50 | headers(Req) -> cowboy_req:headers(Req). 51 | 52 | setHeader(Name, Value, Req) -> cowboy_req:set_resp_header(Name, Value, Req). 53 | 54 | setCookieWithOpts(Name, Value, Opts, Req) -> cowboy_req:set_resp_cookie(Name, Value, Req, Opts). 55 | 56 | setCookie(Name, Value, Req) -> cowboy_req:set_resp_cookie(Name, Value, Req). 57 | 58 | setBody(Body, Req) -> cowboy_req:set_resp_body(Body, Req). 59 | 60 | peer(Req) -> cowboy_req:peer(Req). 61 | 62 | parseCookies(Req) -> 63 | cowboy_req:parse_cookies(Req). 64 | 65 | readBodyImpl(FullData, PartialData, Req) -> 66 | fun() -> case cowboy_req:read_body(Req) of 67 | {ok, D, Req2} -> (FullData(D))(Req2); 68 | {more, D, Req2} -> (PartialData(D))(Req2) 69 | end 70 | end. 71 | 72 | readUrlEncodedBodyImpl(Result, Req) -> 73 | fun() -> 74 | {ok, Items, Req2 } = cowboy_req:read_urlencoded_body(Req), 75 | (Result(Items))(Req2) 76 | end. 77 | 78 | streamReply(Status, Headers, Req) -> fun () -> 79 | cowboy_req:stream_reply(Status, Headers, Req) 80 | end. 81 | 82 | streamBody(Data, Req) -> fun () -> cowboy_req:stream_body(Data, nofin, Req) end. 83 | streamBodyFinal(Data, Req) -> fun () -> cowboy_req:stream_body(Data, fin, Req) end. 84 | 85 | setIdleTimeout_(Timeout, #{pid := Pid, streamid := StreamID}) -> 86 | fun() -> 87 | Pid ! {{Pid, StreamID}, {set_options, #{idle_timeout => Timeout}}}, 88 | unit 89 | end. 90 | -------------------------------------------------------------------------------- /src/Erl/Cowboy/Req.purs: -------------------------------------------------------------------------------- 1 | -- | Bindings for cowboy_req 2 | -- | 3 | -- | The `Req` type (corresponding to `req()`) is core to the use of cowboy, containing information about request and response. 4 | -- | Many functions operating on `Req` are pure, producing an updated `Req` if required to update some fields, e.g. when setting a 5 | -- | header, but others produce a result in `Effect` as even though they may update the `Req`, they also cause side-effects such as 6 | -- | sending traffic on the network (eg `reply`). 7 | module Erl.Cowboy.Req 8 | ( StatusCode(..) 9 | , Headers 10 | , Req 11 | , reply 12 | , replyWithoutBody 13 | , replyWithFile 14 | , replyStatus 15 | , method 16 | , Version(..) 17 | , version 18 | , scheme 19 | , binding 20 | , bindingWithDefault 21 | , pathInfo 22 | , host 23 | , port 24 | , path 25 | , qs 26 | , header 27 | , headers 28 | , ReadBodyResult(..) 29 | , ReadUrlEncodedBodyResult(..) 30 | , readBody 31 | , readUrlEncodedBody 32 | , setCookie 33 | , setCookieWithOpts 34 | , CookieOpts(..) 35 | , setHeader 36 | , setBody 37 | , IpAddress 38 | , peer 39 | , parseCookies 40 | , streamReply 41 | , streamBody 42 | , streamBodyFinal 43 | , setIdleTimeout 44 | ) where 45 | 46 | import Prelude 47 | import Data.Maybe (Maybe(..)) 48 | import Effect (Effect) 49 | import Erl.Atom (Atom, atom) 50 | import Erl.Data.Binary (Binary) 51 | import Erl.Data.Binary.IOData (IOData) 52 | import Erl.Data.List (List) 53 | import Erl.Data.Map (Map) 54 | import Erl.Data.Tuple (Tuple2, Tuple4) 55 | import Erl.Types (IntOrInfinity(..)) 56 | import Foreign (Foreign, unsafeToForeign) 57 | 58 | foreign import data Req :: Type 59 | 60 | -- http_status() = non_neg_integer() | binary() 61 | newtype StatusCode 62 | = StatusCode Int 63 | 64 | type Headers 65 | = Map String String 66 | 67 | -- | Send the reply including the given body content (cowboy_req:reply/4) 68 | foreign import reply :: StatusCode -> Headers -> IOData -> Req -> Effect Req 69 | 70 | -- | Send the reply without setting the body (cowboy_req:reply/3) 71 | foreign import replyWithoutBody :: StatusCode -> Headers -> Req -> Effect Req 72 | 73 | -- | Send the reply including a file as the body 74 | foreign import replyWithFile :: StatusCode -> Headers -> String -> Req -> Effect Req 75 | 76 | -- | Send the reply with already set headers and body (cowboy_req:reply/2) 77 | foreign import replyStatus :: StatusCode -> Req -> Effect Req 78 | 79 | -- Raw request 80 | foreign import method :: Req -> String 81 | 82 | data Version 83 | = HTTP1_0 84 | | HTTP1_1 85 | | HTTP2 86 | 87 | foreign import versionImpl :: Version -> Version -> Version -> Req -> Version 88 | 89 | version :: Req -> Version 90 | version = versionImpl HTTP1_0 HTTP1_1 HTTP2 91 | 92 | foreign import scheme :: Req -> String 93 | 94 | foreign import bindingWithDefault :: forall a. Atom -> Req -> a -> a 95 | 96 | foreign import bindingImpl :: forall a. (Maybe a) -> (a -> Maybe a) -> Atom -> Req -> Maybe a 97 | 98 | binding :: forall a. Atom -> Req -> Maybe a 99 | binding = bindingImpl Nothing Just 100 | 101 | foreign import pathInfo :: Req -> List String 102 | 103 | foreign import host :: Req -> String 104 | 105 | foreign import port :: Req -> Int 106 | 107 | foreign import path :: Req -> String 108 | 109 | foreign import qs :: Req -> String 110 | 111 | -- cowboy_req:uri(3) - Reconstructed URI 112 | foreign import headerImpl :: (forall a. Maybe a) -> (forall a. a -> Maybe a) -> String -> Req -> Maybe String 113 | 114 | header :: String -> Req -> Maybe String 115 | header = headerImpl Nothing Just 116 | 117 | foreign import headers :: Req -> Headers 118 | 119 | -- Reading the body 120 | data ReadBodyResult 121 | = FullData Binary Req 122 | | PartialData Binary Req 123 | 124 | foreign import readBodyImpl :: (Binary -> Req -> ReadBodyResult) -> (Binary -> Req -> ReadBodyResult) -> Req -> Effect ReadBodyResult 125 | 126 | readBody :: Req -> Effect ReadBodyResult 127 | readBody = readBodyImpl FullData PartialData 128 | 129 | -- and the helper for url encoded body 130 | data ReadUrlEncodedBodyResult 131 | = UrlEncodedBody (List (Tuple2 String String)) Req 132 | 133 | foreign import readUrlEncodedBodyImpl :: ((List (Tuple2 String String)) -> Req -> ReadUrlEncodedBodyResult) -> Req -> Effect ReadUrlEncodedBodyResult 134 | 135 | readUrlEncodedBody :: Req -> Effect ReadUrlEncodedBodyResult 136 | readUrlEncodedBody = readUrlEncodedBodyImpl UrlEncodedBody 137 | 138 | -- Writing a response 139 | -- See: cow_cookie:cookie_option() 140 | type CookieOpts 141 | = { max_age :: Int 142 | , domain :: String 143 | , path :: String 144 | , secure :: Boolean 145 | , http_only :: Boolean 146 | , same_site :: Atom 147 | } 148 | 149 | foreign import setHeader :: String -> String -> Req -> Req 150 | 151 | foreign import setCookie :: String -> String -> Req -> Req 152 | 153 | foreign import setCookieWithOpts :: String -> String -> CookieOpts -> Req -> Req 154 | 155 | -- | Set response body. As should be apparent from the type, this does not actually send the body but merely sets it in the Req, 156 | -- | the body is sent once reply is called. 157 | foreign import setBody :: String -> Req -> Req 158 | 159 | type IpAddress 160 | = Tuple4 Int Int Int Int 161 | 162 | foreign import peer :: Req -> Tuple2 IpAddress Int 163 | 164 | foreign import parseCookies :: Req -> List (Tuple2 String String) 165 | 166 | -- Streaming responses 167 | foreign import streamReply :: StatusCode -> Headers -> Req -> Effect Req 168 | 169 | foreign import streamBody :: IOData -> Req -> Effect Unit 170 | 171 | foreign import streamBodyFinal :: IOData -> Req -> Effect Unit 172 | 173 | setIdleTimeout :: IntOrInfinity -> Req -> Effect Unit 174 | setIdleTimeout (Finite n) = setIdleTimeout_ (unsafeToForeign n) 175 | 176 | setIdleTimeout Infinity = setIdleTimeout_ (unsafeToForeign (atom "infinity")) 177 | 178 | foreign import setIdleTimeout_ :: Foreign -> Req -> Effect Unit 179 | -------------------------------------------------------------------------------- /src/Erl/Cowboy/Req/Monad.purs: -------------------------------------------------------------------------------- 1 | module Erl.Cowboy.Req.Monad 2 | ( reply 3 | , replyWithoutBody 4 | , replyWithFile 5 | , replyStatus 6 | , streamReply 7 | , streamBody 8 | , streamBodyFinal 9 | , path 10 | , qs 11 | ) where 12 | 13 | import Prelude 14 | import Control.Monad.State (get, put) 15 | import Control.Monad.State.Class (class MonadState) 16 | import Effect (Effect) 17 | import Effect.Class (class MonadEffect, liftEffect) 18 | import Erl.Cowboy.Req as Req 19 | import Erl.Data.Binary.IOData (IOData) 20 | 21 | -- Like modify_ but with an effectful modification 22 | modifyEffect_ :: forall s m. MonadState s m => MonadEffect m => (s -> Effect s) -> m Unit 23 | modifyEffect_ f = get >>= (liftEffect <<< f) >>= put 24 | 25 | reply :: forall m. MonadState Req.Req m => MonadEffect m => Req.StatusCode -> Req.Headers -> IOData -> m Unit 26 | reply s h b = modifyEffect_ (Req.reply s h b) 27 | 28 | replyWithoutBody :: forall m. MonadState Req.Req m => MonadEffect m => Req.StatusCode -> Req.Headers -> m Unit 29 | replyWithoutBody s h = modifyEffect_ (Req.replyWithoutBody s h) 30 | 31 | replyWithFile :: forall m. MonadState Req.Req m => MonadEffect m => Req.StatusCode -> Req.Headers -> String -> m Unit 32 | replyWithFile s h f = modifyEffect_ (Req.replyWithFile s h f) 33 | 34 | replyStatus :: forall m. MonadState Req.Req m => MonadEffect m => Req.StatusCode -> m Unit 35 | replyStatus s = modifyEffect_ (Req.replyStatus s) 36 | 37 | streamReply :: forall m. MonadState Req.Req m => MonadEffect m => Req.StatusCode -> Req.Headers -> m Unit 38 | streamReply s h = modifyEffect_ (Req.streamReply s h) 39 | 40 | streamBody :: forall m. MonadState Req.Req m => MonadEffect m => IOData -> m Unit 41 | streamBody b = get >>= (liftEffect <<< Req.streamBody b) 42 | 43 | streamBodyFinal :: forall m. MonadState Req.Req m => MonadEffect m => IOData -> m Unit 44 | streamBodyFinal b = get >>= (liftEffect <<< Req.streamBodyFinal b) 45 | 46 | path :: forall m. (MonadState Req.Req m) => m String 47 | path = Req.path <$> get 48 | 49 | qs :: forall m. (MonadState Req.Req m) => m String 50 | qs = Req.qs <$> get 51 | -------------------------------------------------------------------------------- /src/Erl/Cowboy/Routes.erl: -------------------------------------------------------------------------------- 1 | -module(erl_cowboy_routes@foreign). 2 | -export([compile/1]). 3 | 4 | compile(Routes) -> cowboy_router:compile(Routes). 5 | -------------------------------------------------------------------------------- /src/Erl/Cowboy/Routes.purs: -------------------------------------------------------------------------------- 1 | -- | Bindings for cowboy_router 2 | module Erl.Cowboy.Routes where 3 | 4 | import Prelude 5 | 6 | import Erl.Atom (atom) 7 | import Erl.Data.List (List) 8 | import Erl.Data.Tuple (Tuple2, Tuple3, tuple2, tuple3) 9 | import Erl.ModuleName (NativeModuleName) 10 | import Foreign (Foreign) 11 | import Unsafe.Coerce (unsafeCoerce) 12 | 13 | -- | Initial state of a route. Different routes will have different underlying state types, this is *not* safe and is not 14 | -- | linked to the actual module state type :( 15 | newtype InitialState = InitialState Foreign 16 | 17 | newtype Route = Route (Tuple2 MatchSpec (List Path)) 18 | newtype Path = Path (Tuple3 MatchSpec NativeModuleName InitialState) 19 | 20 | -- | Match spec for host or route (string host/path or placeholder _) 21 | foreign import data MatchSpec :: Type 22 | 23 | anyMatchSpec :: MatchSpec 24 | anyMatchSpec = unsafeCoerce $ atom "_" 25 | 26 | matchSpec :: String -> MatchSpec 27 | matchSpec = unsafeCoerce 28 | 29 | foreign import data Dispatch :: Type 30 | foreign import compile :: List Route -> Dispatch 31 | 32 | anyHost :: List Path -> Route 33 | anyHost = Route <<< tuple2 anyMatchSpec 34 | 35 | host :: String -> List Path -> Route 36 | host h = Route <<< tuple2 (matchSpec h) 37 | 38 | anyPath :: NativeModuleName -> InitialState -> Path 39 | anyPath m s = Path $ tuple3 anyMatchSpec m s 40 | 41 | path :: String -> NativeModuleName -> InitialState -> Path 42 | path spec m s = Path $ tuple3 (matchSpec spec) m s -------------------------------------------------------------------------------- /src/Erl/Cowboy/Static.purs: -------------------------------------------------------------------------------- 1 | -- | Convenience binding to cowboy_static 2 | module Cowboy.Static where 3 | 4 | import Prelude 5 | 6 | import Erl.Atom (Atom, atom) 7 | import Erl.Cowboy.Routes (InitialState(..), Path, path) 8 | import Erl.Data.Tuple (tuple2, tuple3) 9 | import Erl.ModuleName as ModuleName 10 | import Foreign (unsafeToForeign) 11 | 12 | moduleName :: ModuleName.NativeModuleName 13 | moduleName = ModuleName.NativeModuleName (atom "cowboy_static") 14 | 15 | privFile :: Atom -> String -> String -> Path 16 | privFile app url f = path url moduleName (InitialState $ unsafeToForeign $ tuple3 (atom "priv_file") app f) 17 | 18 | file :: String -> String -> Path 19 | file url f = path url moduleName (InitialState $ unsafeToForeign $ tuple2 (atom "file") f) 20 | 21 | privDir :: Atom -> String -> String -> Path 22 | privDir app url d = path url moduleName (InitialState $ unsafeToForeign $ tuple3 (atom "priv_dir") app d) 23 | 24 | dir :: String -> String -> Path 25 | dir url d = path url moduleName (InitialState $ unsafeToForeign $ tuple2 (atom "dir") d) 26 | --------------------------------------------------------------------------------