├── tests ├── failures ├── basics │ ├── url │ │ ├── output │ │ ├── expected │ │ ├── input │ │ ├── run │ │ ├── test.ipkg │ │ └── Url.idr │ └── errors │ │ ├── run │ │ ├── expected │ │ ├── output │ │ ├── test.ipkg │ │ └── Error.idr ├── tests.ipkg └── runner │ └── Tests.idr ├── .dockerignore ├── json ├── tests │ ├── json │ │ └── server │ │ │ ├── input │ │ │ ├── run │ │ │ ├── expected │ │ │ ├── test.ipkg │ │ │ └── JSONServer.idr │ ├── .gitignore │ ├── tests.ipkg │ └── runner │ │ └── Tests.idr ├── README.md ├── tyttp-json.ipkg └── src │ └── TyTTP │ └── HTTP │ ├── Consumer │ └── JSON.idr │ └── Producer │ └── JSON.idr ├── adapter-node ├── tests │ ├── .gitignore │ ├── server │ │ ├── http │ │ │ ├── echo │ │ │ │ ├── input │ │ │ │ ├── run │ │ │ │ ├── test.ipkg │ │ │ │ ├── expected │ │ │ │ └── Echo.idr │ │ │ └── files │ │ │ │ ├── input │ │ │ │ ├── run │ │ │ │ ├── expected │ │ │ │ ├── test.ipkg │ │ │ │ └── Files.idr │ │ └── http2 │ │ │ ├── echo │ │ │ ├── input │ │ │ ├── run │ │ │ ├── test.ipkg │ │ │ ├── expected │ │ │ └── Echo.idr │ │ │ └── push │ │ │ ├── input │ │ │ ├── run │ │ │ ├── test.ipkg │ │ │ ├── expected │ │ │ └── Push.idr │ ├── tests.ipkg │ └── runner │ │ └── Tests.idr ├── src │ ├── TyTTP │ │ └── Adapter │ │ │ └── Node │ │ │ ├── Error.idr │ │ │ ├── URI.idr │ │ │ ├── Static.idr │ │ │ ├── HTTP.idr │ │ │ ├── HTTPS.idr │ │ │ └── HTTP2.idr │ └── Main.idr └── tyttp-adapter-node.ipkg ├── .gitignore ├── src ├── TyTTP │ ├── URL.idr │ ├── Core │ │ ├── Error.idr │ │ ├── Response.idr │ │ ├── Request.idr │ │ ├── Routing.idr │ │ ├── Context.idr │ │ └── Stream.idr │ ├── HTTP.idr │ ├── URL │ │ ├── Definition.idr │ │ ├── Search.idr │ │ ├── Simple.idr │ │ └── Path.idr │ └── HTTP │ │ ├── Producer.idr │ │ ├── Routing.idr │ │ ├── Consumer.idr │ │ └── Protocol.idr └── TyTTP.idr ├── pack.toml ├── Dockerfile ├── tyttp.ipkg ├── flake.nix ├── LICENSE ├── README.md └── flake.lock /tests/failures: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/basics/url/output: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.dockerignore: -------------------------------------------------------------------------------- 1 | Dockerfile 2 | -------------------------------------------------------------------------------- /json/tests/json/server/input: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/basics/url/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/basics/url/input: -------------------------------------------------------------------------------- 1 | main 2 | :q 3 | -------------------------------------------------------------------------------- /json/tests/.gitignore: -------------------------------------------------------------------------------- 1 | failures 2 | output 3 | 4 | -------------------------------------------------------------------------------- /adapter-node/tests/.gitignore: -------------------------------------------------------------------------------- 1 | failures 2 | output 3 | 4 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http/echo/input: -------------------------------------------------------------------------------- 1 | main 2 | :q 3 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http/files/input: -------------------------------------------------------------------------------- 1 | main 2 | :q 3 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http2/echo/input: -------------------------------------------------------------------------------- 1 | main 2 | :q 3 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http2/push/input: -------------------------------------------------------------------------------- 1 | main 2 | :q 3 | -------------------------------------------------------------------------------- /json/tests/json/server/run: -------------------------------------------------------------------------------- 1 | rm -rf build 2 | 3 | pack run test.ipkg 4 | -------------------------------------------------------------------------------- /tests/basics/errors/run: -------------------------------------------------------------------------------- 1 | rm -rf build 2 | 3 | pack run test.ipkg 4 | 5 | 6 | -------------------------------------------------------------------------------- /tests/basics/url/run: -------------------------------------------------------------------------------- 1 | rm -rf build 2 | 3 | pack run test.ipkg 4 | 5 | 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .pack/ 2 | .direnv/ 3 | node_modules/ 4 | build/ 5 | certs/ 6 | tmp/ 7 | -------------------------------------------------------------------------------- /json/tests/json/server/expected: -------------------------------------------------------------------------------- 1 | "success" 2 | {"field":"a field value","opt":1} 3 | -------------------------------------------------------------------------------- /tests/basics/errors/expected: -------------------------------------------------------------------------------- 1 | 2 | Errors: request 3 | 4 | Could not parse as int: request 5 | 6 | Errors: 134 7 | 8 | 134 9 | -------------------------------------------------------------------------------- /tests/basics/errors/output: -------------------------------------------------------------------------------- 1 | 2 | Errors: request 3 | 4 | Could not parse as int: request 5 | 6 | Errors: 134 7 | 8 | 134 9 | -------------------------------------------------------------------------------- /tests/tests.ipkg: -------------------------------------------------------------------------------- 1 | package tests 2 | 3 | depends = golden-runner-helper 4 | 5 | main = Tests 6 | executable=tests 7 | 8 | sourcedir = "runner" 9 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http/echo/run: -------------------------------------------------------------------------------- 1 | rm -rf build 2 | 3 | pack -q build test.ipkg 4 | [ -f build/exec/test ] && node build/exec/test 5 | 6 | 7 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http/files/run: -------------------------------------------------------------------------------- 1 | rm -rf build 2 | 3 | pack -q build test.ipkg 4 | [ -f build/exec/test ] && node build/exec/test 5 | 6 | 7 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http2/echo/run: -------------------------------------------------------------------------------- 1 | rm -rf build 2 | 3 | pack -q build test.ipkg 4 | [ -f build/exec/test ] && node build/exec/test 5 | 6 | 7 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http2/push/run: -------------------------------------------------------------------------------- 1 | rm -rf build 2 | 3 | pack -q build test.ipkg 4 | [ -f build/exec/test ] && node build/exec/test 5 | 6 | 7 | -------------------------------------------------------------------------------- /json/tests/tests.ipkg: -------------------------------------------------------------------------------- 1 | package tests 2 | 3 | depends = golden-runner-helper 4 | 5 | main = Tests 6 | executable=tests 7 | 8 | sourcedir = "runner" 9 | -------------------------------------------------------------------------------- /adapter-node/tests/tests.ipkg: -------------------------------------------------------------------------------- 1 | package tests 2 | 3 | depends = golden-runner-helper 4 | 5 | main = Tests 6 | executable=tests 7 | 8 | sourcedir = "runner" 9 | -------------------------------------------------------------------------------- /json/tests/runner/Tests.idr: -------------------------------------------------------------------------------- 1 | module Tests 2 | 3 | import Test.Golden.RunnerHelper 4 | 5 | main : IO () 6 | main = do 7 | goldenRunner [ "json" `atDir` "json" ] 8 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http/files/expected: -------------------------------------------------------------------------------- 1 | 200 2 | rm -rf build 3 | 4 | pack -q build test.ipkg 5 | [ -f build/exec/test ] && node build/exec/test 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /tests/basics/errors/test.ipkg: -------------------------------------------------------------------------------- 1 | package test 2 | 3 | depends = tyttp 4 | modules = Error 5 | main = Error 6 | executable = test 7 | opts = "--no-color --console-width 0" 8 | -------------------------------------------------------------------------------- /tests/runner/Tests.idr: -------------------------------------------------------------------------------- 1 | module Tests 2 | 3 | import Test.Golden.RunnerHelper 4 | 5 | main : IO () 6 | main = do 7 | goldenRunner [ "basics" `atDir` "basics" ] 8 | 9 | -------------------------------------------------------------------------------- /tests/basics/url/test.ipkg: -------------------------------------------------------------------------------- 1 | package test 2 | 3 | depends = tyttp, promise 4 | modules = Url 5 | main = Url 6 | executable = test 7 | opts = "--no-color --console-width 0" 8 | -------------------------------------------------------------------------------- /src/TyTTP/URL.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.URL 2 | 3 | import public TyTTP.URL.Definition 4 | import public TyTTP.URL.Path 5 | import public TyTTP.URL.Search 6 | import public TyTTP.URL.Simple 7 | 8 | 9 | -------------------------------------------------------------------------------- /src/TyTTP/Core/Error.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.Core.Error 2 | 3 | 4 | public export 5 | interface Error e where 6 | message : e -> String 7 | 8 | export 9 | Error String where 10 | message = id 11 | 12 | -------------------------------------------------------------------------------- /src/TyTTP/HTTP.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.HTTP 2 | 3 | import public TyTTP 4 | import public TyTTP.HTTP.Consumer 5 | import public TyTTP.HTTP.Producer 6 | import public TyTTP.HTTP.Protocol 7 | import public TyTTP.HTTP.Routing 8 | 9 | -------------------------------------------------------------------------------- /adapter-node/src/TyTTP/Adapter/Node/Error.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.Adapter.Node.Error 2 | 3 | import Node.Error as Node 4 | import TyTTP 5 | 6 | export 7 | Node.ErrorClass e => Error e where 8 | message = Node.(.message) 9 | 10 | -------------------------------------------------------------------------------- /adapter-node/tests/runner/Tests.idr: -------------------------------------------------------------------------------- 1 | module Tests 2 | 3 | import Test.Golden.RunnerHelper 4 | 5 | main : IO () 6 | main = do 7 | goldenRunner 8 | [ "http" `atDir` "server/http" 9 | , "http2" `atDir` "server/http2" 10 | ] 11 | 12 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http/echo/test.ipkg: -------------------------------------------------------------------------------- 1 | package test 2 | 3 | depends = tyttp, tyttp-adapter-node, apache-mime-types, promise, node 4 | modules = Echo 5 | main = Echo 6 | executable = test 7 | opts = "--no-color --console-width 0 --codegen node" 8 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http/files/test.ipkg: -------------------------------------------------------------------------------- 1 | package test 2 | 3 | depends = tyttp, tyttp-adapter-node, apache-mime-types, promise, node 4 | modules = Files 5 | main = Files 6 | executable = test 7 | opts = "--no-color --console-width 0 --codegen node" 8 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http2/echo/test.ipkg: -------------------------------------------------------------------------------- 1 | package test 2 | 3 | depends = tyttp, tyttp-adapter-node, apache-mime-types, promise, node 4 | modules = Echo 5 | main = Echo 6 | executable = test 7 | opts = "--no-color --console-width 0 --codegen node" 8 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http2/push/test.ipkg: -------------------------------------------------------------------------------- 1 | package test 2 | 3 | depends = tyttp, tyttp-adapter-node, apache-mime-types, promise, node 4 | modules = Push 5 | main = Push 6 | executable = test 7 | opts = "--no-color --console-width 0 --codegen node" 8 | -------------------------------------------------------------------------------- /json/README.md: -------------------------------------------------------------------------------- 1 | # tyttp-json 2 | 3 | JSON body consumer and producer for TyTTP 4 | 5 | Enables using 6 | 7 | consumes [JSON] handler context 8 | 9 | and 10 | 11 | sendJSON someToJSONValue context 12 | 13 | in your tyttp expression. 14 | -------------------------------------------------------------------------------- /src/TyTTP.idr: -------------------------------------------------------------------------------- 1 | module TyTTP 2 | 3 | import public Promise 4 | import public TyTTP.Core.Context 5 | import public TyTTP.Core.Error 6 | import public TyTTP.Core.Request 7 | import public TyTTP.Core.Response 8 | import public TyTTP.Core.Routing 9 | import public TyTTP.Core.Stream 10 | -------------------------------------------------------------------------------- /src/TyTTP/Core/Response.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.Core.Response 2 | 3 | public export 4 | record Response s h a where 5 | constructor MkResponse 6 | status : s 7 | headers : h 8 | body : a 9 | 10 | export 11 | Functor (Response s h) where 12 | map f res = { body $= f } res 13 | 14 | -------------------------------------------------------------------------------- /src/TyTTP/Core/Request.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.Core.Request 2 | 3 | public export 4 | record Request m u v h a where 5 | constructor MkRequest 6 | method : m 7 | url : u 8 | version : v 9 | headers : h 10 | body : a 11 | 12 | export 13 | Functor (Request m u v h) where 14 | map f req = { body $= f } req 15 | 16 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http2/push/expected: -------------------------------------------------------------------------------- 1 | PUSH 2 | [(":authority", "localhost:3000"), (":method", "GET"), (":path", "/pushed.txt"), (":scheme", "http")] 3 | GET 4 | [(":status", ""), ("content-type", "text/plain")] 5 | this is the response 6 | close counter is at 1 7 | this is pushed 8 | close counter is at 0 9 | closing session and server 10 | -------------------------------------------------------------------------------- /json/tests/json/server/test.ipkg: -------------------------------------------------------------------------------- 1 | package test 2 | 3 | depends = tyttp 4 | , tyttp-adapter-node 5 | , tyttp-json 6 | , promise 7 | , json 8 | , sop 9 | , elab-util 10 | , apache-mime-types 11 | , node 12 | modules = JSONServer 13 | main = JSONServer 14 | executable = test 15 | opts = "--no-color --console-width 0 --codegen node" 16 | -------------------------------------------------------------------------------- /json/tyttp-json.ipkg: -------------------------------------------------------------------------------- 1 | package tyttp-json 2 | 3 | modules = TyTTP.HTTP.Consumer.JSON 4 | , TyTTP.HTTP.Producer.JSON 5 | 6 | depends = tyttp 7 | , promise 8 | , json 9 | , sop 10 | , elab-util 11 | , apache-mime-types 12 | , node 13 | 14 | opts = "--codegen node" 15 | sourcedir = "src" 16 | 17 | brief = "JSON payload consumer and producer for TyTTP web framework" 18 | 19 | -------------------------------------------------------------------------------- /pack.toml: -------------------------------------------------------------------------------- 1 | [custom.all.tyttp] 2 | type = "local" 3 | path = "." 4 | ipkg = "tyttp.ipkg" 5 | test = "tests/tests.ipkg" 6 | 7 | [custom.all.tyttp-json] 8 | type = "local" 9 | path = "./json" 10 | ipkg = "tyttp-json.ipkg" 11 | test = "tests/tests.ipkg" 12 | 13 | [custom.all.tyttp-adapter-node] 14 | type = "local" 15 | path = "./adapter-node" 16 | ipkg = "tyttp-adapter-node.ipkg" 17 | test = "tests/tests.ipkg" 18 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http/echo/expected: -------------------------------------------------------------------------------- 1 | GET 2 | 200 3 | method -> GET 4 | url -> / 5 | version -> 1.1 6 | headers -> 7 | host : localhost:3000 8 | connection : close 9 | body -> 10 | POST 11 | 200 12 | method -> POST 13 | url -> /the/resource 14 | version -> 1.1 15 | headers -> 16 | host : localhost:3000 17 | connection : close 18 | transfer-encoding : chunked 19 | body -> 20 | Hello World! 21 | With more chunks 22 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http2/echo/expected: -------------------------------------------------------------------------------- 1 | GET 2 | method -> GET 3 | path -> / 4 | headers -> 5 | :authority : localhost:3000 6 | :method : GET 7 | :path : / 8 | :scheme : http 9 | body -> 10 | POST 11 | method -> POST 12 | path -> /the/resource 13 | headers -> 14 | :authority : localhost:3000 15 | :method : POST 16 | :path : /the/resource 17 | :scheme : http 18 | body -> 19 | Hello World! 20 | With more chunks 21 | -------------------------------------------------------------------------------- /json/src/TyTTP/HTTP/Consumer/JSON.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.HTTP.Consumer.JSON 2 | 3 | import Data.Buffer.Ext 4 | import JSON 5 | import TyTTP.HTTP.Consumer 6 | 7 | %hide JSON.Parser.JSON 8 | 9 | export 10 | data JSON : Type where 11 | 12 | export 13 | implementation Accept JSON where 14 | contentType _ = [ "application/json" ] 15 | 16 | export 17 | implementation FromJSON a => Consumer a JSON where 18 | consumeRaw _ ct raw = 19 | mapFst show $ decode $ show raw 20 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ghcr.io/stefan-hoeck/idris2-pack AS builder 2 | 3 | RUN apt-get update 4 | RUN apt-get install -y nodejs 5 | 6 | WORKDIR /tyttp 7 | COPY . . 8 | 9 | RUN pack --no-prompt build tyttp.ipkg 10 | RUN pack --no-prompt build json/tyttp-json.ipkg 11 | RUN pack --no-prompt build adapter-node/tyttp-adapter-node.ipkg 12 | 13 | RUN pack --no-prompt test tyttp 14 | RUN pack --no-prompt test tyttp-json 15 | RUN pack --no-prompt test tyttp-adapter-node 16 | 17 | EXPOSE 3000 18 | CMD pack run tyttp-adapter-node 19 | -------------------------------------------------------------------------------- /adapter-node/tyttp-adapter-node.ipkg: -------------------------------------------------------------------------------- 1 | package tyttp-adapter-node 2 | 3 | modules = TyTTP.Adapter.Node.Error 4 | , TyTTP.Adapter.Node.HTTP 5 | , TyTTP.Adapter.Node.HTTPS 6 | , TyTTP.Adapter.Node.HTTP2 7 | , TyTTP.Adapter.Node.Static 8 | , TyTTP.Adapter.Node.URI 9 | 10 | depends = apache-mime-types 11 | , node 12 | , promise 13 | , tyttp 14 | 15 | opts = "--codegen node" 16 | 17 | sourcedir = "src" 18 | 19 | main = Main 20 | executable = tyttp-node 21 | 22 | brief = "An experimental web server framework targeting NodeJS" 23 | 24 | -------------------------------------------------------------------------------- /src/TyTTP/URL/Definition.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.URL.Definition 2 | 3 | public export 4 | data Scheme 5 | = HTTP 6 | | HTTPS 7 | | OtherScheme String 8 | 9 | namespace Scheme 10 | export 11 | parse : String -> Scheme 12 | parse "http" = HTTP 13 | parse "https" = HTTPS 14 | parse str = OtherScheme str 15 | 16 | export 17 | Show Scheme where 18 | show s = case s of 19 | HTTP => "http" 20 | HTTPS => "https" 21 | OtherScheme str => str 22 | 23 | public export 24 | record URL a p s where 25 | constructor MkURL 26 | scheme : Maybe Scheme 27 | authority : Maybe a 28 | path : p 29 | search : s 30 | 31 | -------------------------------------------------------------------------------- /tyttp.ipkg: -------------------------------------------------------------------------------- 1 | package tyttp 2 | 3 | modules = TyTTP 4 | , TyTTP.Core.Context 5 | , TyTTP.Core.Error 6 | , TyTTP.Core.Request 7 | , TyTTP.Core.Response 8 | , TyTTP.Core.Routing 9 | , TyTTP.Core.Stream 10 | , TyTTP.HTTP 11 | , TyTTP.HTTP.Consumer 12 | , TyTTP.HTTP.Producer 13 | , TyTTP.HTTP.Protocol 14 | , TyTTP.HTTP.Routing 15 | , TyTTP.URL 16 | , TyTTP.URL.Definition 17 | , TyTTP.URL.Path 18 | , TyTTP.URL.Search 19 | , TyTTP.URL.Simple 20 | 21 | depends = base 22 | , apache-mime-types 23 | , promise 24 | 25 | sourcedir = "src" 26 | 27 | brief = "An experimental web server framework targeting NodeJS" 28 | 29 | -------------------------------------------------------------------------------- /json/src/TyTTP/HTTP/Producer/JSON.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.HTTP.Producer.JSON 2 | 3 | import Data.Buffer.Ext 4 | import TyTTP 5 | import TyTTP.HTTP 6 | import JSON 7 | 8 | export 9 | sendJSON : 10 | Applicative m 11 | => ToJSON j 12 | => j 13 | -> Context me u v h1 s StringHeaders a b 14 | -> m $ Context me u v h1 s StringHeaders a (Publisher IO e Buffer) 15 | sendJSON j ctx = do 16 | let bodyJson = encode j 17 | let stream : Publisher IO e Buffer = Stream.singleton $ fromString $ bodyJson 18 | pure $ { response.body := stream 19 | , response.headers := 20 | [ ("Content-Type", "application/json") 21 | , ("Content-Length", show $ length bodyJson) 22 | ] 23 | } ctx 24 | -------------------------------------------------------------------------------- /src/TyTTP/Core/Routing.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.Core.Routing 2 | 3 | import public Control.Monad.Maybe 4 | import TyTTP.Core.Context 5 | 6 | export 7 | routes : Alternative m 8 | => List ( 9 | Context me u v h1 s h2 a b 10 | -> m $ Context me' p' v' h1' s' h2' a' b' 11 | ) 12 | -> Context me u v h1 s h2 a b 13 | -> m $ Context me' p' v' h1' s' h2' a' b' 14 | routes handlers ctx = choiceMap ($ ctx) handlers 15 | 16 | export 17 | routes' : Monad m 18 | => ( 19 | Context me u v h1 s h2 a b 20 | -> m $ Context me' p' v' h1' s' h2' a' b' 21 | ) 22 | -> List ( 23 | Context me u v h1 s h2 a b 24 | -> MaybeT m $ Context me' p' v' h1' s' h2' a' b' 25 | ) 26 | -> Context me u v h1 s h2 a b 27 | -> m $ Context me' p' v' h1' s' h2' a' b' 28 | routes' def handlers ctx = do 29 | Just result <- runMaybeT $ routes handlers ctx 30 | | Nothing => def ctx 31 | pure result 32 | 33 | -------------------------------------------------------------------------------- /src/TyTTP/Core/Context.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.Core.Context 2 | 3 | import public Control.Monad.Trans 4 | import TyTTP.Core.Request 5 | import TyTTP.Core.Response 6 | 7 | public export 8 | record Context me u v h1 s h2 a b where 9 | constructor MkContext 10 | request : Request me u v h1 a 11 | response : Response s h2 b 12 | 13 | export 14 | Functor (Context me u v h1 s h2 a) where 15 | map f step = { response $= map f } step 16 | 17 | export 18 | Bifunctor (Context me u v h1 s h2) where 19 | bimap f g step = { request $= map f, response $= map g } step 20 | 21 | export 22 | infixr 0 :> 23 | 24 | export 25 | infixr 0 :>> 26 | 27 | export 28 | (:>) : MonadTrans t 29 | => Monad m 30 | => (f : (a -> (t m) b) -> c) 31 | -> (handler : a -> m b) 32 | -> c 33 | (:>) f handler = f $ \a => lift $ handler a 34 | 35 | export 36 | (:>>) : MonadTrans t1 37 | => MonadTrans t2 38 | => Monad m 39 | => Monad (t1 m) 40 | => (f : (a -> (t2 (t1 m)) b) -> c) 41 | -> (handler : a -> m b) 42 | -> c 43 | (:>>) f handler = f $ \a => lift $ lift $ handler a 44 | -------------------------------------------------------------------------------- /adapter-node/src/TyTTP/Adapter/Node/URI.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.Adapter.Node.URI 2 | 3 | import Control.Monad.Maybe 4 | import Node.JS.Std.URI 5 | import TyTTP 6 | 7 | export 8 | decodeUri : Alternative m 9 | => ( 10 | Context me String v h1 s h2 a b 11 | -> m $ Context me' String v' h1' s' h2' a' b' 12 | ) 13 | -> Context me String v h1 s h2 a b 14 | -> m $ Context me' String v' h1' s' h2' a' b' 15 | decodeUri handler ctx = case Std.URI.decodeURI ctx.request.url of 16 | Right str => handler $ { request.url := str } ctx 17 | Left _ => empty 18 | 19 | export 20 | decodeUri' : Monad m 21 | => ( 22 | Context me String v h1 s h2 a b 23 | -> m $ Context me' String v' h1' s' h2' a' b' 24 | ) 25 | -> ( 26 | Context me String v h1 s h2 a b 27 | -> MaybeT m $ Context me' String v' h1' s' h2' a' b' 28 | ) 29 | -> Context me String v h1 s h2 a b 30 | -> m $ Context me' String v' h1' s' h2' a' b' 31 | decodeUri' defHandler handler ctx = do 32 | Just result <- runMaybeT $ decodeUri handler ctx 33 | | Nothing => defHandler ctx 34 | pure result 35 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Flake for TyTTP"; 3 | 4 | inputs.nixpkgs.url = "github:NixOS/nixpkgs/nixos-23.11"; 5 | inputs.flake-utils.url = "github:numtide/flake-utils"; 6 | 7 | outputs = { 8 | self, 9 | nixpkgs, 10 | nixpkgs-unstable, 11 | flake-utils, 12 | }: 13 | flake-utils.lib.eachDefaultSystem 14 | ( 15 | system: let 16 | stable = nixpkgs.legacyPackages.${system}; 17 | in { 18 | devShells.default = stable.mkShell { 19 | packages = with stable; [ 20 | nodejs_18 21 | chez 22 | 23 | stdenv 24 | gmp 25 | ]; 26 | 27 | shellHook = '' 28 | export PACK_DIR=`pwd`/.pack 29 | export PATH=$PACK_DIR/bin:$PATH 30 | if [ ! -d $PACK_DIR ]; then 31 | sh -c "$(${stable.curl}/bin/curl -fsSL https://raw.githubusercontent.com/stefan-hoeck/idris2-pack/main/install.bash)" 32 | fi 33 | [ ! -e $PACK_DIR/bin/idris2-lsp ] && pack --no-prompt install-app idris2-lsp 34 | ''; 35 | }; 36 | } 37 | ); 38 | } 39 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Bertalan Kis 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 | 23 | -------------------------------------------------------------------------------- /src/TyTTP/HTTP/Producer.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.HTTP.Producer 2 | 3 | import Data.Buffer 4 | import TyTTP 5 | import TyTTP.HTTP.Protocol 6 | 7 | unsafeFromString : String -> Buffer 8 | unsafeFromString str = unsafePerformIO $ do 9 | let size = stringByteLength str 10 | Just buffer <- newBuffer $ cast size 11 | | Nothing => assert_total $ idris_crash "could not create new buffer" 12 | setString buffer 0 str 13 | pure buffer 14 | 15 | export 16 | sendText : 17 | Applicative m 18 | => String 19 | -> Context me u v h1 s StringHeaders a b 20 | -> m $ Context me u v h1 s StringHeaders a (Publisher IO e Buffer) 21 | sendText str ctx = do 22 | let stream : Publisher IO e Buffer = Stream.singleton $ unsafeFromString str 23 | pure $ { response.body := stream 24 | , response.headers := 25 | [ ("Content-Type", "text/plain") 26 | , ("Content-Length", show $ length str) 27 | ] 28 | } ctx 29 | 30 | export 31 | status : 32 | Applicative m 33 | => Status 34 | -> Context me u v h1 s h2 a b 35 | -> m $ Context me u v h1 Status h2 a b 36 | status s ctx = pure $ { response.status := s } ctx 37 | 38 | -------------------------------------------------------------------------------- /src/TyTTP/Core/Stream.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.Core.Stream 2 | 3 | import Data.Contravariant 4 | 5 | public export 6 | record Subscriber (m : Type -> Type) (e : Type) (a : Type) where 7 | constructor MkSubscriber 8 | onNext: a -> m () 9 | onSucceded: () -> m () 10 | onFailed: e -> m () 11 | 12 | export 13 | Contravariant (Subscriber m e) where 14 | contramap f subscriber = { onNext := subscriber.onNext . f } subscriber 15 | 16 | public export 17 | record Publisher (m : Type -> Type) (e : Type) (a : Type) where 18 | constructor MkPublisher 19 | subscribe : Subscriber m e a -> m () 20 | 21 | export 22 | Functor (Publisher m e) where 23 | map f publisher = MkPublisher $ \s => publisher.subscribe $ contramap f s 24 | 25 | export 26 | empty : Publisher m e a 27 | empty = MkPublisher $ \s => s.onSucceded () 28 | 29 | export 30 | fail : e -> Publisher m e a 31 | fail e = MkPublisher $ \s => s.onFailed e 32 | 33 | export 34 | singleton : Monad m => a -> Publisher m e a 35 | singleton a = MkPublisher $ \s => s.onNext a >>= s.onSucceded 36 | 37 | export 38 | fromList : Monad m => List a -> Publisher m e a 39 | fromList list = MkPublisher $ \s => do 40 | traverse_ s.onNext list 41 | s.onSucceded () 42 | 43 | -------------------------------------------------------------------------------- /tests/basics/url/Url.idr: -------------------------------------------------------------------------------- 1 | module Url 2 | 3 | import Control.Monad.Either 4 | import TyTTP.URL 5 | 6 | main : IO () 7 | main = eitherT putStrLn pure $ do 8 | Left EmptyString <- pure $ Simple.parse "" 9 | | _ => throwError "empty url is not matched" 10 | 11 | Left EmptyString <- pure $ Simple.parse " \t\r\n" 12 | | _ => throwError "blank url is not matched" 13 | 14 | Left MissingAuthorityOrPath <- pure $ Simple.parse "http:" 15 | | _ => throwError "http scheme not recognized" 16 | 17 | Right (MkURL (Just HTTP) Nothing "something" "") <- pure $ Simple.parse "http:something" 18 | | _ => throwError "http scheme not recognized" 19 | 20 | Right (MkURL (Just HTTPS) Nothing "som" "") <- pure $ Simple.parse " \thttps:som" 21 | | _ => throwError "https scheme with whitespace not recognized" 22 | 23 | Right (MkURL Nothing (Just "something") "/" "") <- pure $ Simple.parse "//something" 24 | | _ => throwError "simple authority not recognized" 25 | 26 | Right (MkURL (Just HTTP) (Just "user:passwd@something") "/path/like" "?query=string") <- pure $ Simple.parse "http://user:passwd@something/path/like?query=string" 27 | | _ => throwError "simple authority not recognized" 28 | 29 | pure () 30 | 31 | 32 | -------------------------------------------------------------------------------- /src/TyTTP/URL/Search.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.URL.Search 2 | 3 | import Control.Monad.Either 4 | import Data.List 5 | import Data.List1 6 | import Data.Maybe 7 | import TyTTP 8 | import TyTTP.URL.Definition 9 | 10 | %default total 11 | 12 | namespace Simple 13 | 14 | public export 15 | SimpleSearch : Type 16 | SimpleSearch = List (String, String) 17 | 18 | parseString : String -> SimpleSearch 19 | parseString = parseSkipQuestionMarks . unpack 20 | where 21 | parse : List Char -> SimpleSearch 22 | parse [] = [] 23 | parse xs = 24 | let sections = splitOn '&' xs 25 | params = break (== '=') <$> List.filter (not . null) (forget sections) 26 | in 27 | bimap pack (pack . fromMaybe [] . tail') <$> params 28 | 29 | parseSkipQuestionMarks : List Char -> SimpleSearch 30 | parseSkipQuestionMarks [] = [] 31 | parseSkipQuestionMarks ('?'::xs) = parseSkipQuestionMarks xs 32 | parseSkipQuestionMarks a@(x::xs) = parse a 33 | 34 | 35 | export 36 | search : Monad m 37 | => ( 38 | Context me (URL auth pth SimpleSearch) v h1 st h2 a b 39 | -> m $ Context me' (URL auth pth SimpleSearch) v' h1' st' h2' a' b' 40 | ) 41 | -> Context me (URL auth pth String) v h1 st h2 a b 42 | -> m $ Context me' (URL auth pth String) v' h1' st' h2' a' b' 43 | search handler ctx = do 44 | let src = parseString $ URL.search ctx.request.url 45 | result <- handler $ { request.url := { search := src } ctx.request.url } ctx 46 | pure $ { request.url := { search := ctx.request.url.search } result.request.url } result 47 | 48 | -------------------------------------------------------------------------------- /tests/basics/errors/Error.idr: -------------------------------------------------------------------------------- 1 | module Error 2 | 3 | import Control.Monad.Error.Interface 4 | import Control.Monad.Error.Either 5 | import Data.String 6 | import TyTTP 7 | import TyTTP.HTTP 8 | 9 | orThrow : MonadError e m => Maybe a -> e -> m a 10 | orThrow m e = case m of 11 | Just a => pure a 12 | Nothing => throwError e 13 | 14 | data Error = ParseError String 15 | 16 | parseIntegerM : MonadError Error m => String -> m Int 17 | parseIntegerM s = parseInteger s `orThrow` ParseError ("Could not parse as int: " <+> s) 18 | 19 | hParseRequest : MonadError e m 20 | => (String -> m a') 21 | -> Context me u v h1 s h2 String b 22 | -> m $ Context me u v h1 s h2 a' b 23 | hParseRequest parser ctx = do 24 | result <- parser ctx.request.body 25 | pure $ { request.body := result } ctx 26 | 27 | hEcho : Monad m 28 | => Context me u v h1 s h2 a b 29 | -> m $ Context me u v h1 s h2 a a 30 | hEcho ctx = pure $ { response.body := ctx.request.body } ctx 31 | 32 | exampleErrorHandling : Context Method String Version () String () String String -> IO () 33 | exampleErrorHandling ctx = do 34 | putStrLn $ "\nErrors: " <+> ctx.request.body <+> "\n" 35 | 36 | let handler = hParseRequest parseIntegerM >=> hEcho {m = EitherT Error IO} 37 | result <- runEitherT $ handler ctx 38 | 39 | case result of 40 | Left (ParseError e) => putStrLn e 41 | Right a => putStrLn $ show a.response.body 42 | 43 | main : IO () 44 | main = do 45 | let res = MkResponse "" () "" 46 | ctx = MkContext (MkRequest GET "/" Version_1_1 () "request") res 47 | 48 | exampleErrorHandling ctx 49 | exampleErrorHandling $ MkContext (MkRequest GET "/" Version_1_1 () "134") res 50 | 51 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http/files/Files.idr: -------------------------------------------------------------------------------- 1 | module Files 2 | 3 | import Data.Buffer.Ext 4 | import Node.HTTP 5 | import Node.Timers 6 | import System.Directory 7 | import TyTTP.Adapter.Node.HTTP 8 | import TyTTP.Adapter.Node.Static 9 | import TyTTP.HTTP 10 | import TyTTP.URL 11 | 12 | sendError : 13 | Error e 14 | => HasIO io 15 | => Status 16 | -> String 17 | -> Context me u v h1 s StringHeaders a b 18 | -> io $ Context me u v h1 Status StringHeaders a (Publisher IO e Buffer) 19 | sendError st str ctx = do 20 | sendText str ctx >>= status st 21 | 22 | routeDef : 23 | String 24 | -> StaticRequest String 25 | -> Promise Error IO $ StaticResponse String 26 | routeDef folder = 27 | let routingError = sendError NOT_FOUND "Resource could not be found" 28 | urlError = \err => sendError BAD_REQUEST "URL has invalid format" 29 | in 30 | parseUrl' urlError :> 31 | routes' routingError 32 | [ get $ pattern "/static/*" :> hStatic folder $ flip $ \ctx => 33 | \case 34 | StatError e => sendError INTERNAL_SERVER_ERROR ("File error: " <+> TyTTP.Core.Error.message e) ctx 35 | NotAFile s => sendError NOT_FOUND ("Could not found file: " <+> s) ctx 36 | ] 37 | 38 | main : IO () 39 | main = do 40 | Just folder <- currentDir 41 | | _ => putStrLn "There is no current folder" 42 | 43 | http <- HTTP.require 44 | server <- listen' $ routeDef "\{folder}/" 45 | 46 | ignore $ setImmediate $ ignore $ http.get "http://localhost:3000/static/run" defaultOptions $ \res => do 47 | putStrLn $ show res.statusCode 48 | res.onData $ putStrLn . show 49 | server.close 50 | 51 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http/echo/Echo.idr: -------------------------------------------------------------------------------- 1 | module Echo 2 | 3 | import Data.Buffer.Ext 4 | import Node.HTTP 5 | import Node.Timers 6 | import TyTTP.Adapter.Node.HTTP as HTTP 7 | import TyTTP.HTTP 8 | 9 | hReflect : Context Method String Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) () 10 | -> IO $ Context Method String Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) (Publisher IO Error Buffer) 11 | hReflect ctx = do 12 | let m = ctx.request.method 13 | h = ctx.request.headers 14 | p : Publisher IO Error Buffer = MkPublisher $ \s => do 15 | s.onNext $ fromString "method -> \{show m}" 16 | s.onNext $ fromString "url -> \{ctx.request.url}" 17 | s.onNext $ fromString "version -> \{show ctx.request.version}" 18 | s.onNext "headers ->" 19 | for_ h $ \v => s.onNext $ fromString "\t\{fst v} : \{snd v}" 20 | s.onNext "body ->" 21 | ctx.request.body.subscribe s 22 | pure $ { response.body := p } ctx 23 | 24 | main : IO () 25 | main = do 26 | http <- require 27 | server <- HTTP.listen' { e = Error } :> hReflect 28 | 29 | ignore $ setImmediate $ do 30 | ignore $ http.get "http://localhost:3000" defaultOptions $ \res => do 31 | putStrLn "GET" 32 | putStrLn $ show res.statusCode 33 | res.onData $ putStrLn . show 34 | 35 | ignore $ setImmediate $ do 36 | clientReq <- http.post "http://localhost:3000/the/resource" defaultOptions $ \res => do 37 | putStrLn "POST" 38 | putStrLn $ show res.statusCode 39 | res.onData $ putStrLn . show 40 | server.close 41 | 42 | clientReq.write "Hello World!" Nothing 43 | clientReq.write "With more chunks" Nothing 44 | clientReq.end Nothing { d = Buffer } 45 | 46 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # tyttp 2 | 3 | A type safe _experimental_ web framework for idris2 targeting node js. 4 | 5 | # Features 6 | 7 | - HTTP/HTTPS server, HTTP2 server 8 | - Streaming from end-to-end 9 | - Supports async execution via [idris2-promise](https://github.com/kbertalan/idris2-promise) 10 | 11 | - Routing - based on Alternative monad 12 | - Match HTTP methods 13 | - Parse HTTP url 14 | - Support path parameters, own path syntax 15 | - Flexible: all combinators can be replaced 16 | 17 | - Example file server in test 18 | - Example text based echo implementation in test 19 | 20 | # Prerequisities 21 | 22 | 1. [idris2-pack](https://github.com/stefan-hoeck/idris2-pack) 23 | 1. idris2 version 0.5.1, see installation at idris2-pack documentation 24 | 1. node LTS 16.x, see [download page](https://nodejs.org/en/download/) 25 | 26 | # Consumers and Producers 27 | 28 | Supporting multiple formats can introduce many dependencies, so their handling is encouraged to be packaged separately. 29 | 30 | Known consumers and producers: 31 | 32 | - [json](https://github.com/kbertalan/tyttp/tree/main/json) for supporting `application/json` 33 | 34 | # Build 35 | 36 | pack build tyttp.ipkg 37 | pack build json/tyttp-json.ipkg 38 | pack build adapter-node/tyttp-adapter-node.ipkg 39 | 40 | # Test 41 | 42 | pack test tyttp 43 | pack test tyttp-json 44 | pack test tyttp-adapter-node 45 | 46 | # Run a sample from tyttp-adapter-node 47 | 48 | pack run tyttp-adapter-node 49 | 50 | # Run all builds and tests via docker 51 | 52 | docker build . -t tyttp:latest 53 | docker run --rm -it -p 3000:3000 tyttp:latest 54 | 55 | Then you can access the running application on port 3000: 56 | 57 | curl http://localhost:3000/query?query-string=will-be-sent-back 58 | -------------------------------------------------------------------------------- /json/tests/json/server/JSONServer.idr: -------------------------------------------------------------------------------- 1 | module JSONServer 2 | 3 | import Data.Buffer.Ext 4 | import JSON 5 | import JSON.Derive 6 | import TyTTP.Adapter.Node.HTTP 7 | import TyTTP.Adapter.Node.URI 8 | import TyTTP.HTTP 9 | import TyTTP.HTTP.Consumer.JSON 10 | import TyTTP.HTTP.Producer.JSON 11 | import TyTTP.URL 12 | 13 | %language ElabReflection 14 | 15 | %hide JSON.Parser.JSON 16 | 17 | record Example where 18 | constructor MkExample 19 | field : String 20 | opt : Maybe Int 21 | 22 | %runElab derive "Example" [Show, Eq, ToJSON, FromJSON] 23 | 24 | main : IO () 25 | main = do 26 | http <- HTTP.require 27 | server <- HTTP.listen' 28 | $ (\next, ctx => mapFailure message (next ctx)) 29 | $ parseUrl' (const $ sendText "URL has invalid format" >=> status BAD_REQUEST) 30 | :> routes' (sendText "Resource could not be found" >=> status NOT_FOUND) { m = Promise Error IO } 31 | [ post 32 | $ pattern "/json" 33 | $ consumes' [JSON] 34 | { a = Example } 35 | ( 36 | \ctx => liftPromise $ do 37 | printLn "failure" 38 | sendText "Content cannot be parsed: \{ctx.request.body}" ctx >>= status BAD_REQUEST 39 | ) 40 | $ \ctx => liftPromise $ do 41 | printLn "success" 42 | sendJSON ctx.request.body ctx >>= status OK 43 | ] 44 | 45 | req <- http.request "http://localhost:3000/json" ({ request.method := "POST", request.headers := Just (singleton "Content-Type" "application/json") } defaultOptions) $ \res => do 46 | res.onData $ putStrLn . show 47 | res.onEnd server.close 48 | 49 | req.write """ 50 | { 51 | "field": "a field value", 52 | "opt": 1 53 | } 54 | """ Nothing 55 | req.end Nothing 56 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http2/echo/Echo.idr: -------------------------------------------------------------------------------- 1 | module Echo 2 | 3 | import Data.Buffer.Ext 4 | import Data.List 5 | import Node.HTTP2 6 | import Node.Timers 7 | import TyTTP.Adapter.Node.HTTP2 8 | import TyTTP 9 | import TyTTP.HTTP.Protocol 10 | import TyTTP.URL 11 | 12 | hReflect : Context Method SimpleURL Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) () 13 | -> IO $ Context Method SimpleURL Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) (Publisher IO Error Buffer) 14 | hReflect ctx = do 15 | let m = ctx.request.method 16 | h = sort ctx.request.headers 17 | p : Publisher IO Error Buffer = MkPublisher $ \s => do 18 | s.onNext $ fromString "method -> \{show m}\n" 19 | s.onNext $ fromString "path -> \{ctx.request.url.path}\n" 20 | s.onNext $ fromString "headers ->\n" 21 | for_ h $ \v => s.onNext $ fromString "\t\{fst v} : \{snd v}\n" 22 | s.onNext $ fromString "body ->\n" 23 | ctx.request.body.subscribe s 24 | pure $ { response.body := p } ctx 25 | 26 | main : IO () 27 | main = do 28 | http2 <- HTTP2.require 29 | server <- listen' { e = Error, pushIO = IO } $ \_, ctx => lift $ hReflect ctx 30 | 31 | ignore $ setImmediate $ do 32 | session <- http2.connect "http://localhost:3000" defaultOptions 33 | stream <- session.get "/" =<< Headers.empty 34 | stream.onResponse $ \headers => do 35 | putStrLn "GET" 36 | stream.onData $ putStr . show 37 | session.close 38 | 39 | ignore $ setImmediate $ do 40 | session <- http2.connect "http://localhost:3000" defaultOptions 41 | stream <- session.post "/the/resource" =<< Headers.empty 42 | stream.onResponse $ \headers => do 43 | putStrLn "POST" 44 | stream.onData $ putStr . show 45 | session.close 46 | server.close 47 | 48 | stream.write "Hello World!\n" Nothing 49 | stream.write "With more chunks\n" Nothing 50 | stream.end Nothing 51 | -------------------------------------------------------------------------------- /adapter-node/src/Main.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Data.List 4 | 5 | import TyTTP.Adapter.Node.HTTP 6 | import TyTTP.HTTP 7 | import TyTTP.URL 8 | 9 | main : IO () 10 | main = do 11 | http <- Node.HTTP.require 12 | 13 | -- must set host to 0.0.0.0 if it is running in docker, otherwise 14 | -- let options = Node.HTTP.defaultOptions 15 | -- would be enough 16 | let options = { listenOptions := 17 | { port := Just 3000 18 | , host := Just "0.0.0.0" 19 | } Listen.defaultOptions 20 | } Node.HTTP.defaultOptions 21 | 22 | ignore $ listen http options { e = String } 23 | $ parseUrl' (const $ sendText "URL has invalid format" >=> status BAD_REQUEST) 24 | :> routes' (sendText "Resource could not be found" >=> status NOT_FOUND) 25 | [ get $ pattern "/query" $ \ctx => do 26 | putStrLn "serving query" 27 | sendText ctx.request.url.search ctx >>= status OK 28 | , get $ pattern "/parsed" $ Simple.search $ \ctx => do 29 | putStrLn "serving parsed" 30 | sendText (show ctx.request.url.search) ctx >>= status OK 31 | , get $ pattern "/" $ \ctx => do 32 | putStrLn "serving root" 33 | sendText "welcome adventurer" ctx >>= status OK 34 | , get $ pattern "/example/{id}" $ \ctx => do 35 | let maybeId = lookup "id" ctx.request.url.path.params 36 | putStrLn $ "parameters: \{show ctx.request.url.path.params}" 37 | sendText "id: \{show maybeId}" ctx >>= status OK 38 | , get $ pattern "/example/{id}/*" $ \ctx => do 39 | let maybeId = lookup "id" ctx.request.url.path.params 40 | putStrLn $ "parameters: \{show ctx.request.url.path.params} and rest: \{ctx.request.url.path.rest}" 41 | sendText "id: \{show maybeId} and rest: \{show ctx.request.url.path.rest}" ctx >>= status OK 42 | ] 43 | 44 | let Just port = options.listenOptions.port | Nothing => pure () 45 | putStrLn $ "started server on port " <+> show port 46 | -------------------------------------------------------------------------------- /adapter-node/tests/server/http2/push/Push.idr: -------------------------------------------------------------------------------- 1 | module Push 2 | 3 | import Data.Buffer.Ext 4 | import Data.IORef 5 | import Data.List 6 | import Node.HTTP2 7 | import Node.Timers 8 | import TyTTP.Adapter.Node.HTTP2 9 | import TyTTP.HTTP 10 | import TyTTP.URL 11 | 12 | main : IO () 13 | main = do 14 | http2 <- HTTP2.require 15 | server <- listen' {e = String} $ \push => 16 | routes' (sendText "Resource could not be found" >=> status NOT_FOUND) 17 | [ get $ pattern "/push" :> \step => do 18 | push $ MkContext 19 | { request = MkRequest 20 | { method = GET 21 | , url = MkURL (Just HTTP) (Just "localhost:3000") "/pushed.txt" "" 22 | , version = Version_2 23 | , headers = [] 24 | , body = () 25 | } 26 | , response = MkResponse 27 | { status = OK 28 | , headers = [ ("content-type", "text/plain") ] 29 | , body = singleton "this is pushed" 30 | } 31 | } 32 | sendText "this is the response" step >>= status OK 33 | ] 34 | 35 | ignore $ setImmediate $ do 36 | session <- http2.connect "http://localhost:3000" defaultOptions 37 | 38 | counter <- newIORef 2 39 | let closer = do 40 | modifyIORef counter (\x => x-1) 41 | count <- readIORef counter 42 | putStrLn "\nclose counter is at \{show count}" 43 | when (count <= 0) $ do 44 | putStrLn "closing session and server" 45 | session.close 46 | server.close 47 | 48 | session.onStream $ \stream, headers => do 49 | stream.onPush $ \headers => putStrLn $ show $ filter (\(a,b) => a /= "date") $ headers.asList 50 | putStrLn "PUSH" 51 | putStrLn $ show $ sort headers.asList 52 | stream.onData $ putStr . show 53 | stream.onEnd closer 54 | 55 | stream <- session.get "/push" =<< empty 56 | stream.onResponse $ \headers => do 57 | putStrLn "GET" 58 | stream.onData $ putStr . show 59 | stream.onEnd closer 60 | 61 | stream.end Nothing 62 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1710146030, 9 | "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "type": "github" 19 | } 20 | }, 21 | "nixpkgs": { 22 | "locked": { 23 | "lastModified": 1713995372, 24 | "narHash": "sha256-fFE3M0vCoiSwCX02z8VF58jXFRj9enYUSTqjyHAjrds=", 25 | "owner": "NixOS", 26 | "repo": "nixpkgs", 27 | "rev": "dd37924974b9202f8226ed5d74a252a9785aedf8", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "NixOS", 32 | "ref": "nixos-23.11", 33 | "repo": "nixpkgs", 34 | "type": "github" 35 | } 36 | }, 37 | "nixpkgs-unstable": { 38 | "locked": { 39 | "lastModified": 1713537308, 40 | "narHash": "sha256-XtTSSIB2DA6tOv+l0FhvfDMiyCmhoRbNB+0SeInZkbk=", 41 | "path": "/nix/store/v4pcs3nzx54m5bmxd39win0rgl2d2hbx-source", 42 | "rev": "5c24cf2f0a12ad855f444c30b2421d044120c66f", 43 | "type": "path" 44 | }, 45 | "original": { 46 | "id": "nixpkgs-unstable", 47 | "type": "indirect" 48 | } 49 | }, 50 | "root": { 51 | "inputs": { 52 | "flake-utils": "flake-utils", 53 | "nixpkgs": "nixpkgs", 54 | "nixpkgs-unstable": "nixpkgs-unstable" 55 | } 56 | }, 57 | "systems": { 58 | "locked": { 59 | "lastModified": 1681028828, 60 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 61 | "owner": "nix-systems", 62 | "repo": "default", 63 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 64 | "type": "github" 65 | }, 66 | "original": { 67 | "owner": "nix-systems", 68 | "repo": "default", 69 | "type": "github" 70 | } 71 | } 72 | }, 73 | "root": "root", 74 | "version": 7 75 | } 76 | -------------------------------------------------------------------------------- /src/TyTTP/URL/Simple.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.URL.Simple 2 | 3 | import public Control.Monad.Either 4 | import Data.List 5 | import Data.String 6 | import TyTTP 7 | import TyTTP.URL.Definition 8 | 9 | public export 10 | SimpleURL : Type 11 | SimpleURL = URL String String String 12 | 13 | public export 14 | data URLParserError 15 | = EmptyString 16 | | MissingAuthorityOrPath 17 | 18 | export -- visible for testing 19 | parse : String -> Either URLParserError SimpleURL 20 | parse str = scheme (unpack $ trim str) $ MkURL Nothing Nothing "" "" 21 | where 22 | search : List Char -> SimpleURL -> Either URLParserError SimpleURL 23 | search [] url = Right url 24 | search xs url = Right $ { search := pack xs } url 25 | 26 | path : List Char -> SimpleURL -> Either URLParserError SimpleURL 27 | path [] url = Right $ { path := "/" } url 28 | path xs url = 29 | let (p, rest) = List.break (== '?') xs 30 | in search rest $ { path := pack p } url 31 | 32 | authority : List Char -> SimpleURL -> Either URLParserError SimpleURL 33 | authority ('/' :: '/' :: xs) url = 34 | let (auth, rest) = List.break (== '/') xs 35 | in path rest $ { authority := Just $ pack auth } url 36 | authority [] _ = Left MissingAuthorityOrPath 37 | authority x url = path x url 38 | 39 | scheme : List Char -> SimpleURL -> Either URLParserError SimpleURL 40 | scheme ('h' :: 't' :: 't' :: 'p' :: xs) url = 41 | case xs of 42 | ('s' :: ':' :: ys) => authority ys $ { scheme := Just HTTPS } url 43 | (':' :: ys) => authority ys $ { scheme := Just HTTP } url 44 | xs => path ('h' :: 't' :: 't' :: 'p' :: xs) url 45 | scheme [] _ = Left EmptyString 46 | scheme xs url = authority xs url 47 | 48 | export 49 | parseUrl : MonadError URLParserError m 50 | => ( 51 | Context me SimpleURL v h1 s h2 a b 52 | -> m $ Context me' SimpleURL v' h1' s' h2' a' b' 53 | ) 54 | -> Context me String v h1 s h2 a b 55 | -> m $ Context me' String v' h1' s' h2' a' b' 56 | parseUrl handler ctx = case parse ctx.request.url of 57 | Right u => do 58 | result <- handler $ { request.url := u } ctx 59 | pure $ { request.url := ctx.request.url } result 60 | Left err => throwError err 61 | 62 | export 63 | parseUrl' : Monad m 64 | => ( 65 | URLParserError 66 | -> Context me String v h1 s h2 a b 67 | -> m $ Context me' String v' h1' s' h2' a' b' 68 | ) 69 | -> ( 70 | Context me SimpleURL v h1 s h2 a b 71 | -> EitherT URLParserError m $ Context me' SimpleURL v' h1' s' h2' a' b' 72 | ) 73 | -> Context me String v h1 s h2 a b 74 | -> m $ Context me' String v' h1' s' h2' a' b' 75 | parseUrl' errHandler handler ctx = do 76 | Right result <- runEitherT $ Simple.parseUrl handler ctx 77 | | Left err => errHandler err ctx 78 | pure result 79 | 80 | 81 | -------------------------------------------------------------------------------- /adapter-node/src/TyTTP/Adapter/Node/Static.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.Adapter.Node.Static 2 | 3 | import Data.Buffer 4 | import Data.Maybe 5 | import Data.Mime.Apache 6 | import Data.List 7 | import Control.Monad.Either 8 | import Node.Error 9 | import Node.FS 10 | import TyTTP.Adapter.Node.Error 11 | import TyTTP.Adapter.Node.HTTP 12 | import TyTTP.HTTP 13 | import TyTTP.URL 14 | import TyTTP.URL.Path 15 | 16 | public export 17 | Resource : Type 18 | Resource = String 19 | 20 | public export 21 | data FileServingError : Type where 22 | StatError : Error e => e -> FileServingError 23 | NotAFile : Resource -> FileServingError 24 | 25 | public export 26 | StaticRequest : Type -> Type 27 | StaticRequest url = Context Method url Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) () 28 | 29 | public export 30 | StaticResponse : Type -> Type 31 | StaticResponse url = Context Method url Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) (Publisher IO Error Buffer) 32 | 33 | record StaticSuccesResult where 34 | constructor MkStaticSuccessResult 35 | size : Int 36 | stream : Publisher IO Error Buffer 37 | mime : Mime 38 | 39 | export 40 | hStatic : HasIO io 41 | => (folder : String) 42 | -> (returnError : FileServingError 43 | -> StaticRequest (URL a Path s) 44 | -> io $ StaticResponse (URL a Path s) 45 | ) 46 | -> (ctx : StaticRequest (URL a Path s)) 47 | -> io $ StaticResponse (URL a Path s) 48 | hStatic folder returnError ctx = eitherT (flip returnError ctx) returnSuccess $ do 49 | let resource = ctx.request.url.path.rest 50 | file = "\{folder}\{resource}" 51 | 52 | fs <- FS.require 53 | Right stats <- fs.statSync StatsInt file 54 | | Left e => throwError $ case e.code of 55 | SystemError ENOENT => NotAFile resource 56 | _ => StatError e 57 | 58 | True <- pure $ stats.isFile 59 | | _ => throwError $ NotAFile resource 60 | 61 | False <- pure $ stats.isDirectory 62 | | _ => throwError $ NotAFile resource 63 | 64 | readStream <- fs.createReadStream file 65 | 66 | pure $ MkStaticSuccessResult 67 | { size = Stats.size stats 68 | , stream = MkPublisher $ \s => do 69 | readStream.onData s.onNext 70 | readStream.onEnd $ s.onSucceded () 71 | readStream.onError s.onFailed 72 | , mime = mimeOf file 73 | } 74 | 75 | where 76 | returnSuccess : StaticSuccesResult -> io $ StaticResponse (URL a Path s) 77 | returnSuccess result = do 78 | let hs = [ ("Content-Length", show $ result.size) 79 | , ("Content-Type", show $ result.mime) 80 | ] 81 | pure $ { response.status := OK 82 | , response.headers := hs 83 | , response.body := result.stream } ctx 84 | 85 | extensionOf' : (ext: List Char) -> (file: List Char) -> (dot: Bool) -> Maybe (List Char) 86 | extensionOf' ext ('.' :: xs) _ = extensionOf' xs xs True 87 | extensionOf' ext (x :: xs) dot = extensionOf' ext xs dot 88 | extensionOf' ext [] True = Just ext 89 | extensionOf' ext [] False = Nothing 90 | 91 | extensionOf : String -> Maybe String 92 | extensionOf file = let l = unpack file in 93 | map pack $ extensionOf' l l False 94 | 95 | mimeOf : String -> Mime 96 | mimeOf file = 97 | fromMaybe TEXT_PLAIN $ 98 | flip lookup extensions =<< extensionOf file 99 | 100 | -------------------------------------------------------------------------------- /adapter-node/src/TyTTP/Adapter/Node/HTTP.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.Adapter.Node.HTTP 2 | 3 | import public Data.Buffer 4 | import Data.Buffer.Ext 5 | import public Node.Error 6 | import public Node.HTTP 7 | import TyTTP 8 | import public TyTTP.Adapter.Node.Error 9 | import TyTTP.HTTP 10 | 11 | %hide Node.Net.Server.Server 12 | 13 | public export 14 | RawHttpRequest : Type 15 | RawHttpRequest = HttpRequest String StringHeaders $ Publisher IO Error Buffer 16 | 17 | public export 18 | RawHttpResponse : Type 19 | RawHttpResponse = Response Status StringHeaders $ Publisher IO Error Buffer 20 | 21 | toNodeResponse : RawHttpResponse -> ServerResponse -> IO () 22 | toNodeResponse res nodeRes = do 23 | let status = res.status.code 24 | headers <- mapHeaders res.headers 25 | 26 | nodeRes.writeHead status headers 27 | res.body.subscribe $ MkSubscriber 28 | { onNext = \a => nodeRes.write a Nothing } 29 | { onFailed = \e => pure () } 30 | { onSucceded = \_ => nodeRes.end Nothing { d = Buffer } } 31 | where 32 | mapHeaders : StringHeaders -> IO Headers 33 | mapHeaders h = do 34 | newHeaders <- empty 35 | foldlM (\hs, (k,v) => hs.setHeader k v) newHeaders h 36 | 37 | fromPromiseToNodeResponse : Error e 38 | => (e -> RawHttpResponse) 39 | -> Promise e IO (Context Method String Version StringHeaders Status StringHeaders b $ Publisher IO Error Buffer) 40 | -> ServerResponse 41 | -> IO () 42 | fromPromiseToNodeResponse errorHandler (MkPromise cont) nodeRes = 43 | let callbacks = MkCallbacks 44 | { onSucceded = \a => toNodeResponse a.response nodeRes } 45 | { onFailed = \e => toNodeResponse (errorHandler e) nodeRes } 46 | in 47 | cont callbacks 48 | 49 | fromNodeRequest : IncomingMessage -> RawHttpRequest 50 | fromNodeRequest nodeReq = 51 | let method = parseMethod nodeReq.method 52 | path = nodeReq.url 53 | headers = nodeReq.headers.asList 54 | version = parseVersion nodeReq.httpVersion 55 | in mkRequest method path version headers $ MkPublisher $ \s => do 56 | nodeReq.onData s.onNext 57 | nodeReq.onError s.onFailed 58 | nodeReq.onEnd $ s.onSucceded () 59 | 60 | public export 61 | record Options e where 62 | constructor MkOptions 63 | listenOptions : Listen.Options 64 | serverOptions : HTTP.CreateServer.Options 65 | errorHandler : (e -> RawHttpResponse) 66 | 67 | export 68 | defaultOptions : Error e => Adapter.Node.HTTP.Options e 69 | defaultOptions = MkOptions 70 | { listenOptions = 71 | { port := Just 3000 72 | , host := Just "localhost" 73 | } Listen.defaultOptions 74 | , serverOptions = HTTP.CreateServer.defaultOptions 75 | , errorHandler = \e => MkResponse 76 | { status = INTERNAL_SERVER_ERROR 77 | , headers = 78 | [ ("Content-Type", "text/plain") 79 | , ("Content-Length", show $ length $ TyTTP.Core.Error.message e) 80 | ] 81 | , body = singleton $ fromString $ TyTTP.Core.Error.message e 82 | } 83 | } 84 | 85 | export 86 | listen : HasIO io 87 | => Error e 88 | => HTTPModule 89 | -> Adapter.Node.HTTP.Options e 90 | -> ( 91 | Context Method String Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) () 92 | -> Promise e IO $ Context Method String Version StringHeaders Status StringHeaders b (Publisher IO Error Buffer) 93 | ) 94 | -> io Server 95 | listen http options handler = do 96 | server <- http.createServer options.serverOptions 97 | 98 | server.onRequest $ \req => \res => do 99 | let handlerReq = fromNodeRequest req 100 | initialRes = MkResponse OK [] () {h = StringHeaders} 101 | result = handler $ MkContext handlerReq initialRes 102 | 103 | fromPromiseToNodeResponse options.errorHandler result res 104 | 105 | server.listen options.listenOptions 106 | pure server 107 | 108 | export 109 | listen' : HasIO io 110 | => Error e 111 | => { auto http : HTTPModule } 112 | -> ( 113 | Context Method String Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) () 114 | -> Promise e IO $ Context Method String Version StringHeaders Status StringHeaders b (Publisher IO Error Buffer) 115 | ) 116 | -> io Server 117 | listen' {http} handler = listen http defaultOptions handler 118 | -------------------------------------------------------------------------------- /adapter-node/src/TyTTP/Adapter/Node/HTTPS.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.Adapter.Node.HTTPS 2 | 3 | import public Data.Buffer 4 | import Data.Buffer.Ext 5 | import Data.String 6 | import Data.Maybe 7 | import public Node.Error 8 | import Node.HTTP 9 | import public Node.HTTPS 10 | import TyTTP 11 | import public TyTTP.Adapter.Node.Error 12 | import TyTTP.HTTP 13 | import TyTTP.URL 14 | 15 | %hide Node.HTTP.Server.Server 16 | %hide Node.Net.Server.Server 17 | 18 | public export 19 | RawHttpRequest : Type 20 | RawHttpRequest = HttpRequest String StringHeaders $ Publisher IO Error Buffer 21 | 22 | public export 23 | RawHttpResponse : Type 24 | RawHttpResponse = Response Status StringHeaders $ Publisher IO Error Buffer 25 | 26 | public export 27 | record Options e where 28 | constructor MkOptions 29 | netServerOptions : Net.CreateServer.Options 30 | tlsServerOptions : TLS.CreateServer.Options 31 | tlsContextOptions : TLS.CreateSecureContext.Options 32 | serverOptions : HTTPS.CreateServer.Options 33 | listenOptions : Listen.Options 34 | errorHandler : e -> RawHttpResponse 35 | 36 | export 37 | defaultOptions : Error e => HTTPS.Options e 38 | defaultOptions = MkOptions 39 | { netServerOptions = Net.CreateServer.defaultOptions 40 | , tlsServerOptions = TLS.CreateServer.defaultOptions 41 | , tlsContextOptions = TLS.CreateSecureContext.defaultOptions 42 | , serverOptions = HTTPS.CreateServer.defaultOptions 43 | , listenOptions = 44 | { port := Just 3443 45 | , host := Just "localhost" 46 | } Listen.defaultOptions 47 | , errorHandler = \e => MkResponse 48 | { status = INTERNAL_SERVER_ERROR 49 | , headers = 50 | [ ("Content-Type", "text/plain") 51 | , ("Content-Length", show $ length $ TyTTP.Core.Error.message e) 52 | ] 53 | , body = singleton $ fromString $ TyTTP.Core.Error.message e 54 | } 55 | } 56 | 57 | toNodeResponse : RawHttpResponse -> ServerResponse -> IO () 58 | toNodeResponse res nodeRes = do 59 | let status = res.status.code 60 | headers <- mapHeaders res.headers 61 | 62 | nodeRes.writeHead status headers 63 | res.body.subscribe $ MkSubscriber 64 | { onNext = \a => nodeRes.write a Nothing } 65 | { onFailed = \e => pure () } 66 | { onSucceded = \_ => nodeRes.end Nothing {d = Buffer} } 67 | where 68 | mapHeaders : StringHeaders -> IO Headers 69 | mapHeaders h = do 70 | newHeaders <- empty 71 | foldlM (\hs, (k,v) => hs.setHeader k v) newHeaders h 72 | 73 | fromPromiseToNodeResponse : Error e 74 | => (e -> RawHttpResponse) 75 | -> Promise e IO (Context Method String Version StringHeaders Status StringHeaders b $ Publisher IO Error Buffer) 76 | -> ServerResponse 77 | -> IO () 78 | fromPromiseToNodeResponse errorHandler (MkPromise cont) nodeRes = 79 | let callbacks = MkCallbacks 80 | { onSucceded = \a => toNodeResponse a.response nodeRes } 81 | { onFailed = \e => toNodeResponse (errorHandler e) nodeRes } 82 | in 83 | cont callbacks 84 | 85 | fromNodeRequest : IncomingMessage -> RawHttpRequest 86 | fromNodeRequest nodeReq = 87 | let method = parseMethod nodeReq.method 88 | path = nodeReq.url 89 | headers = nodeReq.headers.asList 90 | version = parseVersion nodeReq.httpVersion 91 | in mkRequest method path version headers $ MkPublisher $ \s => do 92 | nodeReq.onData s.onNext 93 | nodeReq.onError s.onFailed 94 | nodeReq.onEnd $ s.onSucceded () 95 | 96 | export 97 | listen : HasIO io 98 | => Error e 99 | => HTTPSModule 100 | -> HTTPS.Options e 101 | -> ( 102 | Context Method String Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) () 103 | -> Promise e IO $ Context Method String Version StringHeaders Status StringHeaders b (Publisher IO Error Buffer) 104 | ) 105 | -> io Server 106 | listen https options handler = do 107 | server <- https.createServer $ MkOptions 108 | { server = options.serverOptions 109 | , context = options.tlsContextOptions 110 | , tls = options.tlsServerOptions 111 | , net = options.netServerOptions 112 | } 113 | 114 | server.onRequest $ \req => \res => do 115 | let handlerReq = fromNodeRequest req 116 | initialRes = MkResponse OK [] () {h = StringHeaders} 117 | result = handler $ MkContext handlerReq initialRes 118 | 119 | fromPromiseToNodeResponse options.errorHandler result res 120 | 121 | server.listen options.listenOptions 122 | pure server 123 | -------------------------------------------------------------------------------- /src/TyTTP/HTTP/Routing.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.HTTP.Routing 2 | 3 | import Data.Mime.Apache 4 | import Data.String 5 | 6 | import TyTTP 7 | import TyTTP.HTTP.Protocol 8 | 9 | namespace Method 10 | 11 | methodRouter : Alternative m 12 | => Method 13 | -> ( 14 | Context Method u v h1 s h2 a b 15 | -> m $ Context me' p' v' h1' s' h2' a' b' 16 | ) 17 | -> Context Method u v h1 s h2 a b 18 | -> m $ Context me' p' v' h1' s' h2' a' b' 19 | methodRouter m handler ctx = 20 | if ctx.request.method == m 21 | then handler ctx 22 | else empty 23 | 24 | export 25 | options : Alternative m 26 | => ( 27 | Context Method u v h1 s h2 a b 28 | -> m $ Context me' p' v' h1' s' h2' a' b' 29 | ) 30 | -> Context Method u v h1 s h2 a b 31 | -> m $ Context me' p' v' h1' s' h2' a' b' 32 | options = methodRouter OPTIONS 33 | 34 | export 35 | get : Alternative m 36 | => ( 37 | Context Method u v h1 s h2 a b 38 | -> m $ Context me' p' v' h1' s' h2' a' b' 39 | ) 40 | -> Context Method u v h1 s h2 a b 41 | -> m $ Context me' p' v' h1' s' h2' a' b' 42 | get = methodRouter GET 43 | 44 | export 45 | head : Alternative m 46 | => ( 47 | Context Method u v h1 s h2 a b 48 | -> m $ Context me' p' v' h1' s' h2' a' b' 49 | ) 50 | -> Context Method u v h1 s h2 a b 51 | -> m $ Context me' p' v' h1' s' h2' a' b' 52 | head = methodRouter HEAD 53 | 54 | export 55 | post : Alternative m 56 | => ( 57 | Context Method u v h1 s h2 a b 58 | -> m $ Context me' p' v' h1' s' h2' a' b' 59 | ) 60 | -> Context Method u v h1 s h2 a b 61 | -> m $ Context me' p' v' h1' s' h2' a' b' 62 | post = methodRouter POST 63 | 64 | export 65 | put : Alternative m 66 | => ( 67 | Context Method u v h1 s h2 a b 68 | -> m $ Context me' p' v' h1' s' h2' a' b' 69 | ) 70 | -> Context Method u v h1 s h2 a b 71 | -> m $ Context me' p' v' h1' s' h2' a' b' 72 | put = methodRouter PUT 73 | 74 | export 75 | delete : Alternative m 76 | => ( 77 | Context Method u v h1 s h2 a b 78 | -> m $ Context me' p' v' h1' s' h2' a' b' 79 | ) 80 | -> Context Method u v h1 s h2 a b 81 | -> m $ Context me' p' v' h1' s' h2' a' b' 82 | delete = methodRouter DELETE 83 | 84 | export 85 | trace : Alternative m 86 | => ( 87 | Context Method u v h1 s h2 a b 88 | -> m $ Context me' p' v' h1' s' h2' a' b' 89 | ) 90 | -> Context Method u v h1 s h2 a b 91 | -> m $ Context me' p' v' h1' s' h2' a' b' 92 | trace = methodRouter TRACE 93 | 94 | export 95 | connect : Alternative m 96 | => ( 97 | Context Method u v h1 s h2 a b 98 | -> m $ Context me' p' v' h1' s' h2' a' b' 99 | ) 100 | -> Context Method u v h1 s h2 a b 101 | -> m $ Context me' p' v' h1' s' h2' a' b' 102 | connect = methodRouter CONNECT 103 | 104 | export 105 | other : Alternative m 106 | => String 107 | -> ( 108 | Context Method u v h1 s h2 a b 109 | -> m $ Context me' p' v' h1' s' h2' a' b' 110 | ) 111 | -> Context Method u v h1 s h2 a b 112 | -> m $ Context me' p' v' h1' s' h2' a' b' 113 | other str = methodRouter (OtherMethod str) 114 | 115 | namespace ContentType 116 | 117 | stringMatchesMime : Mime -> String -> Bool 118 | stringMatchesMime mime candidate = 119 | let mimeString = show mime 120 | in isPrefixOf mimeString $ toLower candidate 121 | 122 | export 123 | contentType : Alternative m 124 | => HasContentType h1 125 | => Mime 126 | -> ( 127 | Context me u v h1 s h2 a b 128 | -> m $ Context me' p' v' h1' s' h2' a' b' 129 | ) 130 | -> Context me u v h1 s h2 a b 131 | -> m $ Context me' p' v' h1' s' h2' a' b' 132 | contentType mime handler ctx = 133 | case stringMatchesMime mime <$> getContentType ctx.request.headers of 134 | Just True => handler ctx 135 | _ => empty 136 | 137 | export 138 | json : Alternative m 139 | => HasContentType h1 140 | => ( 141 | Context me u v h1 s h2 a b 142 | -> m $ Context me' p' v' h1 s' h2' a' b' 143 | ) 144 | -> Context me u v h1 s h2 a b 145 | -> m $ Context me' p' v' h1 s' h2' a' b' 146 | json = contentType APPLICATION_JSON 147 | 148 | export 149 | text : Alternative m 150 | => HasContentType h1 151 | => ( 152 | Context me u v h1 s h2 a b 153 | -> m $ Context me' p' v' h1 s' h2' a' b' 154 | ) 155 | -> Context me u v h1 s h2 a b 156 | -> m $ Context me' p' v' h1 s' h2' a' b' 157 | text = contentType TEXT_PLAIN 158 | 159 | export 160 | binary : Alternative m 161 | => HasContentType h1 162 | => ( 163 | Context me u v h1 s h2 a b 164 | -> m $ Context me' p' v' h1 s' h2' a' b' 165 | ) 166 | -> Context me u v h1 s h2 a b 167 | -> m $ Context me' p' v' h1 s' h2' a' b' 168 | binary = contentType APPLICATION_OCTET_STREAM 169 | -------------------------------------------------------------------------------- /src/TyTTP/URL/Path.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.URL.Path 2 | 3 | import Data.List 4 | import Data.String 5 | import public Data.Either 6 | import TyTTP 7 | import TyTTP.URL.Definition 8 | 9 | %default total 10 | 11 | data Elem : Type where 12 | Literal : List Char -> Elem 13 | Param : List Char -> Elem 14 | Rest : Elem 15 | 16 | Eq Elem where 17 | (==) (Literal s1) (Literal s2) = s1 == s2 18 | (==) (Param s1) (Param s2) = s1 == s2 19 | (==) Rest Rest = True 20 | (==) _ _ = False 21 | 22 | data ParseState 23 | = InLiteral (List Char) 24 | | InParam (List Char) 25 | | InRest 26 | 27 | public export 28 | data ParseError 29 | = EmptyPattern 30 | | ParamShouldFollowALiteral String (List Elem) 31 | | RestShouldFollowALiteral String (List Elem) 32 | | ParamAlreadyDefined String (List Elem) 33 | | ParamEmpty String (List Elem) 34 | | UnclosedParam String (List Elem) 35 | | InvalidStartCharInParam Char (List Elem) 36 | | InvalidCharInParam Char (List Elem) 37 | | RestShouldBeLast String (List Elem) 38 | 39 | export 40 | data ParsedPattern : (0 s : String) -> Type where 41 | MkParsedPattern : List Elem -> ParsedPattern s 42 | 43 | public export 44 | parse : (s : String) -> Either ParseError (ParsedPattern s) 45 | parse "" = Left EmptyPattern 46 | parse s = map (MkParsedPattern . reverse) $ go (InLiteral []) [] $ unpack s 47 | where 48 | isAllowedInParam : Char -> Bool 49 | isAllowedInParam c = isAlpha c || c == '-' || c == '_' 50 | 51 | go : ParseState -> List Elem -> List Char -> Either ParseError $ List Elem 52 | go (InLiteral []) p r@('{' :: xs) = Left $ ParamShouldFollowALiteral (pack r) $ reverse p 53 | go (InLiteral s) p ('{' :: xs) = go (InParam []) (Literal (reverse s) :: p) xs 54 | go (InLiteral []) p r@('*' :: xs) = Left $ RestShouldFollowALiteral (pack r) $ reverse p 55 | go (InLiteral s) p ('*' :: xs) = go InRest (Literal (reverse s) :: p) xs 56 | go (InLiteral []) p ['/'] = Right $ Literal ['/'] :: p 57 | go (InLiteral s) p ['/'] = Right $ Literal (reverse s) :: p 58 | go (InLiteral []) p [] = Right p 59 | go (InLiteral s) p [] = Right $ Literal (reverse s) :: p 60 | go (InLiteral s) p (x :: xs) = go (InLiteral $ x :: s) p xs 61 | go (InParam s) p r@('}' :: xs) = 62 | let name = reverse s 63 | param = Param name 64 | in do 65 | False <- pure $ elem param p 66 | | True => Left $ ParamAlreadyDefined (pack name) $ reverse p 67 | False <- pure $ null name 68 | | True => Left $ ParamEmpty (pack $ '{' :: r) $ reverse p 69 | go (InLiteral []) (param :: p) xs 70 | go (InParam s) p [] = Left $ UnclosedParam (pack $ reverse s) $ reverse p 71 | go (InParam []) p (x :: xs) = 72 | if isAlpha x 73 | then go (InParam [x]) p xs 74 | else Left $ InvalidStartCharInParam x $ reverse p 75 | go (InParam s) p (x :: xs) = 76 | if isAllowedInParam x 77 | then go (InParam (x :: s)) p xs 78 | else Left $ InvalidCharInParam x $ reverse p 79 | go InRest p [] = Right $ Rest :: p 80 | go InRest p r@(x :: _) = Left $ RestShouldBeLast (pack r) $ reverse p 81 | 82 | public export 83 | record Path where 84 | constructor MkPath 85 | raw : String 86 | params : List (String, String) 87 | rest : String 88 | 89 | matcher : (s : String) -> ParsedPattern str -> Maybe Path 90 | matcher s (MkParsedPattern ls) = go ls (unpack s) $ MkPath s [] "" 91 | where 92 | 93 | consumeLiteral : List Char -> List Char -> Maybe $ List Char 94 | consumeLiteral [] xs = Just xs 95 | consumeLiteral (_::_) [] = Nothing 96 | consumeLiteral (l::ls) (x::xs) = 97 | case l == x of 98 | True => consumeLiteral ls xs 99 | False => Nothing 100 | 101 | go : List Elem -> List Char -> Path -> Maybe Path 102 | go [] [] p = Just p 103 | go [] xs _ = Nothing 104 | go (Literal l :: ps) xs p = do 105 | remaining <- consumeLiteral l xs 106 | go ps (assert_smaller xs remaining) p 107 | go (Param param :: Literal l@(f::fs) :: ps) xs p = 108 | let (value, remaining) = List.break (==f) xs 109 | in if null value 110 | then Nothing 111 | else go (Literal l :: ps) (assert_smaller xs remaining) $ { params $= ((pack param, pack value)::) } p 112 | go (Param param :: Nil) xs p = 113 | let (value, remaining) = List.break (=='/') xs 114 | in if null value || not (null remaining) 115 | then Nothing 116 | else Just $ { params $= ((pack param, pack value)::) } p 117 | go (Rest :: Nil) xs p = Just $ { rest := pack xs } p 118 | go _ _ _ = Nothing 119 | 120 | export 121 | pattern : Monad m 122 | => Alternative m 123 | => (str : String) 124 | -> {auto 0 ok : IsRight (Path.parse str)} 125 | -> ( 126 | Context me (URL auth Path s) v h1 st h2 a b 127 | -> m $ Context me' (URL auth Path s) v' h1' st' h2' a' b' 128 | ) 129 | -> Context me (URL auth String s) v h1 st h2 a b 130 | -> m $ Context me' (URL auth String s) v' h1' st' h2' a' b' 131 | pattern str {ok} handler ctx with (Path.parse str) 132 | _ | Right parsedPattern = 133 | case matcher ctx.request.url.path parsedPattern of 134 | Just p => do 135 | result <- handler $ { request.url := { path := p } ctx.request.url } ctx 136 | pure $ { request.url := { path := ctx.request.url.path } result.request.url } result 137 | Nothing => empty 138 | -------------------------------------------------------------------------------- /src/TyTTP/HTTP/Consumer.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.HTTP.Consumer 2 | 3 | import Control.Monad.Trans 4 | import Control.Monad.Either 5 | import Data.Buffer 6 | import Data.List 7 | import public Data.List.Quantifiers 8 | import Data.Maybe 9 | import Data.SnocList 10 | import Data.IORef 11 | import TyTTP 12 | import TyTTP.HTTP.Protocol 13 | 14 | public export 15 | interface Accept t where 16 | contentType : (ty : Type) -> { auto p : ty = t } -> List String 17 | 18 | public export 19 | data IsAccept : (t : Type) -> Type where 20 | ItIsAccept : Accept t => IsAccept t 21 | 22 | public export 23 | ConsumerError : Type 24 | ConsumerError = String 25 | 26 | public export 27 | interface Accept t => Consumer a t where 28 | consumeRaw : (ty : Type) -> { auto p : ty = t } -> (ct : String) -> (raw : Buffer) -> Either ConsumerError a 29 | 30 | public export 31 | data IsConsumer : (a : Type) -> (t : Type) -> Type where 32 | ItIsConsumer : Consumer a t => IsConsumer a t 33 | 34 | ||| This function consumes the stream from the underlying server, thus the original stream cannot be used twice. 35 | ||| If you make sure that the original stream is not used twice, then this function can be used. 36 | export 37 | unsafeConsumeBody : Error e 38 | => HasIO m 39 | => MonadPromise e m p 40 | => ( 41 | Context me u v h1 s h2 Buffer b 42 | -> (forall p'. MonadPromise e m p' => p' $ Context me' u' v' h1' s' h2' a' b') 43 | ) 44 | -> Context me u v h1 s h2 (Publisher m e Buffer) b 45 | -> p $ Context me' u' v' h1' s' h2' a' b' 46 | unsafeConsumeBody handler ctx = promise $ \resolve', reject' => do 47 | acc <- newIORef Lin 48 | let subscriber : Subscriber m e Buffer = MkSubscriber 49 | { onNext = \a => modifyIORef acc (:< a) 50 | , onSucceded = \_ => do 51 | all <- concatBuffers =<< asList <$> readIORef acc 52 | Just emptyBuffer <- newBuffer 0 | _ => assert_total $ idris_crash "creating an empty buffer has failed" 53 | let result = handler $ { request.body := fromMaybe emptyBuffer all } ctx 54 | runPromise { m = m } resolve' reject' result 55 | , onFailed = reject' 56 | } 57 | ctx.request.body.subscribe subscriber 58 | 59 | consumePayload : 60 | (t : Type) 61 | -> (isConsumer : IsConsumer a t) 62 | -> (ct : String) 63 | -> (raw : Buffer) 64 | -> Either ConsumerError a 65 | consumePayload t ItIsConsumer ct raw = 66 | consumeRaw t ct raw 67 | 68 | safeConsume : 69 | Error e 70 | => MonadTrans t 71 | => MonadPromise e IO m 72 | => Alternative (t m) 73 | => HasContentType h1 74 | => (list: List Type) 75 | -> (areAccepts : All IsAccept list) 76 | -> (areConsumers : All (IsConsumer a) list) 77 | -> (ct : String) 78 | -> ( 79 | Context me u v h1 s h2 (Either ConsumerError a) b 80 | -> (forall m'. MonadPromise e IO m' => m' $ Context me' u' v' h1' s' h2' a' b') 81 | ) 82 | -> Context me u v h1 s h2 (Publisher IO e Buffer) b 83 | -> t m $ Context me' u' v' h1' s' h2' (Publisher IO e Buffer) b' 84 | safeConsume [] _ _ _ _ _ = empty 85 | safeConsume (t::ts) (ItIsAccept::as) (c::cs) ct handler ctx = 86 | if elem ct (contentType t) 87 | then lift $ flip unsafeConsumeBody ctx $ \ctx' => promise $ \resolve' ,reject' => do 88 | let raw = ctx'.request.body 89 | result = handler $ { request.body := consumePayload t c ct raw } ctx' 90 | success = \r => resolve' $ { request.body := singleton raw } r 91 | runPromise { m = IO } success reject' result 92 | else safeConsume ts as cs ct handler ctx 93 | 94 | export 95 | consumes : 96 | Error e 97 | => MonadTrans t 98 | => MonadPromise e IO m 99 | => Alternative (t m) 100 | => HasContentType h1 101 | => (list: List Type) 102 | -> {auto isNonEmpty : NonEmpty list} 103 | -> {auto areAccepts : All IsAccept list} 104 | -> {auto areConsumers : All (IsConsumer a) list} 105 | -> ( 106 | Context me u v h1 s h2 (Either ConsumerError a) b 107 | -> (forall m'. MonadPromise e IO m' => m' $ Context me' u' v' h1' s' h2' a' b') 108 | ) 109 | -> Context me u v h1 s h2 (Publisher IO e Buffer) b 110 | -> t m $ Context me' u' v' h1' s' h2' (Publisher IO e Buffer) b' 111 | consumes list {isNonEmpty} {areAccepts} {areConsumers} handler ctx = do 112 | let Just ct = getContentType ctx.request.headers 113 | | _ => empty 114 | 115 | safeConsume list areAccepts areConsumers ct handler ctx 116 | 117 | export 118 | consumes' : 119 | Error e 120 | => MonadTrans t 121 | => MonadPromise e IO m 122 | => Alternative (t m) 123 | => HasContentType h1 124 | => (list: List Type) 125 | -> {auto isNonEmpty : NonEmpty list} 126 | -> {auto areAccepts : All IsAccept list} 127 | -> {auto areConsumers : All (IsConsumer a) list} 128 | -> ( 129 | Context me u v h1 s h2 ConsumerError b 130 | -> (forall m'. MonadPromise e IO m' => m' $ Context me' u' v' h1' s' h2' a' b') 131 | ) 132 | -> ( 133 | Context me u v h1 s h2 a b 134 | -> (forall m''. MonadPromise e IO m'' => m'' $ Context me' u' v' h1' s' h2' a'' b') 135 | ) 136 | -> Context me u v h1 s h2 (Publisher IO e Buffer) b 137 | -> t m $ Context me' u' v' h1' s' h2' (Publisher IO e Buffer) b' 138 | consumes' list {isNonEmpty} {areAccepts} {areConsumers} errHandler handler ctx = 139 | let handler' : 140 | Context me u v h1 s h2 (Either ConsumerError a) b 141 | -> (forall m'. MonadPromise e IO m' => m' $ Context me' u' v' h1' s' h2' () b') 142 | handler' s = 143 | case s.request.body of 144 | Right r => do 145 | result <- handler $ { request.body := r } s 146 | pure $ { request.body := () } result 147 | Left l => do 148 | result <- errHandler $ { request.body := l } s 149 | pure $ { request.body := () } result 150 | in consumes list handler' ctx 151 | -------------------------------------------------------------------------------- /src/TyTTP/HTTP/Protocol.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.HTTP.Protocol 2 | 3 | import Data.List 4 | import TyTTP 5 | 6 | public export 7 | data Method 8 | = OPTIONS 9 | | GET 10 | | HEAD 11 | | POST 12 | | PUT 13 | | DELETE 14 | | TRACE 15 | | CONNECT 16 | | OtherMethod String 17 | 18 | export 19 | Eq Method where 20 | (==) OPTIONS OPTIONS = True 21 | (==) GET GET = True 22 | (==) HEAD HEAD = True 23 | (==) POST POST = True 24 | (==) PUT PUT = True 25 | (==) DELETE DELETE = True 26 | (==) TRACE TRACE = True 27 | (==) CONNECT CONNECT = True 28 | (==) (OtherMethod a) (OtherMethod b) = a == b 29 | (==) _ _ = False 30 | 31 | export 32 | Show Method where 33 | show m = case m of 34 | OPTIONS => "OPTIONS" 35 | GET => "GET" 36 | HEAD => "HEAD" 37 | POST => "POST" 38 | PUT => "PUT" 39 | DELETE => "DELETE" 40 | TRACE => "TRACE" 41 | CONNECT => "CONNECT" 42 | OtherMethod str => str 43 | 44 | 45 | export 46 | parseMethod : String -> Method 47 | parseMethod str = case str of 48 | "OPTIONS" => OPTIONS 49 | "GET" => GET 50 | "HEAD" => HEAD 51 | "POST" => POST 52 | "PUT" => PUT 53 | "DELETE" => DELETE 54 | "TRACE" => TRACE 55 | "CONNECT" => CONNECT 56 | s => OtherMethod s 57 | 58 | public export 59 | data Version 60 | = Version_1_0 61 | | Version_1_1 62 | | Version_2 63 | | OtherVersion String 64 | 65 | export 66 | Eq Version where 67 | (==) Version_1_0 Version_1_0 = True 68 | (==) Version_1_1 Version_1_1 = True 69 | (==) Version_2 Version_2 = True 70 | (==) (OtherVersion v1) (OtherVersion v2) = v1 == v2 71 | (==) _ _ = False 72 | 73 | export 74 | Show Version where 75 | show v = case v of 76 | Version_1_0 => "1.0" 77 | Version_1_1 => "1.1" 78 | Version_2 => "2.0" 79 | OtherVersion v => v 80 | 81 | export 82 | parseVersion : String -> Version 83 | parseVersion s = case s of 84 | "1.0" => Version_1_0 85 | "1.1" => Version_1_1 86 | "2.0" => Version_2 87 | v => OtherVersion v 88 | 89 | public export 90 | StringHeaders : Type 91 | StringHeaders = List (String, String) 92 | 93 | public export 94 | interface HasContentType a where 95 | getContentType : a -> Maybe String 96 | 97 | export 98 | implementation HasContentType StringHeaders where 99 | getContentType headers = lookup "content-type" headers 100 | 101 | 102 | public export 103 | HttpRequest : Type -> Type -> Type -> Type 104 | HttpRequest p h a = Request Method p Version h a 105 | 106 | export 107 | mkRequest : (m : Method) -> p -> Version -> h -> a -> HttpRequest p h a 108 | mkRequest m p v h a = MkRequest m p v h a 109 | 110 | public export 111 | data Status 112 | = CONTINUE 113 | | SWITCHING_PROTOCOLS 114 | | PROCESSING 115 | | EARLY_HINTS 116 | | OK 117 | | CREATED 118 | | ACCEPTED 119 | | NON_AUTHORITATIVE_INFORMATION 120 | | NO_CONTENT 121 | | RESET_CONTENT 122 | | PARTIAL_CONTENT 123 | | MULTI_STATUS 124 | | ALREADY_REPORTED 125 | | IM_USED 126 | | MULTIPLE_CHOICES 127 | | MOVED_PERMANENTLY 128 | | FOUND 129 | | SEE_OTHER 130 | | NOT_MODIFIED 131 | | USE_PROXY 132 | | TEMPORARY_REDIRECT 133 | | PERMANENT_REDIRECT 134 | | BAD_REQUEST 135 | | UNAUTHORIZED 136 | | PAYMENT_REQUIRED 137 | | FORBIDDEN 138 | | NOT_FOUND 139 | | METHOD_NOT_ALLOWED 140 | | NOT_ACCEPTABLE 141 | | PROXY_AUTHENTICATION_REQUIRED 142 | | REQUEST_TIMEOUT 143 | | CONFLICT 144 | | GONE 145 | | LENGTH_REQUIRED 146 | | PRECONDITION_FAILED 147 | | PAYLOAD_TOO_LARGE 148 | | URI_TOO_LONG 149 | | UNSUPPORTED_MEDIA_TYPE 150 | | RANGE_NOT_SATISFIABLE 151 | | EXPECTATION_FAILED 152 | | TEAPOT 153 | | MISDIRECTED_REQUEST 154 | | UNPROCESSABLE_ENTITY 155 | | LOCKED 156 | | FAILED_DEPENDENCY 157 | | TOO_EARLY 158 | | UPGRADE_REQUIRED 159 | | PRECONDITION_REQUIRED 160 | | TOO_MANY_REQUESTS 161 | | REQUEST_HEADER_FIELDS_TOO_LARGE 162 | | UNAVAILABLE_FOR_LEGAL_REASONS 163 | | INTERNAL_SERVER_ERROR 164 | | NOT_IMPLEMENTED 165 | | BAD_GATEWAY 166 | | SERVICE_UNAVAILABLE 167 | | GATEWAY_TIMEOUT 168 | | HTTP_VERSION_NOT_SUPPORTED 169 | | VARIANT_ALSO_NEGOTIATES 170 | | INSUFFICIENT_STORAGE 171 | | LOOP_DETECTED 172 | | BANDWIDTH_LIMIT_EXCEEDED 173 | | NOT_EXTENDED 174 | | NETWORK_AUTHENTICATION_REQUIRED 175 | 176 | export 177 | (.code) : Status -> Int 178 | (.code) status = case status of 179 | CONTINUE => 100 180 | SWITCHING_PROTOCOLS => 101 181 | PROCESSING => 102 182 | EARLY_HINTS => 103 183 | OK => 200 184 | CREATED => 201 185 | ACCEPTED => 202 186 | NON_AUTHORITATIVE_INFORMATION => 203 187 | NO_CONTENT => 204 188 | RESET_CONTENT => 205 189 | PARTIAL_CONTENT => 206 190 | MULTI_STATUS => 207 191 | ALREADY_REPORTED => 208 192 | IM_USED => 226 193 | MULTIPLE_CHOICES => 300 194 | MOVED_PERMANENTLY => 301 195 | FOUND => 302 196 | SEE_OTHER => 303 197 | NOT_MODIFIED => 304 198 | USE_PROXY => 305 199 | TEMPORARY_REDIRECT => 307 200 | PERMANENT_REDIRECT => 308 201 | BAD_REQUEST => 400 202 | UNAUTHORIZED => 401 203 | PAYMENT_REQUIRED => 402 204 | FORBIDDEN => 403 205 | NOT_FOUND => 404 206 | METHOD_NOT_ALLOWED => 405 207 | NOT_ACCEPTABLE => 406 208 | PROXY_AUTHENTICATION_REQUIRED => 407 209 | REQUEST_TIMEOUT => 408 210 | CONFLICT => 409 211 | GONE => 410 212 | LENGTH_REQUIRED => 411 213 | PRECONDITION_FAILED => 412 214 | PAYLOAD_TOO_LARGE => 413 215 | URI_TOO_LONG => 414 216 | UNSUPPORTED_MEDIA_TYPE => 415 217 | RANGE_NOT_SATISFIABLE => 416 218 | EXPECTATION_FAILED => 417 219 | TEAPOT => 418 220 | MISDIRECTED_REQUEST => 421 221 | UNPROCESSABLE_ENTITY => 422 222 | LOCKED => 423 223 | FAILED_DEPENDENCY => 424 224 | TOO_EARLY => 425 225 | UPGRADE_REQUIRED => 426 226 | PRECONDITION_REQUIRED => 428 227 | TOO_MANY_REQUESTS => 429 228 | REQUEST_HEADER_FIELDS_TOO_LARGE => 431 229 | UNAVAILABLE_FOR_LEGAL_REASONS => 451 230 | INTERNAL_SERVER_ERROR => 500 231 | NOT_IMPLEMENTED => 501 232 | BAD_GATEWAY => 502 233 | SERVICE_UNAVAILABLE => 503 234 | GATEWAY_TIMEOUT => 504 235 | HTTP_VERSION_NOT_SUPPORTED => 505 236 | VARIANT_ALSO_NEGOTIATES => 506 237 | INSUFFICIENT_STORAGE => 507 238 | LOOP_DETECTED => 508 239 | BANDWIDTH_LIMIT_EXCEEDED => 509 240 | NOT_EXTENDED => 510 241 | NETWORK_AUTHENTICATION_REQUIRED => 511 242 | 243 | -------------------------------------------------------------------------------- /adapter-node/src/TyTTP/Adapter/Node/HTTP2.idr: -------------------------------------------------------------------------------- 1 | module TyTTP.Adapter.Node.HTTP2 2 | 3 | import public Data.Buffer 4 | import Data.Buffer.Ext 5 | import Data.String 6 | import Data.Maybe 7 | import public Node.Error 8 | import public Node.HTTP2 9 | import Node.JS.Misc 10 | import Node.JS.Std.JSON 11 | import TyTTP 12 | import TyTTP.URL 13 | import public TyTTP.Adapter.Node.Error 14 | import TyTTP.HTTP 15 | 16 | namespace Fields 17 | 18 | public export 19 | data RequestPseudoHeaderField 20 | = Method 21 | | Scheme 22 | | Authority 23 | | Path 24 | 25 | public export 26 | Show RequestPseudoHeaderField where 27 | show f = case f of 28 | Method => ":method" 29 | Scheme => ":scheme" 30 | Authority => ":authority" 31 | Path => ":path" 32 | 33 | public export 34 | data ResponsePseudoHeaderField 35 | = Status 36 | 37 | public export 38 | Show ResponsePseudoHeaderField where 39 | show Status = ":status" 40 | 41 | public export 42 | RawHttpRequest : Type 43 | RawHttpRequest = HttpRequest SimpleURL StringHeaders $ Publisher IO Error Buffer 44 | 45 | public export 46 | RawHttpResponse : Type 47 | RawHttpResponse = Response Status StringHeaders $ Publisher IO Error Buffer 48 | 49 | public export 50 | PushContext : Type 51 | PushContext = Context Method SimpleURL Version StringHeaders Status StringHeaders () $ Publisher IO Error Buffer 52 | 53 | sendResponse : RawHttpResponse -> ServerHttp2Stream -> IO () 54 | sendResponse res stream = do 55 | let status = res.status.code 56 | headers <- mapHeaders res.headers status 57 | 58 | stream.respond headers 59 | res.body.subscribe $ MkSubscriber 60 | { onNext = \a => stream.write a Nothing } 61 | { onFailed = \e => pure () } 62 | { onSucceded = \_ => stream.end Nothing { d = Buffer } } 63 | where 64 | mapHeaders : StringHeaders -> Int -> IO Headers 65 | mapHeaders h s = do 66 | let newHeaders = singleton (show Fields.Status) (show s) 67 | foldlM (\hs, (k,v) => hs.setHeader k v) newHeaders h 68 | 69 | sendResponseFromPromise : Error e 70 | => (String -> RawHttpResponse) 71 | -> Promise e IO (Context Method SimpleURL Version StringHeaders Status StringHeaders b $ Publisher IO Error Buffer) 72 | -> ServerHttp2Stream 73 | -> IO () 74 | sendResponseFromPromise errorHandler (MkPromise cont) stream = 75 | let callbacks = MkCallbacks 76 | { onSucceded = \a => sendResponse a.response stream } 77 | { onFailed = \e => sendResponse (errorHandler $ TyTTP.Core.Error.message e) stream } 78 | in 79 | cont callbacks 80 | 81 | parseRequest : ServerHttp2Stream -> Headers -> Either String RawHttpRequest 82 | parseRequest stream headers = 83 | let Just method = parseMethod <$> headers.getHeader (show Fields.Method) 84 | | Nothing => Left "Method header is missing from request" 85 | scheme = parse <$> headers.getHeader (show Fields.Scheme) 86 | authority = headers.getHeader (show Fields.Authority) 87 | Just pathAndSearch = headers.getHeader (show Fields.Path) 88 | | Nothing => Left "Path header is missing from request" 89 | (path, search) = String.break (=='?') pathAndSearch 90 | url = MkURL scheme authority path search 91 | version = Version_2 92 | in Right $ mkRequest method url version headers.asList $ MkPublisher $ \s => do 93 | stream.onData s.onNext 94 | (Readable.(.onError)) stream s.onFailed 95 | stream.onEnd $ s.onSucceded () 96 | 97 | pusher : HasIO io => ServerHttp2Stream -> Lazy PushContext -> io () 98 | pusher parent ctx = do 99 | reqHeaders <- mapHeaders $ ctx.request.headers 100 | <+> (maybe [] pure $ map ((show Fields.Scheme,) . show) ctx.request.url.scheme) 101 | <+> (maybe [] pure $ map (show Fields.Authority,) ctx.request.url.authority) 102 | <+> [ (show Fields.Method, show ctx.request.method) 103 | , (show Fields.Path, ctx.request.url.path) 104 | ] 105 | parent.pushStream reqHeaders $ \err, stream, headers => do 106 | if truthy err then putStrLn "ERROR: \{JSON.stringify err 2}" 107 | else sendResponse ctx.response stream 108 | where 109 | mapHeaders : StringHeaders -> io Headers 110 | mapHeaders h = do 111 | newHeaders <- empty 112 | foldlM (\hs, (k,v) => hs.setHeader k v) newHeaders h 113 | 114 | public export 115 | record Options where 116 | constructor MkOptions 117 | netServerOptions : Net.CreateServer.Options 118 | serverOptions : HTTP2.CreateServer.Options 119 | listenOptions : Listen.Options 120 | errorHandler : String -> RawHttpResponse 121 | 122 | export 123 | defaultOptions : HTTP2.Options 124 | defaultOptions = MkOptions 125 | { netServerOptions = Net.CreateServer.defaultOptions 126 | , serverOptions = HTTP2.CreateServer.defaultOptions 127 | , listenOptions = 128 | { port := Just 3000 129 | , host := Just "localhost" 130 | } Listen.defaultOptions 131 | , errorHandler = \e => MkResponse 132 | { status = INTERNAL_SERVER_ERROR 133 | , headers = 134 | [ ("Content-Type", "text/plain") 135 | , ("Content-Length", show $ length e) 136 | ] 137 | , body = singleton $ fromString e 138 | } 139 | } 140 | 141 | export 142 | listen : HasIO io 143 | => HasIO pushIO 144 | => Error e 145 | => HTTP2Module 146 | -> HTTP2.Options 147 | -> ( 148 | (Lazy PushContext -> pushIO ()) 149 | -> Context Method SimpleURL Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) () 150 | -> Promise e IO $ Context Method SimpleURL Version StringHeaders Status StringHeaders b (Publisher IO Error Buffer) 151 | ) 152 | -> io Http2Server 153 | listen http2 options handler = do 154 | server <- http2.createServer $ MkOptions 155 | { server = options.serverOptions 156 | , net = options.netServerOptions 157 | } 158 | 159 | server.onStream $ \stream, headers => do 160 | let Right req = parseRequest stream headers 161 | | Left err => sendResponse (options.errorHandler err) stream 162 | initialRes = MkResponse OK [] () {h = StringHeaders} 163 | push = if stream.pushAllowed then pusher stream 164 | else const $ pure () 165 | result = handler push $ MkContext req initialRes 166 | 167 | sendResponseFromPromise options.errorHandler result stream 168 | 169 | server.listen options.listenOptions 170 | pure server 171 | 172 | export 173 | listen' : HasIO io 174 | => HasIO pushIO 175 | => Error e 176 | => { auto http2 : HTTP2Module } 177 | -> ( 178 | (Lazy PushContext -> pushIO ()) 179 | -> Context Method SimpleURL Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) () 180 | -> Promise e IO $ Context Method SimpleURL Version StringHeaders Status StringHeaders b (Publisher IO Error Buffer) 181 | ) 182 | -> io Http2Server 183 | listen' {http2} handler = listen http2 defaultOptions handler 184 | 185 | namespace Secure 186 | 187 | public export 188 | record Options where 189 | constructor MkOptions 190 | netServerOptions : Net.CreateServer.Options 191 | tlsServerOptions : TLS.CreateServer.Options 192 | tlsContextOptions : TLS.CreateSecureContext.Options 193 | serverOptions : HTTP2.CreateSecureServer.Options 194 | listenOptions : Listen.Options 195 | errorHandler : String -> RawHttpResponse 196 | 197 | export 198 | defaultOptions : HTTP2.Secure.Options 199 | defaultOptions = MkOptions 200 | { netServerOptions = Net.CreateServer.defaultOptions 201 | , tlsServerOptions = TLS.CreateServer.defaultOptions 202 | , tlsContextOptions = TLS.CreateSecureContext.defaultOptions 203 | , serverOptions = HTTP2.CreateSecureServer.defaultOptions 204 | , listenOptions = 205 | { port := Just 3443 206 | , host := Just "localhost" 207 | } Listen.defaultOptions 208 | , errorHandler = \e => MkResponse 209 | { status = INTERNAL_SERVER_ERROR 210 | , headers = 211 | [ ("Content-Type", "text/plain") 212 | , ("Content-Length", show $ length e) 213 | ] 214 | , body = singleton $ fromString e 215 | } 216 | } 217 | 218 | export 219 | listen : HasIO io 220 | => HasIO pushIO 221 | => Error e 222 | => HTTP2Module 223 | -> HTTP2.Secure.Options 224 | -> ( 225 | (Lazy PushContext -> pushIO ()) 226 | -> Context Method SimpleURL Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) () 227 | -> Promise e IO $ Context Method SimpleURL Version StringHeaders Status StringHeaders b (Publisher IO Error Buffer) 228 | ) 229 | -> io Http2Server 230 | listen http2 options handler = do 231 | server <- http2.createSecureServer $ MkOptions 232 | { server = options.serverOptions 233 | , context = options.tlsContextOptions 234 | , tls = options.tlsServerOptions 235 | , net = options.netServerOptions 236 | } 237 | 238 | server.onStream $ \stream, headers => do 239 | let Right req = parseRequest stream headers 240 | | Left err => sendResponse (options.errorHandler err) stream 241 | initialRes = MkResponse OK [] () {h = StringHeaders} 242 | push = if stream.pushAllowed then pusher stream 243 | else const $ pure () 244 | result = handler push $ MkContext req initialRes 245 | 246 | sendResponseFromPromise options.errorHandler result stream 247 | 248 | server.listen options.listenOptions 249 | pure server 250 | --------------------------------------------------------------------------------