├── wai-app-static ├── README ├── test │ ├── a │ │ └── b │ └── EmbeddedTestEntries.hs ├── .gitignore ├── קרררר.html ├── .ghci ├── images │ ├── folder.png │ └── haskell.png ├── Setup.lhs ├── README.md ├── app │ └── warp-static.hs ├── tests.hs ├── WaiAppStatic │ └── Storage │ │ └── Embedded.hs ├── embedded-sample.hs ├── sample.hs ├── LICENSE ├── Util.hs └── ChangeLog.md ├── wai ├── README.lhs ├── test │ └── Spec.hs ├── Setup.lhs ├── .ghci ├── webkit-sample │ ├── index.html │ └── webkit-sample.hs ├── LICENSE ├── wai.cabal └── ChangeLog.md ├── warp-tls ├── pong.txt ├── Setup.lhs ├── README.md ├── certificate.pem ├── key.pem ├── LICENSE └── warp-tls.cabal ├── warp ├── attic │ ├── pong.txt │ ├── hex │ ├── test.txt │ ├── file-nolen.hs │ ├── file.hs │ ├── undrained.hs │ ├── statuses.hs │ ├── print-post.hs │ ├── bigtable-single.hs │ ├── bigtable-stream.hs │ ├── server-no-keepalive.hs │ ├── runtests.hs │ └── pong.hs ├── test │ ├── head-response │ ├── Spec.hs │ ├── doctests.hs │ ├── PackIntSpec.hs │ ├── FdCacheSpec.hs │ ├── ReadIntSpec.hs │ ├── HTTP.hs │ ├── ResponseHeaderSpec.hs │ ├── inputFile │ ├── WithApplicationSpec.hs │ ├── ConduitSpec.hs │ └── ExceptionSpec.hs ├── .ghci ├── Setup.lhs ├── README.md ├── Network │ └── Wai │ │ └── Handler │ │ └── Warp │ │ ├── Windows.hs │ │ ├── HTTP2 │ │ ├── File.hs │ │ ├── PushPromise.hs │ │ └── Types.hs │ │ ├── Imports.hs │ │ ├── Counter.hs │ │ ├── ReadInt.hs │ │ ├── HashMap.hs │ │ ├── Date.hs │ │ ├── PackInt.hs │ │ ├── Buffer.hs │ │ ├── IO.hs │ │ └── ResponseHeader.hs └── LICENSE ├── wai-extra ├── test │ ├── json.gz │ ├── noprecompress │ ├── json │ ├── Spec.hs │ ├── requests │ │ └── dalvik-request │ ├── test.html │ ├── sample.hs │ └── Network │ │ └── Wai │ │ └── Middleware │ │ ├── ApprootSpec.hs │ │ ├── RoutedSpec.hs │ │ ├── TimeoutSpec.hs │ │ ├── ForceSSLSpec.hs │ │ └── StripHeadersSpec.hs ├── .gitignore ├── .ghci ├── Setup.lhs ├── README.md ├── example │ ├── index.html │ └── Main.hs ├── Network │ └── Wai │ │ ├── Middleware │ │ ├── Autohead.hs │ │ ├── AddHeaders.hs │ │ ├── MethodOverride.hs │ │ ├── Local.hs │ │ ├── RequestLogger │ │ │ └── Internal.hs │ │ ├── Timeout.hs │ │ ├── AcceptOverride.hs │ │ ├── HealthCheckEndpoint.hs │ │ ├── CleanPath.hs │ │ ├── ForceSSL.hs │ │ ├── Routed.hs │ │ ├── StreamFile.hs │ │ ├── Vhost.hs │ │ ├── ForceDomain.hs │ │ ├── StripHeaders.hs │ │ └── MethodOverridePost.hs │ │ ├── Util.hs │ │ ├── Test │ │ └── Internal.hs │ │ ├── EventSource │ │ └── EventStream.hs │ │ └── EventSource.hs ├── proxy.hs └── LICENSE ├── wai-frontend-monadcgi ├── .gitignore ├── samples │ ├── plain_cgi.hs │ ├── .htaccess │ ├── wai_fastcgi.hs │ ├── wai_cgi.hs │ └── wai_cgi_generic.hs ├── Setup.lhs ├── ChangeLog.md ├── README.md ├── wai-frontend-monadcgi.cabal ├── LICENSE └── Network │ └── Wai │ └── Frontend │ └── MonadCGI.hs ├── recv ├── test │ ├── Spec.hs │ └── BufferPoolSpec.hs ├── ChangeLog.md ├── Network │ └── Socket │ │ ├── BufferPool │ │ ├── Types.hs │ │ └── Buffer.hs │ │ └── BufferPool.hs ├── LICENSE └── recv.cabal ├── auto-update ├── test │ ├── Spec.hs │ └── Control │ │ ├── AutoUpdateSpec.hs │ │ └── ReaperSpec.hs ├── Setup.hs ├── Control │ ├── AutoUpdate │ │ ├── Internal.hs │ │ └── Types.hs │ ├── Reaper │ │ └── Internal.hs │ ├── Debounce.hs │ └── AutoUpdate.hs ├── README.md ├── LICENSE ├── auto-update.cabal └── ChangeLog.md ├── warp-quic ├── Setup.hs ├── ChangeLog.md ├── warp-quic.cabal ├── LICENSE └── Network │ └── Wai │ └── Handler │ └── WarpQUIC.hs ├── wai-conduit ├── Setup.hs ├── ChangeLog.md ├── README.md ├── example │ └── Main.hs ├── wai-conduit.cabal ├── LICENSE └── Network │ └── Wai │ └── Conduit.hs ├── mime-types ├── README.md ├── Setup.lhs ├── mime-types.cabal ├── LICENSE └── ChangeLog.md ├── wai-websockets ├── README.md ├── Setup.lhs ├── ChangeLog.md ├── LICENSE ├── static │ ├── screen.css │ ├── client.html │ └── client.js └── wai-websockets.cabal ├── .gitignore ├── cabal.project ├── wai-http2-extra ├── test │ └── doctests.hs ├── Network │ └── Wai │ │ └── Middleware │ │ └── Push │ │ └── Referer │ │ ├── Multi.hs │ │ ├── LimitMultiMap.hs │ │ ├── Manager.hs │ │ ├── LRU.hs │ │ └── Types.hs ├── LICENSE └── wai-http2-extra.cabal ├── .github ├── PULL_REQUEST_TEMPLATE.md └── ISSUE_TEMPLATE.md ├── stack.yaml ├── README.md ├── stack-nightly.yaml ├── stack-lts-22.yaml ├── time-manager ├── time-manager.cabal ├── LICENSE └── ChangeLog.md ├── LICENSE ├── stack-lts-21.yaml ├── stack-lts-20.yaml ├── fourmolu.yaml └── hie.yaml /wai-app-static/README: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /wai-app-static/test/a/b: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /wai/README.lhs: -------------------------------------------------------------------------------- 1 | README.md -------------------------------------------------------------------------------- /warp-tls/pong.txt: -------------------------------------------------------------------------------- 1 | PONG -------------------------------------------------------------------------------- /warp/attic/pong.txt: -------------------------------------------------------------------------------- 1 | PONG -------------------------------------------------------------------------------- /wai-extra/test/json.gz: -------------------------------------------------------------------------------- 1 | test 2 | -------------------------------------------------------------------------------- /warp/attic/hex: -------------------------------------------------------------------------------- 1 | 0123456789abcdef -------------------------------------------------------------------------------- /wai-extra/.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | dist 3 | -------------------------------------------------------------------------------- /warp/attic/test.txt: -------------------------------------------------------------------------------- 1 | This is a test. 2 | -------------------------------------------------------------------------------- /wai-extra/test/noprecompress: -------------------------------------------------------------------------------- 1 | noprecompress 2 | -------------------------------------------------------------------------------- /warp/test/head-response: -------------------------------------------------------------------------------- 1 | This is the body 2 | -------------------------------------------------------------------------------- /wai-app-static/.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | cabal-dev 3 | -------------------------------------------------------------------------------- /wai-app-static/קרררר.html: -------------------------------------------------------------------------------- 1 |

HELLO WORLD

2 | -------------------------------------------------------------------------------- /wai-extra/test/json: -------------------------------------------------------------------------------- 1 | {"data":"this is some data"} 2 | -------------------------------------------------------------------------------- /wai-frontend-monadcgi/.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | *.swp 3 | -------------------------------------------------------------------------------- /recv/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /wai/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /warp/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /auto-update/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /wai-extra/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /warp-quic/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /auto-update/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /wai-conduit/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /mime-types/README.md: -------------------------------------------------------------------------------- 1 | ## mime-types 2 | 3 | Basic mime-type handling types and functions 4 | -------------------------------------------------------------------------------- /wai-app-static/.ghci: -------------------------------------------------------------------------------- 1 | :set -itest -optP-include -optPdist/build/autogen/cabal_macros.h -XCPP 2 | -------------------------------------------------------------------------------- /warp/test/doctests.hs: -------------------------------------------------------------------------------- 1 | import Test.DocTest 2 | 3 | main :: IO () 4 | main = doctest ["Network"] 5 | -------------------------------------------------------------------------------- /warp/.ghci: -------------------------------------------------------------------------------- 1 | :set -itest -idist/build/autogen -i.stack-work/dist/x86_64-linux/Cabal-1.22.5.0/build/autogen 2 | -------------------------------------------------------------------------------- /wai-app-static/images/folder.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yesodweb/wai/HEAD/wai-app-static/images/folder.png -------------------------------------------------------------------------------- /wai-extra/.ghci: -------------------------------------------------------------------------------- 1 | :set -itest -optP-include -optPdist/build/autogen/cabal_macros.h 2 | :set -XOverloadedStrings 3 | -------------------------------------------------------------------------------- /wai-app-static/images/haskell.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yesodweb/wai/HEAD/wai-app-static/images/haskell.png -------------------------------------------------------------------------------- /wai-extra/test/requests/dalvik-request: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yesodweb/wai/HEAD/wai-extra/test/requests/dalvik-request -------------------------------------------------------------------------------- /wai-websockets/README.md: -------------------------------------------------------------------------------- 1 | ## wai-websockets 2 | 3 | Use websockets with WAI applications, primarily those hosted via Warp. 4 | -------------------------------------------------------------------------------- /wai-conduit/ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## 3.0.0.4 2 | 3 | * Drop dependency on blaze-builder 4 | 5 | ## 3.0.0.3 6 | 7 | * Support wai 3.2 8 | -------------------------------------------------------------------------------- /wai-frontend-monadcgi/samples/plain_cgi.hs: -------------------------------------------------------------------------------- 1 | import Network.CGI 2 | 3 | main = runCGI mainCGI 4 | 5 | mainCGI = output "This is a test" 6 | -------------------------------------------------------------------------------- /wai/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /warp/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /mime-types/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /wai-extra/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /wai-frontend-monadcgi/samples/.htaccess: -------------------------------------------------------------------------------- 1 | Options +ExecCGI 2 | AddHandler cgi-script .cgi 3 | AddHandler fastcgi-script .fcgi 4 | 5 | Options +FollowSymlinks 6 | -------------------------------------------------------------------------------- /warp-tls/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /wai-app-static/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /wai-websockets/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /wai-app-static/README.md: -------------------------------------------------------------------------------- 1 | ## wai-app-static 2 | 3 | WAI application for static serving 4 | 5 | Also provides some helper functions and datatypes for use outside of WAI. 6 | -------------------------------------------------------------------------------- /wai-frontend-monadcgi/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /wai-app-static/app/warp-static.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import WaiAppStatic.CmdLine (runCommandLine) 4 | 5 | main :: IO () 6 | main = runCommandLine (const id) 7 | -------------------------------------------------------------------------------- /wai-app-static/tests.hs: -------------------------------------------------------------------------------- 1 | import Test.Hspec 2 | import WaiAppEmbeddedTest (embSpec) 3 | import WaiAppStaticTest (spec) 4 | 5 | main :: IO () 6 | main = hspec $ spec >> embSpec 7 | -------------------------------------------------------------------------------- /wai-conduit/README.md: -------------------------------------------------------------------------------- 1 | ## wai-conduit 2 | 3 | Since version 3.0.0, WAI has no built-in streaming data abstraction. This 4 | library provides similar functionality to what existed in WAI 2.x. 5 | -------------------------------------------------------------------------------- /wai/.ghci: -------------------------------------------------------------------------------- 1 | :set -optP-include -optPdist/build/autogen/cabal_macros.h -pgmL markdown-unlit 2 | :set -i../warp -i../warp/dist/build/autogen/ -optP-include -optP../warp/dist/build/autogen/cabal_macros.h 3 | -------------------------------------------------------------------------------- /recv/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # ChangeLog for "recv" 2 | 3 | ## v0.1.1 4 | 5 | * Fixing the bug that the last chunk is skipped when the size is 6 | insufficient [1031](https://github.com/yesodweb/wai/pull/1031) 7 | -------------------------------------------------------------------------------- /warp/README.md: -------------------------------------------------------------------------------- 1 | # Warp 2 | 3 | Warp is a server library for HTTP/1.x and HTTP/2 based WAI(Web Application Interface in Haskell). For more information, see [Warp](http://www.aosabook.org/en/posa/warp.html). 4 | -------------------------------------------------------------------------------- /wai-frontend-monadcgi/ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## 3.0.0.3 2 | 3 | * wai-frontend-monadcgi does not drop '?' in query string [#590](https://github.com/yesodweb/wai/issues/590) 4 | 5 | ## 3.0.0.2 6 | 7 | * Support for wai 3.2 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | *.swp 3 | *.hi 4 | *.o 5 | tarballs/ 6 | /.hsenv 7 | /.shelly 8 | .cabal-sandbox/ 9 | cabal.sandbox.config 10 | .stack-work/ 11 | *~ 12 | stack*.yaml.lock 13 | dist-newstyle/ 14 | .hie 15 | *.code-workspace 16 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | auto-update 3 | mime-types 4 | recv 5 | wai 6 | wai-extra 7 | warp 8 | warp-tls 9 | warp-quic 10 | wai-app-static 11 | wai-websockets 12 | wai-conduit 13 | time-manager 14 | -------------------------------------------------------------------------------- /wai-frontend-monadcgi/README.md: -------------------------------------------------------------------------------- 1 | ## wai-frontend-monadcgi 2 | 3 | Allows programs written against MonadCGI to run with any WAI handler. This is 4 | most useful for running your existing CGI apps on Warp. For true "yo 5 | dawg"-ness, try running this through the WAI CGI backend. 6 | -------------------------------------------------------------------------------- /auto-update/Control/AutoUpdate/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Control.AutoUpdate.Internal ( 4 | -- * Debugging 5 | UpdateState (..), 6 | mkClosableAutoUpdate, 7 | mkClosableAutoUpdate', 8 | ) 9 | where 10 | 11 | import Control.AutoUpdate.Event 12 | -------------------------------------------------------------------------------- /warp/attic/file-nolen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Network.HTTP.Types 4 | import Network.Wai 5 | import Network.Wai.Handler.Warp 6 | 7 | main = 8 | run 3000 $ 9 | const $ 10 | return $ 11 | ResponseFile status200 [("Content-Type", "text/plain")] "test.txt" Nothing 12 | -------------------------------------------------------------------------------- /wai-app-static/WaiAppStatic/Storage/Embedded.hs: -------------------------------------------------------------------------------- 1 | module WaiAppStatic.Storage.Embedded ( 2 | -- * Basic 3 | embeddedSettings, 4 | 5 | -- * Template Haskell 6 | Etag, 7 | EmbeddableEntry (..), 8 | mkSettings, 9 | ) where 10 | 11 | import WaiAppStatic.Storage.Embedded.Runtime 12 | import WaiAppStatic.Storage.Embedded.TH 13 | -------------------------------------------------------------------------------- /wai-frontend-monadcgi/samples/wai_fastcgi.hs: -------------------------------------------------------------------------------- 1 | import qualified Network.CGI 2 | import qualified Network.Wai.Frontend.MonadCGI 3 | import qualified Network.Wai.Handler.FastCGI 4 | 5 | main = 6 | Network.Wai.Handler.FastCGI.run $ 7 | Network.Wai.Frontend.MonadCGI.cgiToApp mainCGI 8 | 9 | mainCGI = Network.CGI.output "This is a test" 10 | -------------------------------------------------------------------------------- /wai-frontend-monadcgi/samples/wai_cgi.hs: -------------------------------------------------------------------------------- 1 | import qualified Network.CGI 2 | import qualified Network.Wai.Frontend.MonadCGI 3 | import qualified Network.Wai.Handler.SimpleServer 4 | 5 | main = 6 | Network.Wai.Handler.SimpleServer.run 3000 $ 7 | Network.Wai.Frontend.MonadCGI.cgiToApp mainCGI 8 | 9 | mainCGI = Network.CGI.output "This is a test" 10 | -------------------------------------------------------------------------------- /warp-tls/README.md: -------------------------------------------------------------------------------- 1 | ## warp-tls 2 | 3 | Serve WAI applications using the Warp webserver and the Haskell TLS library. 4 | 5 | In order to generate a self-signed certificate for testing, try the following: 6 | 7 | openssl genrsa -out key.pem 2048 8 | openssl req -new -key key.pem -out certificate.csr 9 | openssl x509 -req -in certificate.csr -signkey key.pem -out certificate.pem 10 | -------------------------------------------------------------------------------- /wai-http2-extra/test/doctests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if __GLASGOW_HASKELL__ < 900 || __GLASGOW_HASKELL__ >= 902 3 | import Test.DocTest 4 | #endif 5 | 6 | main :: IO () 7 | main = 8 | #if __GLASGOW_HASKELL__ < 900 9 | doctest ["Network"] 10 | #else 11 | #if __GLASGOW_HASKELL__ >= 902 12 | doctest ["Network"] 13 | #else 14 | putStrLn "Doesn't work on GHC 9.0.*" 15 | #endif 16 | #endif 17 | -------------------------------------------------------------------------------- /wai-extra/README.md: -------------------------------------------------------------------------------- 1 | # wai-extra 2 | 3 | The goal here is to provide common features without many dependencies. 4 | 5 | 6 | ## Example using Server-Sent Events ## 7 | 8 | There is a small example using Server-Sent Events (SSE) in the 9 | `./example` directory. 10 | 11 | Run the commands below to start the server on http://localhost:8080 12 | 13 | ``` 14 | $ stack build . 15 | $ stack exec example 16 | ``` 17 | -------------------------------------------------------------------------------- /warp/attic/file.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Network.HTTP.Types 4 | import Network.Wai 5 | import Network.Wai.Handler.Warp 6 | 7 | main = 8 | run 3000 $ 9 | const $ 10 | return $ 11 | ResponseFile 12 | status200 13 | [("Content-Type", "text/plain"), ("Content-Length", "16")] 14 | "test.txt" 15 | Nothing 16 | -------------------------------------------------------------------------------- /wai-extra/test/test.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 12 | 13 | 14 | There should be some content loaded below: 15 |
16 | 17 | 18 | -------------------------------------------------------------------------------- /warp/attic/undrained.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Blaze.ByteString.Builder (fromByteString) 4 | import Network.Wai 5 | import Network.Wai.Handler.Warp 6 | 7 | main = 8 | run 3000 9 | $ const 10 | $ return 11 | $ responseBuilder 12 | status200 13 | [("Content-Type", "text/html")] 14 | $ fromByteString 15 | "
" 16 | -------------------------------------------------------------------------------- /warp-quic/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for warp-quic 2 | 3 | ## 0.0.4 4 | 5 | * Adjusted code to fit new range of dependency constraints. [#1043](https://github.com/yesodweb/wai/pull/1043) 6 | * Accept lower versions of `http3` and `tls` 7 | 8 | ## 0.0.3 9 | 10 | * Using http3 v0.1. 11 | 12 | ## 0.0.2 13 | 14 | * Labeling threads. 15 | * New API: runQUICSockets. 16 | 17 | ## 0.0.1 18 | 19 | * Providing `runQUICSocket`. 20 | 21 | ## 0.0.0 22 | 23 | * First version. Released on an unsuspecting world. 24 | -------------------------------------------------------------------------------- /wai-app-static/embedded-sample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | import Data.FileEmbed 5 | import Network.Wai.Application.Static 6 | import Network.Wai.Handler.Warp (run) 7 | import WaiAppStatic.Storage.Embedded 8 | import WaiAppStatic.Types 9 | 10 | main :: IO () 11 | main = 12 | run 3000 $ 13 | staticApp 14 | (embeddedSettings $(embedDir "test")) 15 | { ssIndices = [] 16 | , ssMaxAge = NoMaxAge 17 | } 18 | -------------------------------------------------------------------------------- /warp/test/PackIntSpec.hs: -------------------------------------------------------------------------------- 1 | module PackIntSpec (spec) where 2 | 3 | import qualified Data.ByteString.Char8 as C8 4 | import Network.Wai.Handler.Warp.PackInt 5 | import Test.Hspec 6 | import Test.Hspec.QuickCheck 7 | import qualified Test.QuickCheck as QC 8 | 9 | spec :: Spec 10 | spec = describe "readInt64" $ do 11 | prop "" $ \n -> packIntegral (abs n :: Int) == C8.pack (show (abs n)) 12 | prop "" $ \(QC.Large n) -> 13 | let n' = fromIntegral (abs n :: Int) 14 | in packIntegral (n' :: Int) == C8.pack (show n') 15 | -------------------------------------------------------------------------------- /wai-extra/example/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Example 4 | 5 | 6 |

Testing Server-Sent Events

7 | 8 |
9 | 10 | 21 | -------------------------------------------------------------------------------- /wai/webkit-sample/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | WAI Test Page! 5 | 6 | 7 | 8 |

It works

9 |

Here's some Unicode stuff: שלום

10 |
11 |

Name:

12 | 13 |

Some file:

14 |

15 |
16 | 17 | 18 | -------------------------------------------------------------------------------- /wai-websockets/ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## 3.0.1.3 2 | 3 | * Drop unused dependency on `network` 4 | 5 | ## 3.0.1.2 6 | 7 | * Drop unused dependency on `blaze-builder` 8 | 9 | ## 3.0.1.1 10 | 11 | * Doc improvement 12 | 13 | ## 3.0.1 14 | 15 | * Improved connection close logic 16 | 17 | ## 3.0.0.9 18 | 19 | * Clean up stream resources when websockets completes [#549](https://github.com/yesodweb/wai/pull/549) 20 | 21 | ## 3.0.0.8 22 | 23 | * Support `wai-3.2` 24 | 25 | ## 3.0.0.7 26 | 27 | * Improved documentation [#471](https://github.com/yesodweb/wai/pull/471) 28 | 29 | ## 3.0.0.5 30 | 31 | Allow `blaze-builder-0.4` 32 | -------------------------------------------------------------------------------- /warp/attic/statuses.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Data.ByteString.Char8 as S 4 | import Data.ByteString.Lazy.Char8 (pack) 5 | import Network.Wai 6 | import Network.Wai.Handler.Warp 7 | 8 | main = run 3000 app 9 | 10 | app req = 11 | return $ 12 | responseLBS (Status s' s) [("Content-Type", "text/plain")] $ 13 | pack $ 14 | concat 15 | [ "The status code is " 16 | , S.unpack s 17 | , ". Have a nice day!" 18 | ] 19 | where 20 | s = S.dropWhile (== '/') $ pathInfo req 21 | s' = read $ S.unpack s 22 | -------------------------------------------------------------------------------- /warp/attic/print-post.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Blaze.ByteString.Builder (fromByteString) 4 | import Control.Monad.IO.Class (liftIO) 5 | import qualified Data.Conduit as C 6 | import qualified Data.Conduit.List as CL 7 | import Network.HTTP.Types (status200) 8 | import Network.Wai 9 | import Network.Wai.Handler.Warp 10 | 11 | {- 12 | - use `curl -H "Transfer-Encoding: chunked" estfile http://localhost:3000/` to send a chunked post request. 13 | -} 14 | 15 | main = run 3000 app 16 | 17 | app req = do 18 | (requestBody req C.$$ CL.consume) >>= liftIO . print 19 | return $ ResponseBuilder status200 [] (fromByteString "PONG") 20 | -------------------------------------------------------------------------------- /.github/PULL_REQUEST_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | Before submitting your PR, check that you've: 2 | 3 | - [ ] Bumped the version number 4 | - [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html) 5 | - [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock 6 | 7 | After submitting your PR: 8 | 9 | - [ ] Update the Changelog.md file with a link to your PR 10 | - [ ] Check that CI passes (or if it fails, for reasons unrelated to your change, like CI timeouts) 11 | 12 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-24.7 2 | packages: 3 | - ./auto-update 4 | - ./mime-types 5 | - ./recv 6 | - ./time-manager 7 | - ./wai 8 | - ./wai-app-static 9 | - ./wai-conduit 10 | - ./wai-extra 11 | - ./wai-frontend-monadcgi 12 | - ./wai-http2-extra 13 | - ./wai-websockets 14 | - ./warp 15 | - ./warp-quic 16 | - ./warp-tls 17 | flags: 18 | wai-extra: 19 | build-example: true 20 | nix: 21 | enable: false 22 | packages: 23 | - fcgi 24 | - zlib 25 | extra-deps: 26 | - ech-config-0.0.1 27 | - hpke-0.0.0 28 | - http-semantics-0.4.0 29 | - http2-5.4.0 30 | - http3-0.1.2 31 | - quic-0.2.21 32 | - random-1.3.1 33 | - sockaddr-0.0.1 34 | - tls-2.1.11 35 | -------------------------------------------------------------------------------- /wai-conduit/example/Main.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack --resolver lts-11.10 script 3 | 4 | import Conduit 5 | import Control.Monad.Trans.Resource 6 | import Data.ByteString.Builder (byteString) 7 | import Network.HTTP.Types 8 | import Network.Wai 9 | import Network.Wai.Conduit 10 | import Network.Wai.Handler.Warp 11 | 12 | main :: IO () 13 | main = run 3000 app 14 | 15 | app :: Application 16 | app _req respond = 17 | runResourceT $ withInternalState $ \is -> 18 | respond $ 19 | responseSource status200 [] $ 20 | transPipe (`runInternalState` is) (sourceFile "Main.hs") 21 | .| mapC (Chunk . byteString) 22 | -------------------------------------------------------------------------------- /wai-app-static/sample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Data.Maybe (mapMaybe) 4 | import Data.String 5 | import Data.Text (pack) 6 | import Network.Wai.Application.Static (defaultFileServerSettings, staticApp) 7 | import Network.Wai.Handler.Warp (defaultSettings, runSettings, settingsPort) 8 | import WaiAppStatic.Types (ssIndices, toPiece) 9 | 10 | main :: IO () 11 | main = 12 | runSettings 13 | defaultSettings 14 | { settingsPort = 3000 15 | } 16 | $ staticApp 17 | (defaultFileServerSettings $ fromString ".") 18 | { ssIndices = mapMaybe (toPiece . pack) ["index.html"] 19 | } 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | An interface between Haskell web frameworks and web servers. 2 | 3 | [![Build status](https://github.com/yesodweb/wai/actions/workflows/tests.yml/badge.svg)](https://github.com/yesodweb/wai/actions/workflows/tests.yml) 4 | 5 | A Haskell web application targets WAI and then can be deployed to any backend with a WAI adaptor. 6 | The premier WAI backend is the Warp web server. 7 | 8 | WAI also adds modularity and code-sharing through middleware and WAI applications. 9 | Code can be written that works with any web framework targeting WAI. 10 | 11 | [Documentation](http://www.yesodweb.com/book/web-application-interface) 12 | 13 | [Haddock Documentation](http://hackage.haskell.org/package/wai) 14 | -------------------------------------------------------------------------------- /wai-frontend-monadcgi/samples/wai_cgi_generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | 3 | import qualified Network.CGI 4 | import qualified Network.Wai.Frontend.MonadCGI 5 | import qualified Network.Wai.Handler.SimpleServer 6 | import "mtl" Control.Monad.Reader 7 | 8 | main :: IO () 9 | main = 10 | Network.Wai.Handler.SimpleServer.run 3000 $ 11 | Network.Wai.Frontend.MonadCGI.cgiToAppGeneric 12 | monadToIO 13 | mainCGI 14 | 15 | mainCGI :: Network.CGI.CGIT (Reader String) Network.CGI.CGIResult 16 | mainCGI = do 17 | s <- lift ask 18 | Network.CGI.output s 19 | 20 | monadToIO :: Reader String a -> IO a 21 | monadToIO = return . (flip runReader) "This is a generic test" 22 | -------------------------------------------------------------------------------- /auto-update/README.md: -------------------------------------------------------------------------------- 1 | ## auto-update 2 | 3 | A common problem is the desire to have an action run at a scheduled interval, 4 | but only if it is needed. For example, instead of having every web request 5 | result in a new `getCurrentTime` call, we'd like to have a single worker thread 6 | run every second, updating an `IORef`. However, if the request frequency is 7 | less than once per second, this is a pessimization, and worse, kills idle GC. 8 | 9 | This library allows you to define actions which will either be performed by a 10 | dedicated thread or, in times of low volume, will be executed by the calling 11 | thread. 12 | 13 | For original use case, see [yesod-scaffold issue #15](https://github.com/yesodweb/yesod-scaffold/pull/15). 14 | -------------------------------------------------------------------------------- /warp/test/FdCacheSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module FdCacheSpec where 4 | 5 | import Test.Hspec 6 | #ifndef WINDOWS 7 | import Data.IORef 8 | import Network.Wai.Handler.Warp.FdCache 9 | import System.Posix.IO.ByteString (fdRead) 10 | import System.Posix.Types (Fd(..)) 11 | 12 | main :: IO () 13 | main = hspec spec 14 | 15 | spec :: Spec 16 | spec = describe "withFdCache" $ do 17 | it "clean up Fd" $ do 18 | ref <- newIORef (Fd (-1)) 19 | withFdCache 30000000 $ \getFd -> do 20 | (Just fd,_) <- getFd "warp.cabal" 21 | writeIORef ref fd 22 | nfd <- readIORef ref 23 | fdRead nfd 1 `shouldThrow` anyIOException 24 | #else 25 | spec :: Spec 26 | spec = return () 27 | #endif 28 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/Autohead.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | Automatically produce responses to HEAD requests based on the underlying 4 | -- applications GET response. 5 | module Network.Wai.Middleware.Autohead (autohead) where 6 | 7 | #if __GLASGOW_HASKELL__ < 710 8 | import Data.Monoid (mempty) 9 | #endif 10 | import Network.Wai ( 11 | Middleware, 12 | requestMethod, 13 | responseBuilder, 14 | responseToStream, 15 | ) 16 | 17 | autohead :: Middleware 18 | autohead app req sendResponse 19 | | requestMethod req == "HEAD" = app req{requestMethod = "GET"} $ \res -> do 20 | let (s, hs, _) = responseToStream res 21 | sendResponse $ responseBuilder s hs mempty 22 | | otherwise = app req sendResponse 23 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/AddHeaders.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- 3 | -- Since 3.0.3 4 | module Network.Wai.Middleware.AddHeaders ( 5 | addHeaders, 6 | ) where 7 | 8 | import Control.Arrow (first) 9 | import Data.ByteString (ByteString) 10 | import qualified Data.CaseInsensitive as CI 11 | import Network.HTTP.Types (Header) 12 | import Network.Wai (Middleware, mapResponseHeaders, modifyResponse) 13 | import Network.Wai.Internal (Response (..)) 14 | 15 | addHeaders :: [(ByteString, ByteString)] -> Middleware 16 | -- ^ Prepend a list of headers without any checks 17 | -- 18 | -- Since 3.0.3 19 | addHeaders h = modifyResponse $ addHeaders' (map (first CI.mk) h) 20 | 21 | addHeaders' :: [Header] -> Response -> Response 22 | addHeaders' h = mapResponseHeaders (h ++) 23 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/MethodOverride.hs: -------------------------------------------------------------------------------- 1 | module Network.Wai.Middleware.MethodOverride ( 2 | methodOverride, 3 | ) where 4 | 5 | import Control.Monad (join) 6 | import Network.Wai (Middleware, queryString, requestMethod) 7 | 8 | -- | Overriding of HTTP request method via `_method` query string parameter. 9 | -- 10 | -- This middleware only applies when the initial request method is POST. 11 | -- Allows submitting of normal HTML forms, without worries of semantic 12 | -- mismatches with the HTTP spec. 13 | methodOverride :: Middleware 14 | methodOverride app req = 15 | app req' 16 | where 17 | req' = 18 | case (requestMethod req, join $ lookup "_method" $ queryString req) of 19 | ("POST", Just m) -> req{requestMethod = m} 20 | _ -> req 21 | -------------------------------------------------------------------------------- /wai-http2-extra/Network/Wai/Middleware/Push/Referer/Multi.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Network.Wai.Middleware.Push.Referer.Multi where 4 | 5 | import Data.Set (Set) 6 | import qualified Data.Set as Set 7 | 8 | data Multi a = Multi 9 | { limit :: Int 10 | , list :: [a] 11 | , check :: Set a 12 | } 13 | deriving (Eq, Show) 14 | 15 | empty :: Int -> Multi a 16 | empty n = Multi n [] Set.empty 17 | 18 | singleton :: Int -> a -> Multi a 19 | singleton n v = Multi n [v] $ Set.singleton v 20 | 21 | insert :: Ord a => a -> Multi a -> Multi a 22 | insert _ m@Multi{..} 23 | | Set.size check == limit = m 24 | insert v m@Multi{..} 25 | | Set.size check == Set.size check' = m 26 | | otherwise = Multi limit (v : list) check' 27 | where 28 | check' = Set.insert v check 29 | -------------------------------------------------------------------------------- /stack-nightly.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly 2 | packages: 3 | - ./auto-update 4 | - ./mime-types 5 | - ./recv 6 | - ./time-manager 7 | - ./wai 8 | - ./wai-app-static 9 | - ./wai-conduit 10 | - ./wai-extra 11 | - ./wai-frontend-monadcgi 12 | - ./wai-http2-extra 13 | - ./wai-websockets 14 | - ./warp 15 | - ./warp-quic 16 | - ./warp-tls 17 | flags: 18 | wai-extra: 19 | build-example: true 20 | nix: 21 | enable: false 22 | packages: 23 | - fcgi 24 | - zlib 25 | extra-deps: 26 | - crypto-token-0.1.2 27 | - crypton-x509-store-1.6.11 28 | - ech-config-0.0.1 29 | - hpke-0.0.0 30 | - http-semantics-0.4.0 31 | - http2-5.4.0 32 | - http3-0.1.2 33 | - network-control-0.1.7 34 | - network-udp-0.0.0 35 | - quic-0.2.21 36 | - random-1.3.1 37 | - tls-2.1.11 38 | - tls-session-manager-0.0.7 39 | - sockaddr-0.0.1 40 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/Local.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | Only allow local connections. 4 | module Network.Wai.Middleware.Local ( 5 | local, 6 | ) where 7 | 8 | import Network.Socket (SockAddr (..)) 9 | import Network.Wai (Middleware, Response, remoteHost) 10 | 11 | -- | This middleware rejects non-local connections with a specific response. 12 | -- It is useful when supporting web-based local applications, which would 13 | -- typically want to reject external connections. 14 | local :: Response -> Middleware 15 | local resp f r k = case remoteHost r of 16 | SockAddrInet _ h 17 | | h == fromIntegral home -> 18 | f r k 19 | #if !defined(mingw32_HOST_OS) && !defined(_WIN32) 20 | SockAddrUnix _ -> f r k 21 | #endif 22 | _ -> k resp 23 | where 24 | home :: Integer 25 | home = 127 + (256 * 256 * 256) 26 | -------------------------------------------------------------------------------- /warp/attic/bigtable-single.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Blaze.ByteString.Builder (Builder, fromByteString) 4 | import Blaze.ByteString.Builder.Char8 (fromShow) 5 | import Data.Monoid (mappend) 6 | import Network.Wai 7 | import Network.Wai.Handler.Warp (run) 8 | 9 | bigtable :: Builder 10 | bigtable = 11 | fromByteString "" 12 | `mappend` foldr mappend (fromByteString "
") (replicate 2 row) 13 | where 14 | row = 15 | fromByteString "" 16 | `mappend` foldr go (fromByteString "") [1 .. 2] 17 | go i rest = 18 | fromByteString "" 19 | `mappend` fromShow i 20 | `mappend` fromByteString "" 21 | `mappend` rest 22 | 23 | main = run 3000 app 24 | 25 | app _ = return $ ResponseBuilder status200 [("Content-Type", "text/html")] bigtable 26 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | Some helpers functions. 4 | module Network.Wai.Util ( 5 | dropWhileEnd, 6 | splitCommas, 7 | trimWS, 8 | ) where 9 | 10 | import qualified Data.ByteString as S 11 | import Data.Word8 (Word8, _comma, _space) 12 | 13 | -- | Used to split a header value which is a comma separated list 14 | splitCommas :: S.ByteString -> [S.ByteString] 15 | splitCommas = map trimWS . S.split _comma 16 | 17 | -- Trim whitespace 18 | trimWS :: S.ByteString -> S.ByteString 19 | trimWS = dropWhileEnd (== _space) . S.dropWhile (== _space) 20 | 21 | -- | Dropping all 'Word8's from the end that satisfy the predicate. 22 | dropWhileEnd :: (Word8 -> Bool) -> S.ByteString -> S.ByteString 23 | #if MIN_VERSION_bytestring(0,10,12) 24 | dropWhileEnd = S.dropWhileEnd 25 | #else 26 | dropWhileEnd p = fst . S.spanEnd p 27 | #endif 28 | -------------------------------------------------------------------------------- /recv/Network/Socket/BufferPool/Types.hs: -------------------------------------------------------------------------------- 1 | module Network.Socket.BufferPool.Types where 2 | 3 | import Data.ByteString (ByteString) 4 | import Data.IORef 5 | import Data.Word (Word8) 6 | import Foreign.Ptr (Ptr) 7 | 8 | -- | Type for buffer. 9 | type Buffer = Ptr Word8 10 | 11 | -- | Type for buffer size. 12 | type BufSize = Int 13 | 14 | -- | Type for read buffer pool. 15 | data BufferPool = BufferPool 16 | { minBufSize :: Int 17 | -- ^ If the buffer is larger than or equal to this size, 18 | -- the buffer is used. 19 | -- Otherwise, a new buffer is allocated. 20 | -- The thrown buffer is eventually freed. 21 | , maxBufSize :: Int 22 | , poolBuffer :: IORef ByteString 23 | } 24 | 25 | -- | Type for the receiving function with a buffer pool. 26 | type Recv = IO ByteString 27 | 28 | -- | Type for the receiving function which receives N bytes. 29 | type RecvN = Int -> IO ByteString 30 | -------------------------------------------------------------------------------- /warp-tls/certificate.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIICWDCCAcGgAwIBAgIJAJG1ZMlcMDW6MA0GCSqGSIb3DQEBBQUAMEUxCzAJBgNV 3 | BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX 4 | aWRnaXRzIFB0eSBMdGQwHhcNMTExMDIyMTk0MjU3WhcNMTExMTIxMTk0MjU3WjBF 5 | MQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50 6 | ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB 7 | gQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCdthgTK66SPXkx 8 | EXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cDJSSGK11eQEVs 9 | +p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQABo1AwTjAdBgNV 10 | HQ4EFgQUaA6FbOj/0VJMb4egNyIDZ/ZNV/YwHwYDVR0jBBgwFoAUaA6FbOj/0VJM 11 | b4egNyIDZ/ZNV/YwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0BAQUFAAOBgQCTQyOk 12 | D86Z+yzedXjTLI6FT8QugmQne1YQ8P0w37P76z2reagSvNee2e9B1oTHoPeKZMs0 13 | k99oS9yJ/NOQ1Ms90P+q0yBVGxAs/gF65qKgE27YGXzNtNobj/D4OoxcFG+BsORw 14 | VvYSBV4FiVy9RwJsr7AMqkUBcOEPCuJHgTx58w== 15 | -----END CERTIFICATE----- 16 | -------------------------------------------------------------------------------- /warp/attic/bigtable-stream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Blaze.ByteString.Builder (Builder, fromByteString) 4 | import Blaze.ByteString.Builder.Char8 (fromShow) 5 | import Data.Enumerator (enumList, run_, ($$)) 6 | import Data.Monoid (mappend) 7 | import Network.Wai 8 | import Network.Wai.Handler.Warp (run) 9 | 10 | bigtable :: [Builder] 11 | bigtable = 12 | fromByteString "" 13 | : foldr (:) [fromByteString "
"] (replicate 2 row) 14 | where 15 | row = 16 | fromByteString "" 17 | `mappend` foldr go (fromByteString "") [1 .. 2] 18 | go i rest = 19 | fromByteString "" 20 | `mappend` fromShow i 21 | `mappend` fromByteString "" 22 | `mappend` rest 23 | 24 | main = run 3000 app 25 | 26 | app _ = return $ ResponseEnumerator $ \f -> 27 | run_ $ enumList 4 bigtable $$ f status200 [("Content-Type", "text/html")] 28 | -------------------------------------------------------------------------------- /warp-tls/key.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN RSA PRIVATE KEY----- 2 | MIICXAIBAAKBgQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCd 3 | thgTK66SPXkxEXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cD 4 | JSSGK11eQEVs+p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQAB 5 | AoGAR8pgAgjo7tZ60ccIUjOX/LSxB6d5J2Eu6wvNjk6qZD9OuWtOa7up/HigmZ63 6 | CDMjQNI2/o6AOrWtEQkPYZNbibuifzg5V517nHGSqkqjoIgesAiwEsoKpeOgGTtM 7 | MM08oHbJ9uOnDnEEnDBiE0iE3jCTDfmwjqDMpUhu9dZ1EAECQQDKVpzSSV3pzMOp 8 | ixNxMpYxzcE+4K9jgM+MlxPBJSQhVrg/cRQWb26cKBi8LdSxF23hQTsFr+8qLwid 9 | Ah2AgUOBAkEAyaaCjrNRCiHRpd6YzWZ6GKkxbUvxSuOKX3N7hDaE2OFzQTv2Li8B 10 | 5mrCsXnSZtOG+MBFdHU66UYie1OzDSDKtwJAKMsvkOID0ihbZmpIwDC/wUjHZkLs 11 | eXY14hVvgShY0XPnb7r/nspWlZsr6Xyf/hhIKfr5yFrBMFMNPIJ5qjflgQJAWsyV 12 | YTgxN4S+6BdxapvIQq58ySA3CGeo+Q4BAimibB4oTal4UpdsHZrZDB00toRs9Dlv 13 | jN70pfGkuS+ZIkIvxQJBAKSf5qpXWp4oZcThkieAiMeAhG96xqRPXhPUxq6QF+YG 14 | T4PF1sjlpZwqy7C+2oF3BqLP09mCW7YkH9Jgnl1zDF8= 15 | -----END RSA PRIVATE KEY----- 16 | -------------------------------------------------------------------------------- /mime-types/mime-types.cabal: -------------------------------------------------------------------------------- 1 | name: mime-types 2 | version: 0.1.2.0 3 | synopsis: Basic mime-type handling types and functions 4 | description: API docs and the README are available at . 5 | homepage: https://github.com/yesodweb/wai 6 | license: MIT 7 | license-file: LICENSE 8 | author: Michael Snoyman 9 | maintainer: michael@snoyman.com 10 | category: Web 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | extra-source-files: README.md ChangeLog.md 14 | 15 | library 16 | exposed-modules: Network.Mime 17 | default-language: Haskell2010 18 | build-depends: base >= 4.12 && < 5 19 | , containers 20 | , text 21 | , bytestring 22 | 23 | source-repository head 24 | type: git 25 | location: git://github.com/yesodweb/wai.git 26 | -------------------------------------------------------------------------------- /wai-conduit/wai-conduit.cabal: -------------------------------------------------------------------------------- 1 | name: wai-conduit 2 | version: 3.0.0.4 3 | synopsis: conduit wrappers for WAI 4 | description: API docs and the README are available at . 5 | homepage: https://github.com/yesodweb/wai 6 | license: MIT 7 | license-file: LICENSE 8 | author: Michael Snoyman 9 | maintainer: michael@snoyman.com 10 | category: Web, Conduit 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | extra-source-files: README.md ChangeLog.md 14 | 15 | library 16 | exposed-modules: Network.Wai.Conduit 17 | build-depends: base >= 4.12 && < 5 18 | , wai >= 3.0 && < 3.3 19 | , conduit 20 | , transformers 21 | , bytestring >= 0.10.4 22 | , http-types 23 | default-language: Haskell2010 24 | -------------------------------------------------------------------------------- /warp-quic/warp-quic.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: warp-quic 3 | version: 0.0.4 4 | license: BSD3 5 | license-file: LICENSE 6 | maintainer: Kazu Yamamoto 7 | author: Kazu Yamamoto 8 | homepage: https://github.com/yesodweb/wai 9 | synopsis: Warp based on QUIC 10 | description: WAI handler for HTTP/3 based on QUIC 11 | category: Network 12 | build-type: Simple 13 | extra-source-files: ChangeLog.md 14 | 15 | library 16 | exposed-modules: Network.Wai.Handler.WarpQUIC 17 | default-language: Haskell2010 18 | ghc-options: -Wall 19 | build-depends: 20 | base >=4.13 && <5, 21 | bytestring, 22 | http3 <0.2, 23 | network, 24 | quic >=0.2 && <0.3, 25 | tls >=0.8 && < 3, 26 | wai, 27 | warp >=3.4.4 28 | 29 | if impl(ghc >=8) 30 | default-extensions: Strict StrictData 31 | -------------------------------------------------------------------------------- /warp/Network/Wai/Handler/Warp/Windows.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Network.Wai.Handler.Warp.Windows ( 4 | windowsThreadBlockHack, 5 | ) where 6 | 7 | #if WINDOWS 8 | import Control.Concurrent.MVar 9 | import Control.Concurrent 10 | import qualified Control.Exception 11 | 12 | import GHC.Conc (labelThread) 13 | 14 | -- | Allow main socket listening thread to be interrupted on Windows platform 15 | -- 16 | -- @since 3.2.17 17 | windowsThreadBlockHack :: IO a -> IO a 18 | windowsThreadBlockHack act = do 19 | var <- newEmptyMVar :: IO (MVar (Either Control.Exception.SomeException a)) 20 | -- Catch and rethrow even async exceptions, so don't bother with UnliftIO 21 | threadId <- forkIO $ Control.Exception.try act >>= putMVar var 22 | labelThread threadId "Windows Thread Block Hack (warp)" 23 | res <- takeMVar var 24 | case res of 25 | Left e -> Control.Exception.throwIO e 26 | Right r -> return r 27 | #else 28 | windowsThreadBlockHack :: IO a -> IO a 29 | windowsThreadBlockHack = id 30 | #endif 31 | -------------------------------------------------------------------------------- /stack-lts-22.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-22.43 2 | packages: 3 | - ./auto-update 4 | - ./mime-types 5 | - ./recv 6 | - ./time-manager 7 | - ./wai 8 | - ./wai-app-static 9 | - ./wai-conduit 10 | - ./wai-extra 11 | - ./wai-frontend-monadcgi 12 | - ./wai-http2-extra 13 | - ./wai-websockets 14 | - ./warp 15 | - ./warp-quic 16 | - ./warp-tls 17 | flags: 18 | wai-extra: 19 | build-example: true 20 | zlib: 21 | bundled-c-zlib: true 22 | nix: 23 | enable: false 24 | packages: 25 | - fcgi 26 | - zlib 27 | extra-deps: 28 | - crypton-1.0.4 29 | - crypto-token-0.1.2 30 | - crypton-x509-store-1.6.11 31 | - crypton-x509-validation-1.6.13 32 | - ech-config-0.0.1 33 | - hpke-0.0.0 34 | - http-semantics-0.4.0 35 | - http2-5.4.0 36 | - http3-0.1.2 37 | - network-3.2.7.0 38 | - network-control-0.1.7 39 | - network-udp-0.0.0 40 | - quic-0.2.21 41 | - random-1.3.1 42 | - sockaddr-0.0.1 43 | - tls-2.1.11 44 | - tls-session-manager-0.0.7 45 | - uuid-types-1.0.6 46 | - websockets-0.13.0.0 47 | - zlib-0.7.1.0 48 | - zlib-clib-1.3.1 49 | -------------------------------------------------------------------------------- /wai-extra/proxy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Blaze.ByteString.Builder (fromByteString) 4 | import qualified Data.ByteString.Char8 as S8 5 | import qualified Data.ByteString.Lazy.Char8 () 6 | import Data.Enumerator (joinI, run_, ($$)) 7 | import qualified Data.Enumerator as E 8 | import qualified Network.HTTP.Enumerator as H 9 | import qualified Network.Wai as W 10 | import Network.Wai.Handler.SimpleServer (run) 11 | import Network.Wai.Middleware.Gzip (gzip) 12 | 13 | main :: IO () 14 | main = run 3000 $ gzip False app 15 | 16 | app :: W.Application 17 | app W.Request{W.pathInfo = path} = 18 | case H.parseUrl $ "http://wiki.yesodweb.com" ++ S8.unpack path of 19 | Nothing -> return notFound 20 | Just hreq -> return $ W.ResponseEnumerator $ run_ . H.http hreq . go 21 | where 22 | go f s h = joinI $ E.map fromByteString $$ f s $ filter safe h 23 | safe (x, _) = x `notElem` ["Content-Encoding", "Transfer-Encoding"] 24 | 25 | notFound :: W.Response 26 | notFound = W.ResponseLBS W.status404 [("Content-Type", "text/plain")] "Not found" 27 | -------------------------------------------------------------------------------- /warp/Network/Wai/Handler/Warp/HTTP2/File.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Network.Wai.Handler.Warp.HTTP2.File where 4 | 5 | import Network.HTTP2.Server 6 | 7 | import Network.Wai.Handler.Warp.Types 8 | 9 | #ifdef WINDOWS 10 | pReadMaker :: InternalInfo -> PositionReadMaker 11 | pReadMaker _ = defaultPositionReadMaker 12 | #else 13 | import Network.Wai.Handler.Warp.FdCache 14 | import Network.Wai.Handler.Warp.SendFile (positionRead) 15 | 16 | -- | 'PositionReadMaker' based on file descriptor cache. 17 | -- 18 | -- Since 3.3.13 19 | pReadMaker :: InternalInfo -> PositionReadMaker 20 | pReadMaker ii path = do 21 | (mfd, refresh) <- getFd ii path 22 | case mfd of 23 | Just fd -> return (pread fd, Refresher refresh) 24 | Nothing -> do 25 | fd <- openFile path 26 | return (pread fd, Closer $ closeFile fd) 27 | where 28 | pread :: Fd -> PositionRead 29 | pread fd off bytes buf = fromIntegral <$> positionRead fd buf bytes' off' 30 | where 31 | bytes' = fromIntegral bytes 32 | off' = fromIntegral off 33 | #endif 34 | -------------------------------------------------------------------------------- /time-manager/time-manager.cabal: -------------------------------------------------------------------------------- 1 | Name: time-manager 2 | Version: 0.2.4 3 | Synopsis: Scalable timer 4 | License: MIT 5 | License-file: LICENSE 6 | Author: Michael Snoyman and Kazu Yamamoto 7 | Maintainer: kazu@iij.ad.jp 8 | Homepage: http://github.com/yesodweb/wai 9 | Category: System 10 | Build-Type: Simple 11 | Cabal-Version: >=1.10 12 | Stability: Stable 13 | Description: Scalable timer functions provided by a timer manager 14 | and thread management functions to prevent thread 15 | leak by a thread manager. 16 | Extra-Source-Files: ChangeLog.md 17 | 18 | Library 19 | Build-Depends: base >= 4.12 && < 5 20 | , auto-update >= 0.2 && < 0.3 21 | , containers 22 | , stm 23 | Default-Language: Haskell2010 24 | Exposed-modules: System.TimeManager 25 | Exposed-modules: System.ThreadManager 26 | Ghc-Options: -Wall 27 | -------------------------------------------------------------------------------- /wai/webkit-sample/webkit-sample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | 4 | import Data.ByteString (ByteString) 5 | import Data.ByteString.Builder (lazyByteString) 6 | import qualified Data.ByteString.Lazy as L 7 | import Data.Enumerator (Iteratee, consume) 8 | import Network.Wai 9 | import Network.Wai.Handler.Webkit 10 | 11 | main :: IO () 12 | main = putStrLn "http://localhost:3000/" >> run "Webkit Sample" app 13 | 14 | app :: Application 15 | app req = case pathInfo req of 16 | "/post/" -> do 17 | bss <- consume 18 | postResponse $ L.fromChunks bss 19 | _ -> indexResponse 20 | 21 | indexResponse :: Iteratee ByteString IO Response 22 | indexResponse = 23 | return $ 24 | ResponseFile 25 | status200 26 | [("Content-Type", "text/html")] 27 | "index.html" 28 | 29 | postResponse :: L.ByteString -> Iteratee ByteString IO Response 30 | postResponse lbs = 31 | return $ 32 | ResponseBuilder 33 | status200 34 | [("Content-Type", "text/plain")] 35 | (lazyByteString lbs) 36 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/RequestLogger/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | A module for containing some CPPed code, due to: 4 | -- 5 | -- https://github.com/yesodweb/wai/issues/192 6 | module Network.Wai.Middleware.RequestLogger.Internal ( 7 | getDateGetter, 8 | logToByteString, 9 | ) where 10 | 11 | #if !MIN_VERSION_wai_logger(2, 2, 0) 12 | import Control.Concurrent (forkIO, threadDelay) 13 | import Control.Monad (forever) 14 | #endif 15 | import Data.ByteString (ByteString) 16 | import Network.Wai.Logger (clockDateCacher) 17 | import System.Log.FastLogger (LogStr, fromLogStr) 18 | 19 | logToByteString :: LogStr -> ByteString 20 | logToByteString = fromLogStr 21 | 22 | getDateGetter 23 | :: IO () 24 | -- ^ flusher 25 | -> IO (IO ByteString) 26 | #if !MIN_VERSION_wai_logger(2, 2, 0) 27 | getDateGetter flusher = do 28 | (getter, updater) <- clockDateCacher 29 | _ <- forkIO $ forever $ do 30 | threadDelay 1000000 31 | updater 32 | flusher 33 | #else 34 | getDateGetter _ = do 35 | (getter, _) <- clockDateCacher 36 | #endif 37 | return getter 38 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/Timeout.hs: -------------------------------------------------------------------------------- 1 | -- | Timeout requests 2 | module Network.Wai.Middleware.Timeout ( 3 | timeout, 4 | timeoutStatus, 5 | timeoutAs, 6 | ) where 7 | 8 | import Network.HTTP.Types (Status, status503) 9 | import Network.Wai 10 | import qualified System.Timeout as Timeout 11 | 12 | -- | Time out the request after the given number of seconds 13 | -- 14 | -- Timeouts respond with @'status503'@. See @'timeoutStatus'@ or @'timeoutAs'@ 15 | -- to customize the behavior of the timed-out case. 16 | -- 17 | -- @since 3.0.24.0@ 18 | timeout :: Int -> Middleware 19 | timeout = timeoutStatus status503 20 | 21 | -- | Time out with the given @'Status'@ 22 | -- 23 | -- @since 3.0.24.0@ 24 | timeoutStatus :: Status -> Int -> Middleware 25 | timeoutStatus status = timeoutAs $ responseLBS status [] "" 26 | 27 | -- | Time out with the given @'Response'@ 28 | -- 29 | -- @since 3.0.24.0@ 30 | timeoutAs :: Response -> Int -> Middleware 31 | timeoutAs timeoutReponse seconds app req respond = 32 | maybe (respond timeoutReponse) pure 33 | =<< Timeout.timeout (seconds * 1000000) (app req respond) 34 | -------------------------------------------------------------------------------- /warp/test/ReadIntSpec.hs: -------------------------------------------------------------------------------- 1 | module ReadIntSpec (main, spec) where 2 | 3 | import Data.ByteString (ByteString) 4 | import qualified Data.ByteString.Char8 as B 5 | import Network.Wai.Handler.Warp.ReadInt 6 | import Test.Hspec 7 | import qualified Test.QuickCheck as QC 8 | 9 | main :: IO () 10 | main = hspec spec 11 | 12 | spec :: Spec 13 | spec = describe "readInt64" $ do 14 | it "converts ByteString to Int" $ 15 | QC.property (prop_read_show_idempotent readInt64) 16 | 17 | -- A QuickCheck property. Test that for a number >= 0, converting it to 18 | -- a string using show and then reading the value back with the function 19 | -- under test returns the original value. 20 | -- The functions under test only work on Natural numbers (the Conent-Length 21 | -- field in a HTTP header is always >= 0) so we check the absolute value of 22 | -- the value that QuickCheck generates for us. 23 | prop_read_show_idempotent 24 | :: (Integral a, Show a) => (ByteString -> a) -> a -> Bool 25 | prop_read_show_idempotent freader x = px == freader (toByteString px) 26 | where 27 | px = abs x 28 | toByteString = B.pack . show 29 | -------------------------------------------------------------------------------- /auto-update/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Michael Snoyman 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /wai-conduit/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Michael Snoyman 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /auto-update/test/Control/AutoUpdateSpec.hs: -------------------------------------------------------------------------------- 1 | module Control.AutoUpdateSpec (spec) where 2 | 3 | -- import Control.AutoUpdate 4 | -- import Control.Concurrent (threadDelay) 5 | -- import Control.Monad (replicateM_, forM_) 6 | -- import Data.IORef 7 | import Test.Hspec 8 | 9 | -- import Test.Hspec.QuickCheck 10 | 11 | spec :: Spec 12 | spec = return () 13 | 14 | -- do 15 | -- prop "incrementer" $ \st' -> do 16 | -- let st = abs st' `mod` 10000 17 | -- ref <- newIORef 0 18 | -- next <- mkAutoUpdate defaultUpdateSettings 19 | -- { updateAction = atomicModifyIORef ref $ \i -> 20 | -- let i' = succ i in i' `seq` (i', i') 21 | -- , updateSpawnThreshold = st 22 | -- , updateFreq = 10000 23 | -- } 24 | 25 | -- forM_ [1..st + 1] $ \i -> do 26 | -- j <- next 27 | -- j `shouldBe` i 28 | 29 | -- replicateM_ 50 $ do 30 | -- i <- next 31 | -- i `shouldBe` st + 2 32 | 33 | -- threadDelay 60000 34 | -- last1 <- readIORef ref 35 | -- threadDelay 20000 36 | -- last2 <- readIORef ref 37 | -- last2 `shouldBe` last1 38 | -------------------------------------------------------------------------------- /warp/Network/Wai/Handler/Warp/Imports.hs: -------------------------------------------------------------------------------- 1 | module Network.Wai.Handler.Warp.Imports ( 2 | ByteString (..), 3 | NonEmpty (..), 4 | module Control.Applicative, 5 | module Control.Monad, 6 | module Data.Bits, 7 | module Data.Int, 8 | module Data.Monoid, 9 | module Data.Ord, 10 | module Data.Word, 11 | module Data.Maybe, 12 | module Numeric, 13 | throughAsync, 14 | isAsyncException, 15 | ) where 16 | 17 | import Control.Applicative 18 | import Control.Exception 19 | import Control.Monad 20 | import Data.Bits 21 | import Data.ByteString.Internal (ByteString (..)) 22 | import Data.Int 23 | import Data.List.NonEmpty (NonEmpty (..)) 24 | import Data.Maybe 25 | import Data.Monoid 26 | import Data.Ord 27 | import Data.Word 28 | import Numeric 29 | 30 | isAsyncException :: Exception e => e -> Bool 31 | isAsyncException e = 32 | case fromException (toException e) of 33 | Just (SomeAsyncException _) -> True 34 | Nothing -> False 35 | 36 | throughAsync :: IO a -> SomeException -> IO a 37 | throughAsync action (SomeException e) 38 | | isAsyncException e = throwIO e 39 | | otherwise = action 40 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012-2017 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /wai-extra/test/sample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Data.ByteString.Char8 (pack) 4 | import Data.ByteString.Lazy (fromChunks) 5 | import Data.Text () 6 | import Network.HTTP.Types 7 | import Network.Wai 8 | import Network.Wai.Handler.Warp 9 | import Network.Wai.Middleware.Gzip 10 | import Network.Wai.Middleware.Jsonp 11 | 12 | app :: Application 13 | app request = return $ case pathInfo request of 14 | [] -> responseLBS status200 [] $ 15 | fromChunks $ 16 | flip map [1 .. 10000] $ \i -> 17 | pack $ 18 | concat 19 | [ "

Just this same paragraph again. " 20 | , show (i :: Int) 21 | , "

" 22 | ] 23 | ["test.html"] -> ResponseFile status200 [] "test.html" Nothing 24 | ["json"] -> 25 | ResponseFile 26 | status200 27 | [(hContentType, "application/json")] 28 | "json" 29 | Nothing 30 | _ -> ResponseFile status404 [] "../LICENSE" Nothing 31 | 32 | main :: IO () 33 | main = run 3000 $ gzip defaultGzipSettings $ jsonp app 34 | -------------------------------------------------------------------------------- /wai/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /warp/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /wai-extra/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /warp-tls/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /mime-types/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /time-manager/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /wai-app-static/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /wai-frontend-monadcgi/wai-frontend-monadcgi.cabal: -------------------------------------------------------------------------------- 1 | name: wai-frontend-monadcgi 2 | version: 3.0.0.3 3 | license: MIT 4 | license-file: LICENSE 5 | author: Michael Snoyman 6 | maintainer: Michael Snoyman 7 | synopsis: Run CGI apps on WAI. 8 | description: API docs and the README are available at . 9 | category: Web 10 | stability: stable 11 | cabal-version: >= 1.8 12 | build-type: Simple 13 | extra-source-files: README.md ChangeLog.md 14 | 15 | library 16 | build-depends: base >= 4.12 && < 5 17 | , bytestring 18 | , containers >= 0.2 19 | , cgi 20 | , http-types 21 | , transformers 22 | , case-insensitive 23 | , wai >= 3.0 && < 3.3 24 | exposed-modules: Network.Wai.Frontend.MonadCGI 25 | ghc-options: -Wall 26 | 27 | Source-repository head 28 | type: git 29 | location: git://github.com/yesodweb/wai.git 30 | -------------------------------------------------------------------------------- /wai-http2-extra/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Kazu Yamamoto, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /wai-websockets/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /wai-frontend-monadcgi/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/AcceptOverride.hs: -------------------------------------------------------------------------------- 1 | module Network.Wai.Middleware.AcceptOverride ( 2 | -- $howto 3 | acceptOverride, 4 | ) where 5 | 6 | import Control.Monad (join) 7 | import Network.Wai 8 | 9 | import Network.Wai.Header (replaceHeader) 10 | 11 | -- $howto 12 | -- This 'Middleware' provides a way for the request itself to 13 | -- tell the server to override the \"Accept\" header by looking 14 | -- for the \"_accept\" query parameter in the query string and 15 | -- inserting or replacing the \"Accept\" header with that string. 16 | -- 17 | -- For example: 18 | -- 19 | -- @ 20 | -- ?_accept=SomeValue 21 | -- @ 22 | -- 23 | -- This will result in \"Accept: SomeValue\" being set in the 24 | -- request as a header, and all other previous \"Accept\" headers 25 | -- will be removed from the request. 26 | 27 | acceptOverride :: Middleware 28 | acceptOverride app req = 29 | app req' 30 | where 31 | req' = 32 | case join $ lookup "_accept" $ queryString req of 33 | Nothing -> req 34 | Just a -> 35 | req 36 | { requestHeaders = replaceHeader "Accept" a $ requestHeaders req 37 | } 38 | -------------------------------------------------------------------------------- /stack-lts-21.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 2 | packages: 3 | - ./auto-update 4 | - ./mime-types 5 | - ./recv 6 | - ./time-manager 7 | - ./wai 8 | - ./wai-app-static 9 | - ./wai-conduit 10 | - ./wai-extra 11 | - ./wai-frontend-monadcgi 12 | - ./wai-http2-extra 13 | - ./wai-websockets 14 | - ./warp 15 | - ./warp-quic 16 | - ./warp-tls 17 | flags: 18 | wai-extra: 19 | build-example: true 20 | zlib: 21 | bundled-c-zlib: true 22 | nix: 23 | enable: false 24 | packages: 25 | - fcgi 26 | - zlib 27 | extra-deps: 28 | - crypto-token-0.1.2 29 | - crypton-1.0.4 30 | - crypton-x509-1.7.7 31 | - crypton-x509-store-1.6.11 32 | - crypton-x509-system-1.6.7 33 | - crypton-x509-validation-1.6.13 34 | - ech-config-0.0.1 35 | - hashable-1.4.7.0 36 | - hpke-0.0.0 37 | - http-semantics-0.4.0 38 | - http2-5.4.0 39 | - http3-0.1.2 40 | - mwc-random-0.15.2.0 41 | - network-3.2.7.0 42 | - network-control-0.1.7 43 | - os-string-2.0.8 44 | - quic-0.2.21 45 | - random-1.3.1 46 | - sockaddr-0.0.1 47 | - tls-2.1.11 48 | - tls-session-manager-0.0.7 49 | - unix-time-0.4.16 50 | - uuid-types-1.0.6 51 | - websockets-0.13.0.0 52 | - zlib-0.7.1.0 53 | - zlib-clib-1.3.1 54 | -------------------------------------------------------------------------------- /time-manager/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # ChangeLog for time-manager 2 | 3 | ## 0.2.4 4 | 5 | * Providing `isAllGone`. 6 | * Providing emptyHandle. 7 | 8 | ## 0.2.3 9 | 10 | * Exporting defaultManager. 11 | 12 | ## 0.2.2 13 | 14 | * `initialize` with non positive integer creates a time manager 15 | which does not maintain timeout. 16 | [#1017](https://github.com/yesodweb/wai/pull/1017) 17 | 18 | ## 0.2.1 19 | 20 | * Export KilledByThreadManager exception 21 | [#1016](https://github.com/yesodweb/wai/pull/1016) 22 | 23 | ## 0.2.0 24 | 25 | * Providing `System.ThreadManager`. 26 | * `withHandle` catches `TimeoutThread` internally. 27 | It returns `Nothing` on timeout. 28 | 29 | ## 0.1.3 30 | 31 | * Providing `withHandle` and `withHandleKillThread`. 32 | 33 | ## 0.1.2 34 | 35 | * Holding `Weak ThreadId` to prevent thread leak again 36 | [#1013](https://github.com/yesodweb/wai/pull/1013) 37 | 38 | ## 0.1.1 39 | 40 | * Removing `unliftio`. 41 | 42 | ## 0.1.0 43 | 44 | * [#986](https://github.com/yesodweb/wai/pull/986) 45 | * Change behavior of `cancel` to immediately remove the `Handle` from the 46 | reaper's workload, rather than waiting for timeout. 47 | * Using auto-update v0.2.0. 48 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Test/Internal.hs: -------------------------------------------------------------------------------- 1 | module Network.Wai.Test.Internal where 2 | 3 | import Control.Monad.Trans.Reader (ReaderT, runReaderT) 4 | import qualified Control.Monad.Trans.State as ST 5 | import Data.ByteString (ByteString) 6 | import Data.Map (Map) 7 | import qualified Data.Map as Map 8 | import Network.Wai (Application) 9 | import qualified Web.Cookie as Cookie 10 | 11 | type Session = ReaderT Application (ST.StateT ClientState IO) 12 | 13 | -- | 14 | -- 15 | -- Since 3.0.6 16 | type ClientCookies = Map ByteString Cookie.SetCookie 17 | 18 | newtype ClientState = ClientState 19 | { clientCookies :: ClientCookies 20 | } 21 | 22 | -- | 23 | -- 24 | -- Since 3.0.20.0 25 | initState :: ClientState 26 | initState = ClientState Map.empty 27 | 28 | -- | Like 'runSession', but if allows you to hand in cookies and get 29 | -- the updated cookies back. One use case for this is writing tests 30 | -- that address the application under test alternatingly through rest 31 | -- api and through db handle. 32 | -- 33 | -- Since 3.0.20.0 34 | runSessionWith :: ClientState -> Session a -> Application -> IO (a, ClientState) 35 | runSessionWith st session app = ST.runStateT (runReaderT session app) st 36 | -------------------------------------------------------------------------------- /warp/Network/Wai/Handler/Warp/Counter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Network.Wai.Handler.Warp.Counter ( 4 | Counter, 5 | newCounter, 6 | waitForZero, 7 | increase, 8 | decrease, 9 | waitForDecreased, 10 | getCount, 11 | ) where 12 | 13 | import Control.Concurrent.STM 14 | 15 | import Network.Wai.Handler.Warp.Imports 16 | 17 | newtype Counter = Counter (TVar Int) 18 | 19 | newCounter :: IO Counter 20 | newCounter = Counter <$> newTVarIO 0 21 | 22 | waitForZero :: Counter -> IO () 23 | waitForZero (Counter var) = atomically $ do 24 | x <- readTVar var 25 | when (x > 0) retry 26 | 27 | waitForDecreased :: Counter -> IO () 28 | waitForDecreased (Counter var) = do 29 | n0 <- atomically $ readTVar var 30 | atomically $ do 31 | n <- readTVar var 32 | check (n < n0) 33 | 34 | increase :: Counter -> IO () 35 | increase (Counter var) = atomically $ modifyTVar' var $ \x -> x + 1 36 | 37 | decrease :: Counter -> IO () 38 | decrease (Counter var) = atomically $ modifyTVar' var $ \x -> x - 1 39 | 40 | -- | Get the current count of open connections. 41 | -- 42 | -- Since 3.4.11 43 | getCount :: Counter -> IO Int 44 | getCount (Counter var) = readTVarIO var 45 | -------------------------------------------------------------------------------- /auto-update/test/Control/ReaperSpec.hs: -------------------------------------------------------------------------------- 1 | module Control.ReaperSpec (spec) where 2 | 3 | -- import Control.Concurrent 4 | -- import Control.Reaper 5 | -- import Data.IORef 6 | import Test.Hspec 7 | 8 | -- import Test.Hspec.QuickCheck 9 | 10 | spec :: Spec 11 | spec = return () 12 | 13 | -- prop "works" $ \is -> do 14 | -- reaper <- mkReaper defaultReaperSettings 15 | -- { reaperAction = action 16 | -- , reaperDelay = 1000 17 | -- } 18 | 19 | -- let mkTestCase i = do 20 | -- ref <- newIORef 0 21 | -- let expected = (abs i `mod` 10) + 1 22 | -- reaperAdd reaper (expected, ref) 23 | -- return (expected, ref) 24 | -- testCases <- mapM mkTestCase is 25 | 26 | -- let test (expected, ref) = do 27 | -- actual <- readIORef ref 28 | -- actual `shouldBe` (expected :: Int) 29 | -- threadDelay 100000 30 | -- mapM_ test testCases 31 | -- [] <- reaperRead reaper 32 | -- return () 33 | 34 | -- type Item = (Int, IORef Int) 35 | 36 | -- action = mkListAction $ \(i, ref) -> do 37 | -- modifyIORef ref succ 38 | -- return $ if i > 1 39 | -- then Just (pred i, ref) 40 | -- else Nothing 41 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/HealthCheckEndpoint.hs: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------- 2 | 3 | --------------------------------------------------------- 4 | 5 | -- | 6 | -- Module : Network.Wai.Middleware.HealthCheckEndpoint 7 | -- Copyright : Michael Snoyman 8 | -- License : BSD3 9 | -- 10 | -- Maintainer : Michael Snoyman 11 | -- Stability : Unstable 12 | -- Portability : portable 13 | -- 14 | -- Add empty endpoint (for Health check tests) 15 | module Network.Wai.Middleware.HealthCheckEndpoint ( 16 | healthCheck, 17 | voidEndpoint, 18 | ) 19 | where 20 | 21 | import Data.ByteString (ByteString) 22 | import Network.HTTP.Types (status200) 23 | import Network.Wai 24 | 25 | -- | Add empty endpoint (for Health check tests) called \"/_healthz\" 26 | -- 27 | -- @since 3.1.9 28 | healthCheck :: Middleware 29 | healthCheck = voidEndpoint "/_healthz" 30 | 31 | -- | Add empty endpoint 32 | -- 33 | -- @since 3.1.9 34 | voidEndpoint :: ByteString -> Middleware 35 | voidEndpoint endpointPath router request respond = 36 | if rawPathInfo request == endpointPath 37 | then respond $ responseLBS status200 mempty "-" 38 | else router request respond 39 | -------------------------------------------------------------------------------- /warp/Network/Wai/Handler/Warp/ReadInt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- Copyright : Erik de Castro Lopo 5 | -- License : BSD3 6 | 7 | module Network.Wai.Handler.Warp.ReadInt ( 8 | readInt, 9 | readInt64, 10 | ) where 11 | 12 | import qualified Data.ByteString as S 13 | import Data.Word8 (isDigit, _0) 14 | 15 | import Network.Wai.Handler.Warp.Imports hiding (readInt) 16 | 17 | {-# INLINE readInt #-} 18 | 19 | -- | Will 'takeWhile isDigit' and return the parsed 'Integral'. 20 | readInt :: Integral a => ByteString -> a 21 | readInt bs = fromIntegral $ readInt64 bs 22 | 23 | -- This function is used to parse the Content-Length field of HTTP headers and 24 | -- is a performance hot spot. It should only be replaced with something 25 | -- significantly and provably faster. 26 | -- 27 | -- It needs to be able work correctly on 32 bit CPUs for file sizes > 2G so we 28 | -- use Int64 here and then make a generic 'readInt' that allows conversion to 29 | -- Int and Integer. 30 | 31 | {-# NOINLINE readInt64 #-} 32 | readInt64 :: ByteString -> Int64 33 | readInt64 bs = 34 | S.foldl' (\ !i !c -> i * 10 + fromIntegral (c - _0)) 0 $ 35 | S.takeWhile isDigit bs 36 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/CleanPath.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Network.Wai.Middleware.CleanPath ( 4 | cleanPath, 5 | ) where 6 | 7 | import qualified Data.ByteString.Char8 as B 8 | import qualified Data.ByteString.Lazy as L 9 | #if __GLASGOW_HASKELL__ < 710 10 | import Data.Monoid (mconcat) 11 | #endif 12 | import Data.Text (Text) 13 | import Network.HTTP.Types (hLocation, status301) 14 | import Network.Wai (Application, pathInfo, rawQueryString, responseLBS) 15 | 16 | cleanPath 17 | :: ([Text] -> Either B.ByteString [Text]) 18 | -> B.ByteString 19 | -> ([Text] -> Application) 20 | -> Application 21 | cleanPath splitter prefix app env sendResponse = 22 | case splitter $ pathInfo env of 23 | Right pieces -> app pieces env sendResponse 24 | Left p -> 25 | sendResponse $ 26 | responseLBS 27 | status301 28 | [(hLocation, mconcat [prefix, p, suffix])] 29 | L.empty 30 | where 31 | -- include the query string if present 32 | suffix = 33 | case B.uncons $ rawQueryString env of 34 | Nothing -> B.empty 35 | Just ('?', _) -> rawQueryString env 36 | _ -> B.cons '?' $ rawQueryString env 37 | -------------------------------------------------------------------------------- /auto-update/Control/Reaper/Internal.hs: -------------------------------------------------------------------------------- 1 | module Control.Reaper.Internal (Reaper (..)) where 2 | 3 | -- | A data structure to hold reaper APIs. 4 | data Reaper workload item = Reaper 5 | { reaperAdd :: item -> IO () 6 | -- ^ Adding an item to the workload 7 | , reaperRead :: IO workload 8 | -- ^ Reading workload. 9 | , reaperModify :: (workload -> workload) -> IO workload 10 | -- ^ Modify the workload. The resulting workload is returned. 11 | -- 12 | -- If there is no reaper thread, the modifier will not be applied and 13 | -- 'reaperEmpty' will be returned. 14 | -- 15 | -- If the reaper is currently executing jobs, those jobs will not be in 16 | -- the given workload and the workload might appear empty. 17 | -- 18 | -- If all jobs are removed by the modifier, the reaper thread will not be 19 | -- killed. The reaper thread will only terminate if 'reaperKill' is called 20 | -- or the result of 'reaperAction' satisfies 'reaperNull'. 21 | -- 22 | -- @since 0.2.0 23 | , reaperStop :: IO workload 24 | -- ^ Stopping the reaper thread if exists. 25 | -- The current workload is returned. 26 | , reaperKill :: IO () 27 | -- ^ Killing the reaper thread immediately if exists. 28 | } 29 | -------------------------------------------------------------------------------- /warp/test/HTTP.hs: -------------------------------------------------------------------------------- 1 | module HTTP ( 2 | sendGET, 3 | sendGETwH, 4 | sendHEAD, 5 | sendHEADwH, 6 | responseBody, 7 | responseStatus, 8 | responseHeaders, 9 | getHeaderValue, 10 | HeaderName, 11 | ) where 12 | 13 | import Data.ByteString 14 | import qualified Data.ByteString.Lazy as BL 15 | import Network.HTTP.Client 16 | import Network.HTTP.Types 17 | 18 | sendGET :: String -> IO (Response BL.ByteString) 19 | sendGET url = sendGETwH url [] 20 | 21 | sendGETwH :: String -> [Header] -> IO (Response BL.ByteString) 22 | sendGETwH url hdr = do 23 | manager <- newManager defaultManagerSettings 24 | request <- parseRequest url 25 | let request' = request{requestHeaders = hdr} 26 | response <- httpLbs request' manager 27 | return response 28 | 29 | sendHEAD :: String -> IO (Response BL.ByteString) 30 | sendHEAD url = sendHEADwH url [] 31 | 32 | sendHEADwH :: String -> [Header] -> IO (Response BL.ByteString) 33 | sendHEADwH url hdr = do 34 | manager <- newManager defaultManagerSettings 35 | request <- parseRequest url 36 | let request' = request{requestHeaders = hdr, method = methodHead} 37 | response <- httpLbs request' manager 38 | return response 39 | 40 | getHeaderValue :: HeaderName -> [Header] -> Maybe ByteString 41 | getHeaderValue = lookup 42 | -------------------------------------------------------------------------------- /stack-lts-20.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.26 2 | packages: 3 | - ./auto-update 4 | - ./mime-types 5 | - ./recv 6 | - ./time-manager 7 | - ./wai 8 | - ./wai-conduit 9 | - ./wai-app-static 10 | - ./wai-extra 11 | - ./wai-frontend-monadcgi 12 | - ./wai-http2-extra 13 | - ./wai-websockets 14 | - ./warp 15 | - ./warp-quic 16 | - ./warp-tls 17 | flags: 18 | wai-extra: 19 | build-example: true 20 | zlib: 21 | bundled-c-zlib: true 22 | nix: 23 | enable: false 24 | packages: 25 | - fcgi 26 | - zlib 27 | extra-deps: 28 | - cgi-3001.5.0.1 29 | - crypto-token-0.1.2 30 | - crypton-1.0.4 31 | - crypton-x509-1.7.7 32 | - crypton-x509-store-1.6.11 33 | - crypton-x509-system-1.6.7 34 | - crypton-x509-validation-1.6.13 35 | - ech-config-0.0.1 36 | - fast-logger-3.2.5 37 | - hashable-1.4.7.0 38 | - hpke-0.0.0 39 | - http-semantics-0.4.0 40 | - http2-5.4.0 41 | - http3-0.1.2 42 | - memory-0.18.0 43 | - multipart-0.2.1 44 | - mwc-random-0.15.2.0 45 | - network-3.2.7.0 46 | - network-byte-order-0.1.7 47 | - network-control-0.1.7 48 | - os-string-2.0.8 49 | - random-1.3.1 50 | - quic-0.2.21 51 | - sockaddr-0.0.1 52 | - tls-2.1.11 53 | - tls-session-manager-0.0.7 54 | - unix-time-0.4.16 55 | - uuid-types-1.0.6 56 | - websockets-0.13.0.0 57 | - zlib-0.7.1.0 58 | - zlib-clib-1.3.1 59 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/ForceSSL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | Redirect non-SSL requests to https 4 | -- 5 | -- Since 3.0.7 6 | module Network.Wai.Middleware.ForceSSL ( 7 | forceSSL, 8 | ) where 9 | 10 | #if __GLASGOW_HASKELL__ < 710 11 | import Control.Applicative ((<$>)) 12 | import Data.Monoid (mempty) 13 | #endif 14 | #if __GLASGOW_HASKELL__ < 804 15 | import Data.Monoid ((<>)) 16 | #endif 17 | import Network.HTTP.Types (hLocation, methodGet, status301, status307) 18 | import Network.Wai (Middleware, Request (..), Response, responseBuilder) 19 | 20 | import Network.Wai.Request (appearsSecure) 21 | 22 | -- | For requests that don't appear secure, redirect to https 23 | -- 24 | -- Since 3.0.7 25 | forceSSL :: Middleware 26 | forceSSL app req sendResponse = 27 | case (appearsSecure req, redirectResponse req) of 28 | (False, Just resp) -> sendResponse resp 29 | _ -> app req sendResponse 30 | 31 | redirectResponse :: Request -> Maybe Response 32 | redirectResponse req = do 33 | host <- requestHeaderHost req 34 | return $ responseBuilder status [(hLocation, location host)] mempty 35 | where 36 | location h = "https://" <> h <> rawPathInfo req <> rawQueryString req 37 | status 38 | | requestMethod req == methodGet = status301 39 | | otherwise = status307 40 | -------------------------------------------------------------------------------- /warp/Network/Wai/Handler/Warp/HashMap.hs: -------------------------------------------------------------------------------- 1 | module Network.Wai.Handler.Warp.HashMap where 2 | 3 | import Data.Hashable (hash) 4 | import Data.IntMap.Strict (IntMap) 5 | import qualified Data.IntMap.Strict as I 6 | import Data.Map.Strict (Map) 7 | import qualified Data.Map.Strict as M 8 | import Prelude hiding (lookup) 9 | 10 | ---------------------------------------------------------------- 11 | 12 | -- | 'HashMap' is used for cache of file information. 13 | -- Hash values of file pathes are used as outer keys. 14 | -- Because negative entries are also contained, 15 | -- a bad guy can intentionally cause the hash collison. 16 | -- So, 'Map' is used internally to prevent 17 | -- the hash collision attack. 18 | newtype HashMap v = HashMap (IntMap (Map FilePath v)) 19 | 20 | ---------------------------------------------------------------- 21 | 22 | empty :: HashMap v 23 | empty = HashMap I.empty 24 | 25 | isEmpty :: HashMap v -> Bool 26 | isEmpty (HashMap hm) = I.null hm 27 | 28 | ---------------------------------------------------------------- 29 | 30 | insert :: FilePath -> v -> HashMap v -> HashMap v 31 | insert path v (HashMap hm) = 32 | HashMap $ 33 | I.insertWith M.union (hash path) (M.singleton path v) hm 34 | 35 | lookup :: FilePath -> HashMap v -> Maybe v 36 | lookup path (HashMap hm) = I.lookup (hash path) hm >>= M.lookup path 37 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/Routed.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- 3 | -- Since 3.0.9 4 | module Network.Wai.Middleware.Routed ( 5 | routedMiddleware, 6 | hostedMiddleware, 7 | ) where 8 | 9 | import Data.ByteString (ByteString) 10 | import Data.Text (Text) 11 | import Network.Wai 12 | 13 | -- | Apply a middleware based on a test of pathInfo 14 | -- 15 | -- example: 16 | -- 17 | -- > let corsify = routedMiddleWare ("static" `elem`) addCorsHeaders 18 | -- 19 | -- Since 3.0.9 20 | routedMiddleware 21 | :: ([Text] -> Bool) 22 | -- ^ Only use middleware if this pathInfo test returns True 23 | -> Middleware 24 | -- ^ middleware to apply the path prefix guard to 25 | -> Middleware 26 | -- ^ modified middleware 27 | routedMiddleware pathCheck middle app req 28 | | pathCheck (pathInfo req) = middle app req 29 | | otherwise = app req 30 | 31 | -- | Only apply the middleware to certain hosts 32 | -- 33 | -- Since 3.0.9 34 | hostedMiddleware 35 | :: ByteString 36 | -- ^ Domain the middleware applies to 37 | -> Middleware 38 | -- ^ middleware to apply the path prefix guard to 39 | -> Middleware 40 | -- ^ modified middleware 41 | hostedMiddleware domain middle app req 42 | | hasDomain domain req = middle app req 43 | | otherwise = app req 44 | 45 | hasDomain :: ByteString -> Request -> Bool 46 | hasDomain domain req = Just domain == requestHeaderHost req 47 | -------------------------------------------------------------------------------- /warp/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Network.Wai.Handler.Warp.HTTP2.PushPromise where 5 | 6 | import qualified Control.Exception as E 7 | import qualified Network.HTTP.Types as H 8 | import qualified Network.HTTP2.Server as H2 9 | 10 | import Network.Wai 11 | import Network.Wai.Handler.Warp.FileInfoCache 12 | import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data) 13 | import Network.Wai.Handler.Warp.HTTP2.Types 14 | import Network.Wai.Handler.Warp.Imports 15 | import Network.Wai.Handler.Warp.Types 16 | 17 | fromPushPromises :: InternalInfo -> Request -> IO [H2.PushPromise] 18 | fromPushPromises ii req = do 19 | mh2data <- getHTTP2Data req 20 | let pp = maybe [] http2dataPushPromise mh2data 21 | catMaybes <$> mapM (fromPushPromise ii) pp 22 | 23 | fromPushPromise :: InternalInfo -> PushPromise -> IO (Maybe H2.PushPromise) 24 | fromPushPromise ii (PushPromise path file rsphdr w) = do 25 | efinfo <- E.try $ getFileInfo ii file 26 | case efinfo of 27 | Left (_ex :: E.IOException) -> return Nothing 28 | Right finfo -> do 29 | let !siz = fromIntegral $ fileInfoSize finfo 30 | !fileSpec = H2.FileSpec file 0 siz 31 | !rsp = H2.responseFile H.ok200 rsphdr fileSpec 32 | !pp = H2.pushPromise path rsp w 33 | return $ Just pp 34 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/StreamFile.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- 3 | -- Since 3.0.4 4 | module Network.Wai.Middleware.StreamFile (streamFile) where 5 | 6 | import qualified Data.ByteString.Char8 as S8 7 | import Network.HTTP.Types (hContentLength) 8 | import Network.Wai (Middleware, responseStream, responseToStream) 9 | import Network.Wai.Internal 10 | import System.Directory (getFileSize) 11 | 12 | -- | Convert ResponseFile type responses into ResponseStream type 13 | -- 14 | -- Checks the response type, and if it's a ResponseFile, converts it 15 | -- into a ResponseStream. Other response types are passed through 16 | -- unchanged. 17 | -- 18 | -- Converted responses get a Content-Length header. 19 | -- 20 | -- Streaming a file will bypass a sendfile system call, and may be 21 | -- useful to work around systems without working sendfile 22 | -- implementations. 23 | -- 24 | -- Since 3.0.4 25 | streamFile :: Middleware 26 | streamFile app env sendResponse = app env $ \res -> 27 | case res of 28 | ResponseFile _ _ fp _ -> withBody sendBody 29 | where 30 | (s, hs, withBody) = responseToStream res 31 | sendBody :: StreamingBody -> IO ResponseReceived 32 | sendBody body = do 33 | len <- getFileSize fp 34 | let hs' = (hContentLength, S8.pack (show len)) : hs 35 | sendResponse $ responseStream s hs' body 36 | _ -> sendResponse res 37 | -------------------------------------------------------------------------------- /warp/Network/Wai/Handler/Warp/Date.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Network.Wai.Handler.Warp.Date ( 4 | withDateCache, 5 | GMTDate, 6 | ) where 7 | 8 | import Control.AutoUpdate ( 9 | defaultUpdateSettings, 10 | mkAutoUpdate, 11 | updateAction, 12 | updateThreadName, 13 | ) 14 | import Data.ByteString 15 | import Network.HTTP.Date 16 | 17 | #if WINDOWS 18 | import Data.Time (UTCTime, getCurrentTime) 19 | import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) 20 | import Foreign.C.Types (CTime(..)) 21 | #else 22 | import System.Posix (epochTime) 23 | #endif 24 | 25 | -- | The type of the Date header value. 26 | type GMTDate = ByteString 27 | 28 | -- | Creating 'DateCache' and executing the action. 29 | withDateCache :: (IO GMTDate -> IO a) -> IO a 30 | withDateCache action = initialize >>= action 31 | 32 | initialize :: IO (IO GMTDate) 33 | initialize = 34 | mkAutoUpdate 35 | defaultUpdateSettings 36 | { updateAction = formatHTTPDate <$> getCurrentHTTPDate 37 | , updateThreadName = "Date cacher (AutoUpdate)" 38 | } 39 | 40 | #ifdef WINDOWS 41 | uToH :: UTCTime -> HTTPDate 42 | uToH = epochTimeToHTTPDate . CTime . truncate . utcTimeToPOSIXSeconds 43 | 44 | getCurrentHTTPDate :: IO HTTPDate 45 | getCurrentHTTPDate = uToH <$> getCurrentTime 46 | #else 47 | getCurrentHTTPDate :: IO HTTPDate 48 | getCurrentHTTPDate = epochTimeToHTTPDate <$> epochTime 49 | #endif 50 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | 29 | -------------------------------------------------------------------------------- /wai-http2-extra/Network/Wai/Middleware/Push/Referer/LimitMultiMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | module Network.Wai.Middleware.Push.Referer.LimitMultiMap where 4 | 5 | import Data.Map (Map) 6 | import qualified Data.Map.Strict as M 7 | import Data.Set (Set) 8 | import qualified Data.Set as S 9 | 10 | data LimitMultiMap k v = LimitMultiMap 11 | { limitKey :: !Int 12 | , limitVal :: !Int 13 | , multiMap :: !(Map k (Set v)) 14 | } 15 | deriving (Eq, Show) 16 | 17 | isEmpty :: LimitMultiMap k t -> Bool 18 | isEmpty (LimitMultiMap _ _ m) = M.null m 19 | 20 | empty :: Int -> Int -> LimitMultiMap k v 21 | empty lk lv = LimitMultiMap lk lv M.empty 22 | 23 | insert :: (Ord k, Ord v) => (k, v) -> LimitMultiMap k v -> LimitMultiMap k v 24 | insert (k, v) (LimitMultiMap lk lv m) 25 | | siz < lk = let !m' = M.alter alt k m in LimitMultiMap lk lv m' 26 | | siz == lk = let !m' = M.adjust adj k m in LimitMultiMap lk lv m' 27 | | otherwise = error "insert" 28 | where 29 | siz = M.size m 30 | alt Nothing = Just $ S.singleton v 31 | alt s@(Just set) 32 | | S.size set == lv = s 33 | | otherwise = Just $ S.insert v set 34 | adj set 35 | | S.size set == lv = set 36 | | otherwise = S.insert v set 37 | 38 | lookup :: Ord k => k -> LimitMultiMap k v -> [v] 39 | lookup k (LimitMultiMap _ _ m) = case M.lookup k m of 40 | Nothing -> [] 41 | Just set -> S.toList set 42 | -------------------------------------------------------------------------------- /auto-update/Control/AutoUpdate/Types.hs: -------------------------------------------------------------------------------- 1 | module Control.AutoUpdate.Types where 2 | 3 | -- | Settings to control how values are updated. 4 | -- 5 | -- This should be constructed using 'defaultUpdateSettings' and record 6 | -- update syntax, e.g.: 7 | -- 8 | -- @ 9 | -- let settings = 'defaultUpdateSettings' { 'updateAction' = 'Data.Time.Clock.getCurrentTime' } 10 | -- @ 11 | -- 12 | -- @since 0.1.0 13 | data UpdateSettings a = UpdateSettings 14 | { updateFreq :: Int 15 | -- ^ Microseconds between update calls. Same considerations as 16 | -- 'threadDelay' apply. 17 | -- 18 | -- Default: 1000000 microseconds (1 second) 19 | -- 20 | -- @since 0.1.0 21 | , updateSpawnThreshold :: Int 22 | -- ^ Obsoleted field. 23 | -- 24 | -- @since 0.1.0 25 | , updateAction :: IO a 26 | -- ^ Action to be performed to get the current value. 27 | -- 28 | -- Default: does nothing. 29 | -- 30 | -- @since 0.1.0 31 | , updateThreadName :: String 32 | -- ^ Label of the thread being forked. 33 | -- 34 | -- Default: @"AutoUpdate"@ 35 | -- 36 | -- @since 0.2.2 37 | } 38 | 39 | -- | Default value for creating an 'UpdateSettings'. 40 | -- 41 | -- @since 0.1.0 42 | defaultUpdateSettings :: UpdateSettings () 43 | defaultUpdateSettings = 44 | UpdateSettings 45 | { updateFreq = 1000000 46 | , updateSpawnThreshold = 3 47 | , updateAction = return () 48 | , updateThreadName = "AutoUpdate" 49 | } 50 | -------------------------------------------------------------------------------- /mime-types/ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## 0.1.2.0 2 | 3 | * Added `defaultExtensionMap` to provide the inverse of `defaultMimeMap`. 4 | 5 | See PR [#930](https://github.com/yesodweb/wai/pull/930) and [#948](https://github.com/yesodweb/wai/pull/948). 6 | 7 | ## 0.1.1.0 8 | 9 | * Replace `audio/x-mpegurl` with IANA registered type 10 | `application/vnd.apple.mpegurl`. 11 | * Add TeX-related types; this includes `bib`, `tex`, `sty`, and `cls`. 12 | * Use type image/x-xcf for `.xcf` files. 13 | * Use type "audio/opus" for `.opus` files. 14 | * Add type text/vtt for `.vtt` text track files. 15 | * Use IANA registered type "application/vnd.rar" for `.rar` files. 16 | * Use font types defined in RFC 8081. 17 | * Replace `audio/x-m4a` with `audio/mp4`. 18 | * Change mime type for `.exe` files; use IANA registered type 19 | `application/vnd.microsoft.portable-executable`. 20 | * Add `video/dv` for files with extension `dv`. 21 | * Use 'application/xml' instead of 'text/xml'. 22 | * Change type for `.pcx` files to `image/vnd.zbrush.pcx`. 23 | * Use `text/markdown` type for `.md` and `.markdown` files. 24 | * Replace `application/x-gzip` with type `application/gzip`. 25 | 26 | See PR [#906](https://github.com/yesodweb/wai/pull/906). 27 | 28 | ## 0.1.0.9 29 | 30 | * Add mjs mime type 31 | 32 | ## 0.1.0.8 33 | 34 | * Add wasm mime type 35 | 36 | ## 0.1.0.7 37 | 38 | * Add support for .less files [#534](https://github.com/yesodweb/wai/pull/534) 39 | 40 | ## 0.1.0.6 41 | 42 | * Add woff2 mime type [#350](https://github.com/yesodweb/wai/pull/350) 43 | -------------------------------------------------------------------------------- /wai-extra/test/Network/Wai/Middleware/ApprootSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Network.Wai.Middleware.ApprootSpec ( 4 | main, 5 | spec, 6 | ) where 7 | 8 | import Data.ByteString (ByteString) 9 | import Network.HTTP.Types (RequestHeaders, status200) 10 | import Network.Wai 11 | import Test.Hspec 12 | 13 | import Network.Wai.Middleware.Approot (fromRequest, getApproot) 14 | import Network.Wai.Test (SResponse (simpleHeaders), request, runSession) 15 | 16 | main :: IO () 17 | main = hspec spec 18 | 19 | spec :: Spec 20 | spec = do 21 | let test name host secure headers expected = it name $ do 22 | resp <- runApp host secure headers 23 | simpleHeaders resp `shouldBe` [("Approot", expected)] 24 | test "respects host header" "foobar" False [] "http://foobar" 25 | test "respects isSecure" "foobar" True [] "https://foobar" 26 | test 27 | "respects SSL headers" 28 | "foobar" 29 | False 30 | [("HTTP_X_FORWARDED_SSL", "on")] 31 | "https://foobar" 32 | 33 | runApp :: ByteString -> Bool -> RequestHeaders -> IO SResponse 34 | runApp host secure headers = 35 | runSession 36 | ( request 37 | defaultRequest 38 | { requestHeaderHost = Just host 39 | , isSecure = secure 40 | , requestHeaders = headers 41 | } 42 | ) 43 | $ fromRequest app 44 | where 45 | app req respond = respond $ responseLBS status200 [("Approot", getApproot req)] "" 46 | -------------------------------------------------------------------------------- /wai-websockets/static/screen.css: -------------------------------------------------------------------------------- 1 | html { 2 | font-family: sans-serif; 3 | background-color: #335; 4 | font-size: 16px; 5 | } 6 | 7 | body { 8 | } 9 | 10 | h1 { 11 | text-align: center; 12 | font-size: 20px; 13 | color: #fff; 14 | padding: 10px 10px 20px 10px; 15 | } 16 | 17 | h2 { 18 | border-bottom: 1px solid black; 19 | display: block; 20 | font-size: 18px; 21 | } 22 | 23 | div#main { 24 | width: 600px; 25 | margin: 0px auto 0px auto; 26 | padding: 0px; 27 | background-color: #fff; 28 | height: 460px; 29 | } 30 | 31 | div#warnings { 32 | color: red; 33 | font-weight: bold; 34 | margin: 10px; 35 | } 36 | 37 | div#join-section { 38 | float: left; 39 | margin: 10px; 40 | } 41 | 42 | div#users-section { 43 | width: 170px; 44 | float: right; 45 | padding: 0px; 46 | margin: 10px; 47 | } 48 | 49 | ul#users { 50 | list-style-type: none; 51 | padding-left: 0px; 52 | height: 300px; 53 | overflow: auto; 54 | } 55 | 56 | div#chat-section { 57 | width: 390px; 58 | float: left; 59 | margin: 10px; 60 | } 61 | 62 | div#messages { 63 | margin: 0px; 64 | height: 300px; 65 | overflow: auto; 66 | } 67 | 68 | div#messages p { 69 | margin: 0px; 70 | padding: 0px; 71 | } 72 | 73 | div#footer { 74 | text-align: center; 75 | font-size: 12px; 76 | color: #fff; 77 | margin: 10px 0px 30px 0px; 78 | } 79 | 80 | div#footer a { 81 | color: #fff; 82 | } 83 | 84 | div.clear { 85 | clear: both; 86 | } 87 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/Vhost.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Network.Wai.Middleware.Vhost ( 4 | vhost, 5 | redirectWWW, 6 | redirectTo, 7 | redirectToLogged, 8 | ) where 9 | 10 | import qualified Data.ByteString as BS 11 | #if __GLASGOW_HASKELL__ < 710 12 | import Data.Monoid (mappend) 13 | #endif 14 | import Data.Text (Text) 15 | import qualified Data.Text.Encoding as TE 16 | import Network.HTTP.Types as H 17 | import Network.Wai 18 | 19 | vhost :: [(Request -> Bool, Application)] -> Application -> Application 20 | vhost vhosts def req = 21 | case filter (\(b, _) -> b req) vhosts of 22 | [] -> def req 23 | (_, app) : _ -> app req 24 | 25 | redirectWWW :: Text -> Application -> Application -- W.MiddleWare 26 | redirectWWW home = 27 | redirectIf 28 | home 29 | (maybe True (BS.isPrefixOf "www") . lookup "host" . requestHeaders) 30 | 31 | redirectIf :: Text -> (Request -> Bool) -> Application -> Application 32 | redirectIf home cond app req sendResponse = 33 | if cond req 34 | then sendResponse $ redirectTo $ TE.encodeUtf8 home 35 | else app req sendResponse 36 | 37 | redirectTo :: BS.ByteString -> Response 38 | redirectTo location = 39 | responseLBS 40 | H.status301 41 | [(H.hContentType, "text/plain"), (H.hLocation, location)] 42 | "Redirect" 43 | 44 | redirectToLogged :: (Text -> IO ()) -> BS.ByteString -> IO Response 45 | redirectToLogged logger loc = do 46 | logger $ "redirecting to: " `mappend` TE.decodeUtf8 loc 47 | return $ redirectTo loc 48 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/ForceDomain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | 4 | -- 5 | -- @since 3.0.14 6 | module Network.Wai.Middleware.ForceDomain where 7 | 8 | import Data.ByteString (ByteString) 9 | #if __GLASGOW_HASKELL__ < 804 10 | import Data.Monoid ((<>)) 11 | #if __GLASGOW_HASKELL__ < 710 12 | import Data.Monoid (mempty) 13 | #endif 14 | #endif 15 | import Network.HTTP.Types (hLocation, methodGet, status301, status307) 16 | import Network.Wai (Middleware, Request (..), responseBuilder) 17 | 18 | import Network.Wai.Request (appearsSecure) 19 | 20 | -- | Force a domain by redirecting. 21 | -- The `checkDomain` function takes the current domain and checks whether it is correct. 22 | -- It should return `Nothing` if the domain is correct, or `Just "domain.com"` if it is incorrect. 23 | -- 24 | -- @since 3.0.14 25 | forceDomain :: (ByteString -> Maybe ByteString) -> Middleware 26 | forceDomain checkDomain app req sendResponse = 27 | case requestHeaderHost req >>= checkDomain of 28 | Nothing -> 29 | app req sendResponse 30 | Just domain -> 31 | sendResponse $ redirectResponse domain 32 | where 33 | -- From: Network.Wai.Middleware.ForceSSL 34 | redirectResponse domain = 35 | responseBuilder status [(hLocation, location domain)] mempty 36 | 37 | location h = 38 | let p = if appearsSecure req then "https://" else "http://" 39 | in p <> h <> rawPathInfo req <> rawQueryString req 40 | 41 | status 42 | | requestMethod req == methodGet = status301 43 | | otherwise = status307 44 | -------------------------------------------------------------------------------- /warp/Network/Wai/Handler/Warp/PackInt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Network.Wai.Handler.Warp.PackInt where 5 | 6 | import Data.ByteString.Internal (unsafeCreate) 7 | import Data.Word8 (_0) 8 | import Foreign.Ptr (Ptr, plusPtr) 9 | import Foreign.Storable (poke) 10 | import qualified Network.HTTP.Types as H 11 | 12 | import Network.Wai.Handler.Warp.Imports 13 | 14 | packIntegral :: Integral a => a -> ByteString 15 | packIntegral 0 = "0" 16 | packIntegral n | n < 0 = error "packIntegral" 17 | packIntegral n = unsafeCreate len go0 18 | where 19 | n' = fromIntegral n + 1 :: Double 20 | len = ceiling $ logBase 10 n' 21 | go0 p = go n $ p `plusPtr` (len - 1) 22 | go :: Integral a => a -> Ptr Word8 -> IO () 23 | go i p = do 24 | let (d, r) = i `divMod` 10 25 | poke p (_0 + fromIntegral r) 26 | when (d /= 0) $ go d (p `plusPtr` (-1)) 27 | {-# SPECIALIZE packIntegral :: Int -> ByteString #-} 28 | {-# SPECIALIZE packIntegral :: Integer -> ByteString #-} 29 | 30 | -- | 31 | -- 32 | -- >>> packStatus H.status200 33 | -- "200" 34 | -- >>> packStatus H.preconditionFailed412 35 | -- "412" 36 | packStatus :: H.Status -> ByteString 37 | packStatus status = unsafeCreate 3 $ \p -> do 38 | poke p (toW8 r2) 39 | poke (p `plusPtr` 1) (toW8 r1) 40 | poke (p `plusPtr` 2) (toW8 r0) 41 | where 42 | toW8 :: Int -> Word8 43 | toW8 n = _0 + fromIntegral n 44 | !s = fromIntegral $ H.statusCode status 45 | (!q0, !r0) = s `divMod` 10 46 | (!q1, !r1) = q0 `divMod` 10 47 | !r2 = q1 `mod` 10 48 | -------------------------------------------------------------------------------- /warp/attic/server-no-keepalive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Control.Concurrent (forkIO) 4 | import Control.Exception (bracket) 5 | import Control.Monad (forever) 6 | import Control.Monad.IO.Class (liftIO) 7 | import Data.Enumerator (run_, ($$)) 8 | import qualified Data.Enumerator as E 9 | import qualified Data.Enumerator.Binary as EB 10 | import Network (sClose) 11 | import Network.HTTP.Types (status200) 12 | import Network.Socket (accept) 13 | import Network.Wai (responseLBS) 14 | import Network.Wai.Handler.Warp 15 | 16 | app = 17 | const $ 18 | return $ 19 | responseLBS 20 | status200 21 | [("Content-type", "text/plain")] 22 | "This is not kept alive under any circumstances" 23 | 24 | main = withManager 30000000 $ \man -> 25 | bracket 26 | (bindPort (settingsPort set) (settingsHost set)) 27 | sClose 28 | ( \socket -> forever $ do 29 | (conn, sa) <- accept socket 30 | th <- liftIO $ registerKillThread man 31 | _ <- forkIO $ do 32 | run_ $ 33 | enumSocket th 4096 conn $$ do 34 | liftIO $ pause th 35 | (len, env) <- parseRequest (settingsPort set) sa 36 | liftIO $ resume th 37 | res <- E.joinI $ EB.isolate len $$ app env 38 | _ <- liftIO $ sendResponse th env conn res 39 | liftIO $ sClose conn 40 | return () 41 | ) 42 | where 43 | set = defaultSettings 44 | -------------------------------------------------------------------------------- /recv/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022, Internet Initiative Japan Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in 12 | the documentation and/or other materials provided with the 13 | distribution. 14 | * Neither the name of the copyright holders nor the names of its 15 | contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 21 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 22 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 23 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 24 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 28 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29 | POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /warp-quic/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020, IIJ Innovation Institute Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in 12 | the documentation and/or other materials provided with the 13 | distribution. 14 | * Neither the name of the copyright holders nor the names of its 15 | contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 21 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 22 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 23 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 24 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 28 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29 | POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /warp/attic/runtests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Test.Framework (Test, defaultMain, testGroup) 4 | import Test.Framework.Providers.HUnit 5 | import Test.Framework.Providers.QuickCheck2 6 | import Test.HUnit hiding (Test) 7 | 8 | import Control.Exception (fromException) 9 | import qualified Data.ByteString.Char8 as S8 10 | import Data.Enumerator (enumList, run, run_, ($$)) 11 | import Network.Wai.Handler.Warp (InvalidRequest (..), readInt, takeHeaders) 12 | 13 | main :: IO () 14 | main = defaultMain [testSuite] 15 | 16 | testSuite :: Test 17 | testSuite = 18 | testGroup 19 | "Text.Hamlet" 20 | [ testCase "takeUntilBlank safe" caseTakeUntilBlankSafe 21 | , testCase "takeUntilBlank too many lines" caseTakeUntilBlankTooMany 22 | , testCase "takeUntilBlank too large" caseTakeUntilBlankTooLarge 23 | , testProperty "takeInt" $ \i' -> 24 | let i = abs i' 25 | in i == readInt (S8.pack $ show i) 26 | ] 27 | 28 | caseTakeUntilBlankSafe = do 29 | x <- run_ $ (enumList 1 ["f", "oo\n", "bar\nbaz\n\r\n"]) $$ takeHeaders 30 | x @?= ["foo", "bar", "baz"] 31 | 32 | assertException x (Left se) = 33 | case fromException se of 34 | Just e -> e @?= x 35 | Nothing -> assertFailure "Not an exception" 36 | assertException _ _ = assertFailure "Not an exception" 37 | 38 | caseTakeUntilBlankTooMany = do 39 | x <- run $ (enumList 1 $ repeat "f\n") $$ takeHeaders 40 | assertException OverLargeHeader x 41 | 42 | caseTakeUntilBlankTooLarge = do 43 | x <- run $ (enumList 1 $ repeat "f") $$ takeHeaders 44 | assertException OverLargeHeader x 45 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | # Number of spaces per indentation step 2 | indentation: 4 3 | 4 | # Max line length for automatic line breaking 5 | column-limit: 80 6 | 7 | # Styling of arrows in type signatures (choices: trailing, leading, or leading-args) 8 | function-arrows: leading 9 | 10 | # How to place commas in multi-line lists, records, etc. (choices: leading or trailing) 11 | comma-style: leading 12 | 13 | # Styling of import/export lists (choices: leading, trailing, or diff-friendly) 14 | import-export-style: diff-friendly 15 | 16 | # Whether to full-indent or half-indent 'where' bindings past the preceding body 17 | indent-wheres: false 18 | 19 | # Whether to leave a space before an opening record brace 20 | record-brace-space: false 21 | 22 | # Number of spaces between top-level declarations 23 | newlines-between-decls: 1 24 | 25 | # How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) 26 | haddock-style: single-line 27 | 28 | # How to print module docstring 29 | haddock-style-module: null 30 | 31 | # Styling of let blocks (choices: auto, inline, newline, or mixed) 32 | let-style: inline 33 | 34 | # How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) 35 | in-style: right-align 36 | 37 | # Whether to put parentheses around a single constraint (choices: auto, always, or never) 38 | single-constraint-parens: never 39 | 40 | # Output Unicode syntax (choices: detect, always, or never) 41 | unicode: never 42 | 43 | # Give the programmer more choice on where to insert blank lines 44 | respectful: true 45 | 46 | # Fixity information for operators 47 | fixities: [] 48 | 49 | -------------------------------------------------------------------------------- /recv/Network/Socket/BufferPool.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides efficient receiving functions from the network. 2 | -- 'Network.Socket.ByteString.recv' uses 'createAndTrim' 3 | -- which behaves as follows: 4 | -- 5 | -- * Allocates a buffer whose size is decided from the 6 | -- first argument. 7 | -- * Receives data with the buffer. 8 | -- * Allocates another buffer whose size fits the received data. 9 | -- * Copies the data from the first buffer to the second buffer. 10 | -- 11 | -- On 64bit machines, the global lock is taken for the allocation of 12 | -- a byte string whose length is larger than or equal to 3272 bytes. 13 | -- So, for instance, if 4,096 is specified to 'recv' and the size of 14 | -- received data is 3,300, the global lock is taken twice with the copy 15 | -- overhead. 16 | -- 17 | -- The efficient receiving functions provided here use a buffer pool. 18 | -- A large buffer is allocated at the beginning and it is divided into 19 | -- a used one and a leftover when receiving. 20 | -- The latter is kept in the buffer pool and will be used next time. 21 | -- When the buffer gets small 22 | -- and usefless, a new large buffer is allocated. 23 | module Network.Socket.BufferPool ( 24 | -- * Recv 25 | Recv, 26 | receive, 27 | BufferPool, 28 | newBufferPool, 29 | withBufferPool, 30 | 31 | -- * RecvN 32 | RecvN, 33 | makeRecvN, 34 | 35 | -- * Types 36 | Buffer, 37 | BufSize, 38 | 39 | -- * Utilities 40 | mallocBS, 41 | copy, 42 | ) where 43 | 44 | import Network.Socket.BufferPool.Buffer 45 | import Network.Socket.BufferPool.Recv 46 | import Network.Socket.BufferPool.Types 47 | -------------------------------------------------------------------------------- /recv/recv.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: recv 3 | version: 0.1.1 4 | license: BSD3 5 | license-file: LICENSE 6 | maintainer: kazu@iij.ad.jp 7 | author: Kazu Yamamoto 8 | stability: Stable 9 | homepage: http://github.com/yesodweb/wai 10 | synopsis: Efficient network recv 11 | description: Network recv based on buffer pools 12 | category: Network 13 | build-type: Simple 14 | extra-source-files: ChangeLog.md 15 | 16 | library 17 | exposed-modules: Network.Socket.BufferPool 18 | other-modules: 19 | Network.Socket.BufferPool.Buffer 20 | Network.Socket.BufferPool.Recv 21 | Network.Socket.BufferPool.Types 22 | 23 | default-language: Haskell2010 24 | ghc-options: -Wall 25 | build-depends: 26 | base >=4.12 && <5, 27 | bytestring >=0.9.1.4, 28 | network >=3.1.0 29 | 30 | if impl(ghc >=8) 31 | default-extensions: Strict StrictData 32 | 33 | test-suite spec 34 | type: exitcode-stdio-1.0 35 | main-is: Spec.hs 36 | build-tool-depends: hspec-discover:hspec-discover 37 | hs-source-dirs: test . 38 | other-modules: 39 | BufferPoolSpec 40 | Network.Socket.BufferPool 41 | Network.Socket.BufferPool.Buffer 42 | Network.Socket.BufferPool.Recv 43 | Network.Socket.BufferPool.Types 44 | 45 | default-language: Haskell2010 46 | ghc-options: -Wall 47 | build-depends: 48 | base >=4.12 && <5, 49 | bytestring >=0.9.1.4, 50 | network >=3.1.0, 51 | hspec 52 | -------------------------------------------------------------------------------- /recv/test/BufferPoolSpec.hs: -------------------------------------------------------------------------------- 1 | module BufferPoolSpec where 2 | 3 | import qualified Data.ByteString as B 4 | import qualified Data.ByteString.Internal as B (ByteString (PS)) 5 | import Foreign.ForeignPtr (withForeignPtr) 6 | import Foreign.Marshal.Utils (copyBytes) 7 | import Foreign.Ptr (plusPtr) 8 | 9 | import Network.Socket.BufferPool 10 | import Test.Hspec (Spec, describe, hspec, it, shouldBe) 11 | 12 | main :: IO () 13 | main = hspec spec 14 | 15 | -- Two ByteStrings each big enough to fill a buffer (16K). 16 | wantData, otherData :: B.ByteString 17 | wantData = B.replicate 16384 0xac 18 | otherData = B.replicate 16384 0x77 19 | 20 | spec :: Spec 21 | spec = describe "withBufferPool" $ do 22 | it "does not clobber buffers" $ do 23 | pool <- newBufferPool 2048 16384 24 | -- 'pool' contains B.empty; prime it to contain a real buffer. 25 | _ <- withBufferPool pool $ \_ _ -> return 0 26 | -- 'pool' contains a 16K buffer; fill it with \xac and keep the result. 27 | got <- withBufferPool pool $ blitBuffer wantData 28 | got `shouldBe` wantData 29 | -- 'pool' should now be empty and reallocate, rather than clobber the 30 | -- previous buffer. 31 | _ <- withBufferPool pool $ blitBuffer otherData 32 | got `shouldBe` wantData 33 | 34 | -- Fill the Buffer with the contents of the ByteString and return the number of 35 | -- bytes written. To be used with 'withBufferPool'. 36 | blitBuffer :: B.ByteString -> Buffer -> BufSize -> IO Int 37 | blitBuffer (B.PS fp off len) dst len' = withForeignPtr fp $ \ptr -> do 38 | let src = ptr `plusPtr` off 39 | n = min len len' 40 | copyBytes dst src n 41 | return n 42 | -------------------------------------------------------------------------------- /wai-app-static/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | 4 | module Util ( 5 | relativeDirFromPieces, 6 | defaultMkRedirect, 7 | replace, 8 | remove, 9 | dropLastIfNull, 10 | ) where 11 | 12 | import Data.ByteString (ByteString) 13 | import qualified Data.ByteString.Char8 as S8 14 | import qualified Data.Text as T 15 | import qualified Data.Text.Encoding as TE 16 | import WaiAppStatic.Types 17 | 18 | -- alist helper functions 19 | replace :: Eq a => a -> b -> [(a, b)] -> [(a, b)] 20 | replace k v [] = [(k, v)] 21 | replace k v (x : xs) 22 | | fst x == k = (k, v) : xs 23 | | otherwise = x : replace k v xs 24 | 25 | remove :: Eq a => a -> [(a, b)] -> [(a, b)] 26 | remove _ [] = [] 27 | remove k (x : xs) 28 | | fst x == k = xs 29 | | otherwise = x : remove k xs 30 | 31 | -- | Turn a list of pieces into a relative path to the root folder. 32 | relativeDirFromPieces :: Pieces -> T.Text 33 | relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir 34 | 35 | -- | Construct redirects with relative paths. 36 | defaultMkRedirect :: Pieces -> ByteString -> S8.ByteString 37 | defaultMkRedirect pieces newPath 38 | | S8.null newPath 39 | || S8.null relDir 40 | || S8.last relDir /= '/' 41 | || S8.head newPath /= '/' = 42 | relDir `S8.append` newPath 43 | | otherwise = relDir `S8.append` S8.tail newPath 44 | where 45 | relDir = TE.encodeUtf8 (relativeDirFromPieces pieces) 46 | 47 | dropLastIfNull :: [Piece] -> [Piece] 48 | dropLastIfNull pieces = case pieces of 49 | [fromPiece -> ""] -> [] 50 | (a : r) -> a : dropLastIfNull r 51 | [] -> [] 52 | -------------------------------------------------------------------------------- /wai-websockets/static/client.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Haskell WebSockets example 4 | 5 | 6 | 7 | 8 | 9 |

Haskell WebSockets example

10 |
11 |
12 |
13 |
14 |

Join

15 |
16 | 17 | 18 | 19 |
20 |
21 | 26 | 36 |
37 | 40 | 41 | 42 | -------------------------------------------------------------------------------- /wai-http2-extra/Network/Wai/Middleware/Push/Referer/Manager.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module Network.Wai.Middleware.Push.Referer.Manager ( 5 | MakePushPromise, 6 | defaultMakePushPromise, 7 | Settings (..), 8 | defaultSettings, 9 | Manager, 10 | URLPath, 11 | getManager, 12 | Network.Wai.Middleware.Push.Referer.Manager.lookup, 13 | Network.Wai.Middleware.Push.Referer.Manager.insert, 14 | ) where 15 | 16 | import Control.Monad (unless) 17 | import Data.IORef 18 | import Network.Wai.Handler.Warp hiding (Settings, defaultSettings) 19 | import System.IO.Unsafe (unsafePerformIO) 20 | 21 | import qualified Network.Wai.Middleware.Push.Referer.LRU as LRU 22 | import Network.Wai.Middleware.Push.Referer.Types 23 | 24 | newtype Manager = Manager (IORef (LRU.Cache URLPath PushPromise)) 25 | 26 | getManager :: Settings -> IO Manager 27 | getManager Settings{..} = do 28 | isInitialized <- atomicModifyIORef' lruInitialized $ \x -> (True, x) 29 | unless isInitialized $ do 30 | let cache = LRU.empty keyLimit valueLimit 31 | Manager ref = cacheManager 32 | writeIORef ref cache 33 | return cacheManager 34 | 35 | lruInitialized :: IORef Bool 36 | lruInitialized = unsafePerformIO $ newIORef False 37 | {-# NOINLINE lruInitialized #-} 38 | 39 | cacheManager :: Manager 40 | cacheManager = Manager $ unsafePerformIO $ newIORef $ LRU.empty 0 0 41 | {-# NOINLINE cacheManager #-} 42 | 43 | lookup :: URLPath -> Manager -> IO [PushPromise] 44 | lookup k (Manager ref) = atomicModifyIORef' ref $ LRU.lookup k 45 | 46 | insert :: URLPath -> PushPromise -> Manager -> IO () 47 | insert k v (Manager ref) = atomicModifyIORef' ref $ \c -> (LRU.insert k v c, ()) 48 | -------------------------------------------------------------------------------- /auto-update/auto-update.cabal: -------------------------------------------------------------------------------- 1 | name: auto-update 2 | version: 0.2.6.1 3 | synopsis: Efficiently run periodic, on-demand actions 4 | description: API docs and the README are available at . 5 | homepage: https://github.com/yesodweb/wai 6 | license: MIT 7 | license-file: LICENSE 8 | author: Michael Snoyman 9 | maintainer: michael@snoyman.com 10 | category: Control 11 | build-type: Simple 12 | extra-source-files: README.md 13 | ChangeLog.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | ghc-options: -Wall 18 | exposed-modules: Control.AutoUpdate 19 | Control.Debounce 20 | Control.Debounce.Internal 21 | Control.Reaper 22 | Control.Reaper.Internal 23 | other-modules: Control.AutoUpdate.Types 24 | Control.AutoUpdate.Thread 25 | if !os(windows) 26 | exposed-modules: Control.AutoUpdate.Internal 27 | other-modules: Control.AutoUpdate.Event 28 | build-depends: base >= 4.12 && < 5, 29 | stm 30 | default-language: Haskell2010 31 | if impl(ghc >= 8) 32 | default-extensions: Strict StrictData 33 | 34 | -- Test suite is currently not robust enough, gives too many false negatives. 35 | 36 | test-suite spec 37 | main-is: Spec.hs 38 | other-modules: Control.AutoUpdateSpec 39 | Control.DebounceSpec 40 | Control.ReaperSpec 41 | hs-source-dirs: test 42 | type: exitcode-stdio-1.0 43 | build-depends: base, auto-update, exceptions, hspec, retry, HUnit 44 | build-tool-depends: hspec-discover:hspec-discover 45 | default-language: Haskell2010 46 | -------------------------------------------------------------------------------- /wai-http2-extra/wai-http2-extra.cabal: -------------------------------------------------------------------------------- 1 | Name: wai-http2-extra 2 | Version: 0.1.3 3 | Synopsis: WAI utilities for HTTP/2 4 | License: MIT 5 | License-file: LICENSE 6 | Author: Kazu Yamamoto 7 | Maintainer: kazu@iij.ad.jp 8 | Homepage: http://github.com/yesodweb/wai 9 | Category: Web 10 | Build-Type: Simple 11 | Cabal-Version: >=1.10 12 | Stability: Stable 13 | Description: WAI utilities for HTTP/2 14 | 15 | Library 16 | Build-Depends: base >= 4.12 && < 5 17 | , bytestring 18 | , containers 19 | , http-types 20 | , psqueues 21 | , wai 22 | , warp 23 | , word8 24 | Exposed-modules: Network.Wai.Middleware.Push.Referer 25 | Other-modules: Network.Wai.Middleware.Push.Referer.LRU 26 | Network.Wai.Middleware.Push.Referer.Manager 27 | Network.Wai.Middleware.Push.Referer.Multi 28 | Network.Wai.Middleware.Push.Referer.ParseURL 29 | Network.Wai.Middleware.Push.Referer.Types 30 | Ghc-Options: -Wall 31 | if impl(ghc >= 8) 32 | default-extensions: Strict StrictData 33 | default-language: Haskell2010 34 | 35 | Test-Suite doctest 36 | Type: exitcode-stdio-1.0 37 | HS-Source-Dirs: test 38 | Ghc-Options: -threaded -Wall 39 | Main-Is: doctests.hs 40 | Build-Depends: base 41 | , doctest >= 0.10.1 42 | if impl(ghc >= 8) 43 | default-extensions: Strict StrictData 44 | default-language: Haskell2010 45 | 46 | Source-Repository head 47 | Type: git 48 | Location: git://github.com/yesodweb/wai.git 49 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/StripHeaders.hs: -------------------------------------------------------------------------------- 1 | -- This was written for one specific use case and then generalized. 2 | 3 | -- The specific use case was a JSON API with a consumer that would choke on the 4 | -- "Set-Cookie" response header. The solution was to test for the API's 5 | -- `pathInfo` in the Request and if it matched, filter the response headers. 6 | 7 | -- When using this, care should be taken not to strip out headers that are 8 | -- required for correct operation of the client (eg Content-Type). 9 | 10 | module Network.Wai.Middleware.StripHeaders ( 11 | stripHeader, 12 | stripHeaders, 13 | stripHeaderIf, 14 | stripHeadersIf, 15 | ) where 16 | 17 | import Data.ByteString (ByteString) 18 | import qualified Data.CaseInsensitive as CI 19 | import Network.Wai ( 20 | Middleware, 21 | Request, 22 | ifRequest, 23 | mapResponseHeaders, 24 | modifyResponse, 25 | ) 26 | import Network.Wai.Internal (Response) 27 | 28 | stripHeader :: ByteString -> (Response -> Response) 29 | stripHeader h = mapResponseHeaders (filter (\hdr -> fst hdr /= CI.mk h)) 30 | 31 | stripHeaders :: [ByteString] -> (Response -> Response) 32 | stripHeaders hs = 33 | let hnames = map CI.mk hs 34 | in mapResponseHeaders (filter (\hdr -> fst hdr `notElem` hnames)) 35 | 36 | -- | If the request satisifes the provided predicate, strip headers matching 37 | -- the provided header name. 38 | -- 39 | -- Since 3.0.8 40 | stripHeaderIf :: ByteString -> (Request -> Bool) -> Middleware 41 | stripHeaderIf h rpred = 42 | ifRequest rpred (modifyResponse $ stripHeader h) 43 | 44 | -- | If the request satisifes the provided predicate, strip all headers whose 45 | -- header name is in the list of provided header names. 46 | -- 47 | -- Since 3.0.8 48 | stripHeadersIf :: [ByteString] -> (Request -> Bool) -> Middleware 49 | stripHeadersIf hs rpred = 50 | ifRequest rpred (modifyResponse $ stripHeaders hs) 51 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/Middleware/MethodOverridePost.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | ----------------------------------------------------------------- 4 | 5 | ----------------------------------------------------------------- 6 | 7 | -- | Module : Network.Wai.Middleware.MethodOverridePost 8 | -- 9 | -- Changes the request-method via first post-parameter _method. 10 | module Network.Wai.Middleware.MethodOverridePost ( 11 | methodOverridePost, 12 | ) where 13 | 14 | import Data.ByteString.Lazy (toChunks) 15 | import Data.IORef (atomicModifyIORef, newIORef) 16 | #if __GLASGOW_HASKELL__ < 710 17 | import Data.Monoid (mconcat, mempty) 18 | #endif 19 | import Network.HTTP.Types (hContentType, parseQuery) 20 | import Network.Wai 21 | 22 | -- | Allows overriding of the HTTP request method via the _method post string parameter. 23 | -- 24 | -- * Looks for the Content-Type requestHeader. 25 | -- 26 | -- * If the header is set to application/x-www-form-urlencoded 27 | -- and the first POST parameter is _method 28 | -- then it changes the request-method to the value of that 29 | -- parameter. 30 | -- 31 | -- * This middleware only applies when the initial request method is POST. 32 | methodOverridePost :: Middleware 33 | methodOverridePost app req send = 34 | case (requestMethod req, lookup hContentType (requestHeaders req)) of 35 | ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send 36 | _ -> app req send 37 | 38 | setPost :: Request -> IO Request 39 | setPost req = do 40 | body <- (mconcat . toChunks) `fmap` lazyRequestBody req 41 | ref <- newIORef body 42 | let rb = atomicModifyIORef ref $ \bs -> (mempty, bs) 43 | req' = setRequestBodyChunks rb req 44 | case parseQuery body of 45 | (("_method", Just newmethod) : _) -> return req'{requestMethod = newmethod} 46 | _ -> return req' 47 | 48 | {- HLint ignore setPost "Use tuple-section" -} 49 | -------------------------------------------------------------------------------- /wai-extra/test/Network/Wai/Middleware/RoutedSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Network.Wai.Middleware.RoutedSpec ( 4 | main, 5 | spec, 6 | ) where 7 | 8 | import Data.ByteString (ByteString) 9 | import Data.String (IsString) 10 | import Network.HTTP.Types (hContentType, status200) 11 | import Network.Wai 12 | import Network.Wai.Test 13 | import Test.Hspec 14 | 15 | import Network.Wai.Middleware.ForceSSL (forceSSL) 16 | import Network.Wai.Middleware.Routed 17 | 18 | main :: IO () 19 | main = hspec spec 20 | 21 | spec :: Spec 22 | spec = describe "forceSSL" $ do 23 | it "routed middleware" $ do 24 | let destination = "https://example.com/d/" 25 | let routedSslJsonApp prefix = routedMiddleware (checkPrefix prefix) forceSSL jsonApp 26 | checkPrefix p (p1 : _) = p == p1 27 | checkPrefix _ _ = False 28 | 29 | flip runSession (routedSslJsonApp "r") $ do 30 | res <- testDPath "http" 31 | assertNoHeader location res 32 | assertStatus 200 res 33 | assertBody "{\"foo\":\"bar\"}" res 34 | 35 | flip runSession (routedSslJsonApp "d") $ do 36 | res2 <- testDPath "http" 37 | assertHeader location destination res2 38 | assertStatus 301 res2 39 | 40 | jsonApp :: Application 41 | jsonApp _req cps = 42 | cps $ 43 | responseLBS 44 | status200 45 | [(hContentType, "application/json")] 46 | "{\"foo\":\"bar\"}" 47 | 48 | testDPath :: ByteString -> Session SResponse 49 | testDPath proto = 50 | request $ 51 | flip 52 | setRawPathInfo 53 | "/d/" 54 | defaultRequest 55 | { requestHeaders = [("X-Forwarded-Proto", proto)] 56 | , requestHeaderHost = Just "example.com" 57 | } 58 | 59 | location :: IsString ci => ci 60 | location = "Location" 61 | -------------------------------------------------------------------------------- /warp-tls/warp-tls.cabal: -------------------------------------------------------------------------------- 1 | Name: warp-tls 2 | Version: 3.4.13 3 | Synopsis: HTTP over TLS support for Warp via the TLS package 4 | License: MIT 5 | License-file: LICENSE 6 | Author: Michael Snoyman 7 | Maintainer: michael@snoyman.com 8 | Homepage: http://github.com/yesodweb/wai 9 | Category: Web, Yesod 10 | Build-Type: Simple 11 | Cabal-Version: >= 1.10 12 | Stability: Stable 13 | description: SSLv1 and SSLv2 are obsoleted by IETF. 14 | We should use TLS 1.2 (or TLS 1.1 or TLS 1.0 if necessary). 15 | HTTP/2 can be negotiated by ALPN. 16 | API docs and the README are available at 17 | . 18 | extra-source-files: ChangeLog.md README.md 19 | 20 | Library 21 | Build-Depends: base >= 4.12 && < 5 22 | , bytestring >= 0.9 23 | , wai >= 3.2 && < 3.3 24 | , warp >= 3.3.29 && < 3.5 25 | , tls >= 2.1.3 && < 2.2 26 | , network >= 2.2.1 27 | , streaming-commons 28 | , tls-session-manager >= 0.0.4 29 | , recv >= 0.1.0 && < 0.2.0 30 | Exposed-modules: Network.Wai.Handler.WarpTLS 31 | Network.Wai.Handler.WarpTLS.Internal 32 | ghc-options: -Wall 33 | if os(windows) 34 | Cpp-Options: -DWINDOWS 35 | if impl(ghc >= 8) 36 | Default-Extensions: Strict StrictData 37 | Default-Language: Haskell2010 38 | 39 | 40 | source-repository head 41 | type: git 42 | location: git://github.com/yesodweb/wai.git 43 | -------------------------------------------------------------------------------- /warp/Network/Wai/Handler/Warp/Buffer.hs: -------------------------------------------------------------------------------- 1 | module Network.Wai.Handler.Warp.Buffer ( 2 | createWriteBuffer, 3 | allocateBuffer, 4 | freeBuffer, 5 | toBuilderBuffer, 6 | bufferIO, 7 | ) where 8 | 9 | import Data.IORef (IORef, readIORef) 10 | import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..)) 11 | import Foreign.ForeignPtr 12 | import Foreign.Marshal.Alloc (free, mallocBytes) 13 | import Foreign.Ptr (plusPtr) 14 | import Network.Socket.BufferPool 15 | 16 | import Network.Wai.Handler.Warp.Imports 17 | import Network.Wai.Handler.Warp.Types 18 | 19 | ---------------------------------------------------------------- 20 | 21 | -- | Allocate a buffer of the given size and wrap it in a 'WriteBuffer' 22 | -- containing that size and a finalizer. 23 | createWriteBuffer :: BufSize -> IO WriteBuffer 24 | createWriteBuffer size = do 25 | bytes <- allocateBuffer size 26 | return 27 | WriteBuffer 28 | { bufBuffer = bytes 29 | , bufSize = size 30 | , bufFree = freeBuffer bytes 31 | } 32 | 33 | ---------------------------------------------------------------- 34 | 35 | -- | Allocating a buffer with malloc(). 36 | allocateBuffer :: Int -> IO Buffer 37 | allocateBuffer = mallocBytes 38 | 39 | -- | Releasing a buffer with free(). 40 | freeBuffer :: Buffer -> IO () 41 | freeBuffer = free 42 | 43 | ---------------------------------------------------------------- 44 | -- 45 | -- Utilities 46 | -- 47 | 48 | toBuilderBuffer :: IORef WriteBuffer -> IO B.Buffer 49 | toBuilderBuffer writeBufferRef = do 50 | writeBuffer <- readIORef writeBufferRef 51 | let ptr = bufBuffer writeBuffer 52 | size = bufSize writeBuffer 53 | fptr <- newForeignPtr_ ptr 54 | return $ B.Buffer fptr ptr ptr (ptr `plusPtr` size) 55 | 56 | bufferIO :: Buffer -> Int -> (ByteString -> IO ()) -> IO () 57 | bufferIO ptr siz io = do 58 | fptr <- newForeignPtr_ ptr 59 | io $ PS fptr 0 siz 60 | -------------------------------------------------------------------------------- /wai/wai.cabal: -------------------------------------------------------------------------------- 1 | Cabal-Version: >=1.10 2 | Name: wai 3 | Version: 3.2.4 4 | Synopsis: Web Application Interface. 5 | Description: Provides a common protocol for communication between web applications and web servers. 6 | . 7 | API docs and the README are available at . 8 | License: MIT 9 | License-file: LICENSE 10 | Author: Michael Snoyman 11 | Maintainer: michael@snoyman.com 12 | Homepage: https://github.com/yesodweb/wai 13 | Category: Web 14 | Build-Type: Simple 15 | Stability: Stable 16 | extra-source-files: README.md ChangeLog.md 17 | 18 | Source-repository head 19 | type: git 20 | location: git://github.com/yesodweb/wai.git 21 | 22 | Library 23 | default-language: Haskell2010 24 | Build-Depends: base >= 4.12 && < 5 25 | , bytestring >= 0.10.4 26 | , network >= 2.2.1.5 27 | , http-types >= 0.7 28 | , text >= 0.7 29 | , vault >= 0.3 && < 0.4 30 | Exposed-modules: Network.Wai 31 | Network.Wai.Internal 32 | ghc-options: -Wall 33 | 34 | test-suite test 35 | default-language: Haskell2010 36 | hs-source-dirs: test 37 | main-is: Spec.hs 38 | type: exitcode-stdio-1.0 39 | ghc-options: -threaded -Wall 40 | cpp-options: -DTEST 41 | build-depends: base >= 4.8 && < 5 42 | , wai 43 | , hspec 44 | , bytestring 45 | other-modules: Network.WaiSpec 46 | build-tool-depends: hspec-discover:hspec-discover 47 | 48 | source-repository head 49 | type: git 50 | location: git://github.com/yesodweb/wai.git 51 | -------------------------------------------------------------------------------- /warp/test/ResponseHeaderSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module ResponseHeaderSpec (main, spec) where 4 | 5 | import Data.ByteString 6 | import qualified Network.HTTP.Types as H 7 | import Network.Wai.Handler.Warp.Header 8 | import Network.Wai.Handler.Warp.Response 9 | import Network.Wai.Handler.Warp.ResponseHeader 10 | import Test.Hspec 11 | 12 | main :: IO () 13 | main = hspec spec 14 | 15 | spec :: Spec 16 | spec = do 17 | describe "composeHeader" $ do 18 | it "composes a HTTP header" $ 19 | composeHeader H.http11 H.ok200 headers `shouldReturn` composedHeader 20 | describe "addServer" $ do 21 | it "adds Server if not exist" $ do 22 | let hdrs = [] 23 | rspidxhdr = indexResponseHeader hdrs 24 | addServer "MyServer" rspidxhdr hdrs `shouldBe` [("Server", "MyServer")] 25 | it "does not add Server if exists" $ do 26 | let hdrs = [("Server", "MyServer")] 27 | rspidxhdr = indexResponseHeader hdrs 28 | addServer "MyServer2" rspidxhdr hdrs `shouldBe` hdrs 29 | it "does not add Server if empty" $ do 30 | let hdrs = [] 31 | rspidxhdr = indexResponseHeader hdrs 32 | addServer "" rspidxhdr hdrs `shouldBe` hdrs 33 | it "deletes Server " $ do 34 | let hdrs = [("Server", "MyServer")] 35 | rspidxhdr = indexResponseHeader hdrs 36 | addServer "" rspidxhdr hdrs `shouldBe` [] 37 | 38 | headers :: H.ResponseHeaders 39 | headers = 40 | [ ("Date", "Mon, 13 Aug 2012 04:22:55 GMT") 41 | , ("Content-Length", "151") 42 | , ("Server", "Mighttpd/2.5.8") 43 | , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT") 44 | , ("Content-Type", "text/html") 45 | ] 46 | 47 | composedHeader :: ByteString 48 | composedHeader = 49 | "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Length: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n" 50 | -------------------------------------------------------------------------------- /warp/test/inputFile: -------------------------------------------------------------------------------- 1 | A acid 2 | abacus major 3 | abacus pythagoricus 4 | A battery 5 | abbey counter 6 | abbey laird 7 | abbey lands 8 | abbey lubber 9 | abbot cloth 10 | Abbott papyrus 11 | abb wool 12 | A-b-c book 13 | A-b-c method 14 | abdomino-uterotomy 15 | Abdul-baha 16 | a-be 17 | aberrant duct 18 | aberration constant 19 | abiding place 20 | able-bodied 21 | able-bodiedness 22 | able-minded 23 | able-mindedness 24 | able seaman 25 | aboli fruit 26 | A bond 27 | Abor-miri 28 | a-borning 29 | about-face 30 | about ship 31 | about-sledge 32 | above-cited 33 | above-found 34 | above-given 35 | above-mentioned 36 | above-named 37 | above-quoted 38 | above-reported 39 | above-said 40 | above-water 41 | above-written 42 | Abraham-man 43 | abraum salts 44 | abraxas stone 45 | Abri audit culture 46 | abruptly acuminate 47 | abruptly pinnate 48 | absciss layer 49 | absence state 50 | absentee voting 51 | absent-minded 52 | absent-mindedly 53 | absent-mindedness 54 | absent treatment 55 | absent voter 56 | Absent voting 57 | absinthe green 58 | absinthe oil 59 | absorption bands 60 | absorption circuit 61 | absorption coefficient 62 | absorption current 63 | absorption dynamometer 64 | absorption factor 65 | absorption lines 66 | absorption pipette 67 | absorption screen 68 | absorption spectrum 69 | absorption system 70 | A b station 71 | abstinence theory 72 | abstract group 73 | Abt system 74 | abundance declaree 75 | aburachan seed 76 | abutment arch 77 | abutment pier 78 | abutting joint 79 | acacia veld 80 | academy blue 81 | academy board 82 | academy figure 83 | acajou balsam 84 | acanthosis nigricans 85 | acanthus family 86 | acanthus leaf 87 | acaroid resin 88 | Acca larentia 89 | acceleration note 90 | accelerator nerve 91 | accent mark 92 | acceptance bill 93 | acceptance house 94 | acceptance supra protest 95 | acceptor supra protest 96 | accession book 97 | accession number 98 | accession service 99 | access road 100 | accident insurance 101 | -------------------------------------------------------------------------------- /warp/test/WithApplicationSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module WithApplicationSpec where 4 | 5 | import Control.Exception 6 | import Network.HTTP.Types 7 | import Network.Wai 8 | import System.Environment 9 | import System.Process 10 | import Test.Hspec 11 | 12 | import Network.Wai.Handler.Warp.WithApplication 13 | 14 | -- All these tests assume the "curl" process can be called directly. 15 | spec :: Spec 16 | spec = do 17 | runIO $ do 18 | unsetEnv "http_proxy" 19 | unsetEnv "https_proxy" 20 | describe "\"curl\" dependency" $ 21 | let msg = 22 | "All \"WithApplication\" tests assume the \"curl\" process can be called directly." 23 | underline = replicate (length msg) '^' 24 | in it (msg ++ "\n " ++ underline) True 25 | describe "withApplication" $ do 26 | it "runs a wai Application while executing the given action" $ do 27 | let mkApp = return $ \_request respond -> respond $ responseLBS ok200 [] "foo" 28 | withApplication mkApp $ \port -> do 29 | output <- readProcess "curl" ["-s", "localhost:" ++ show port] "" 30 | output `shouldBe` "foo" 31 | 32 | it "does not propagate exceptions from the server to the executing thread" $ do 33 | let mkApp = return $ \_request _respond -> throwIO $ ErrorCall "foo" 34 | withApplication mkApp $ \port -> do 35 | output <- readProcess "curl" ["-s", "localhost:" ++ show port] "" 36 | output `shouldContain` "Something went wron" 37 | 38 | describe "testWithApplication" $ do 39 | it "propagates exceptions from the server to the executing thread" $ do 40 | let mkApp = return $ \_request _respond -> throwIO $ ErrorCall "foo" 41 | testWithApplication 42 | mkApp 43 | ( \port -> do 44 | readProcess "curl" ["-s", "localhost:" ++ show port] "" 45 | ) 46 | `shouldThrow` (errorCall "foo") 47 | -------------------------------------------------------------------------------- /wai-extra/test/Network/Wai/Middleware/TimeoutSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Network.Wai.Middleware.TimeoutSpec ( 4 | spec, 5 | ) where 6 | 7 | import Control.Concurrent (threadDelay) 8 | import Network.HTTP.Types (status200, status503, status504) 9 | import Network.Wai 10 | import Test.Hspec 11 | 12 | import Network.Wai.Middleware.Timeout 13 | import Network.Wai.Test 14 | 15 | spec :: Spec 16 | spec = do 17 | describe "timeout" $ do 18 | it "times out slow requests with 503" $ do 19 | let app _req respond = do 20 | threadDelay $ 2 * 1000000 21 | respond $ responseLBS status200 [] "" 22 | 23 | resp <- runApp $ timeout 1 app 24 | 25 | simpleStatus resp `shouldBe` status503 26 | 27 | it "does not time out fast requests" $ do 28 | let app _req respond = respond $ responseLBS status200 [] "" 29 | 30 | resp <- runApp $ timeout 3 app 31 | 32 | simpleStatus resp `shouldBe` status200 33 | 34 | describe "timeoutStatus" $ do 35 | it "allows customizing the timeout response status" $ do 36 | let app _req respond = do 37 | threadDelay $ 2 * 1000000 38 | respond $ responseLBS status200 [] "" 39 | 40 | resp <- runApp $ timeoutStatus status504 1 app 41 | 42 | simpleStatus resp `shouldBe` status504 43 | 44 | describe "timeoutAs" $ do 45 | it "allows customizing the timeout response" $ do 46 | let app _req respond = do 47 | threadDelay $ 2 * 1000000 48 | respond $ responseLBS status200 [] "" 49 | timeoutResponse = responseLBS status503 [("X-Timeout", "1")] "" 50 | 51 | resp <- runApp $ timeoutAs timeoutResponse 1 app 52 | 53 | simpleStatus resp `shouldBe` status503 54 | simpleHeaders resp `shouldBe` [("X-Timeout", "1")] 55 | 56 | runApp :: Application -> IO SResponse 57 | runApp = runSession $ request defaultRequest 58 | -------------------------------------------------------------------------------- /wai-websockets/wai-websockets.cabal: -------------------------------------------------------------------------------- 1 | Name: wai-websockets 2 | Version: 3.0.1.3 3 | Synopsis: Provide a bridge between WAI and the websockets package. 4 | License: MIT 5 | License-file: LICENSE 6 | Author: Michael Snoyman, Jasper Van der Jeugt, Ting-Yen Lai 7 | Maintainer: michael@snoyman.com 8 | Homepage: http://github.com/yesodweb/wai 9 | Category: Web, Yesod 10 | Build-Type: Simple 11 | Cabal-Version: >=1.8 12 | Stability: Stable 13 | description: API docs and the README are available at . 14 | 15 | extra-source-files: static/client.js, static/client.html, static/screen.css 16 | README.md ChangeLog.md 17 | 18 | flag example 19 | 20 | Library 21 | Build-Depends: base >= 4.12 && < 5 22 | , bytestring >= 0.9.1.4 23 | , wai >= 3.0 && < 3.3 24 | , case-insensitive >= 0.2 25 | , transformers >= 0.2 26 | , websockets >= 0.9 27 | , http-types 28 | Exposed-modules: Network.Wai.Handler.WebSockets 29 | ghc-options: -Wall 30 | 31 | Executable wai-websockets-example 32 | if flag(example) 33 | buildable: True 34 | Build-Depends: base >= 3 && < 5 35 | , websockets 36 | , warp 37 | , wai 38 | , wai-app-static 39 | , bytestring 40 | , case-insensitive 41 | , transformers 42 | , text 43 | , file-embed 44 | , http-types 45 | other-modules: Network.Wai.Handler.WebSockets 46 | else 47 | buildable: False 48 | 49 | ghc-options: -Wall -threaded 50 | main-is: server.lhs 51 | 52 | source-repository head 53 | type: git 54 | location: git://github.com/yesodweb/wai.git 55 | -------------------------------------------------------------------------------- /wai-app-static/test/EmbeddedTestEntries.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module EmbeddedTestEntries where 6 | 7 | import qualified Data.ByteString.Lazy as BL 8 | import qualified Data.Text as T 9 | import qualified Data.Text.Lazy as TL 10 | import qualified Data.Text.Lazy.Encoding as TL 11 | import WaiAppStatic.Storage.Embedded 12 | 13 | body :: Int -> Char -> BL.ByteString 14 | body i c = TL.encodeUtf8 $ TL.pack $ replicate i c 15 | 16 | mkEntries :: IO [EmbeddableEntry] 17 | mkEntries = 18 | return 19 | -- An entry that should be compressed 20 | [ EmbeddableEntry 21 | "e1.txt" 22 | "text/plain" 23 | (Left ("Etag 1", body 1000 'A')) 24 | , -- An entry so short that the compressed text is longer 25 | EmbeddableEntry 26 | "e2.txt" 27 | "text/plain" 28 | (Left ("Etag 2", "ABC")) 29 | , -- An entry that is not compressed because of the mime 30 | EmbeddableEntry 31 | "somedir/e3.txt" 32 | "xxx" 33 | (Left ("Etag 3", body 1000 'A')) 34 | , -- A reloadable entry 35 | EmbeddableEntry 36 | "e4.css" 37 | "text/css" 38 | (Right [|return ("Etag 4" :: T.Text, body 2000 'Q')|]) 39 | , -- An entry without etag 40 | EmbeddableEntry 41 | "e5.txt" 42 | "text/plain" 43 | (Left ("", body 1000 'Z')) 44 | , -- A reloadable entry without etag 45 | EmbeddableEntry 46 | "e6.txt" 47 | "text/plain" 48 | (Right [|return ("" :: T.Text, body 1000 'W')|]) 49 | , -- An index file 50 | EmbeddableEntry 51 | "index.html" 52 | "text/html" 53 | (Right [|return ("" :: T.Text, "index file")|]) 54 | , -- An index file in a subdir 55 | EmbeddableEntry 56 | "foo/index.html" 57 | "text/html" 58 | (Right [|return ("" :: T.Text, "index file in subdir")|]) 59 | ] 60 | -------------------------------------------------------------------------------- /warp/test/ConduitSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module ConduitSpec (main, spec) where 4 | 5 | import Control.Monad (replicateM) 6 | import qualified Data.ByteString as S 7 | import Data.IORef as I 8 | import Network.Wai.Handler.Warp.Conduit 9 | import Network.Wai.Handler.Warp.Types 10 | import Test.Hspec 11 | 12 | main :: IO () 13 | main = hspec spec 14 | 15 | spec :: Spec 16 | spec = describe "conduit" $ do 17 | it "IsolatedBSSource" $ do 18 | ref <- newIORef $ map S.singleton [1 .. 50] 19 | src <- mkSource $ do 20 | x <- readIORef ref 21 | case x of 22 | [] -> return S.empty 23 | y : z -> do 24 | writeIORef ref z 25 | return y 26 | isrc <- mkISource src 40 27 | x <- replicateM 20 $ readISource isrc 28 | S.concat x `shouldBe` S.pack [1 .. 20] 29 | 30 | y <- replicateM 40 $ readISource isrc 31 | S.concat y `shouldBe` S.pack [21 .. 40] 32 | 33 | z <- replicateM 40 $ readSource src 34 | S.concat z `shouldBe` S.pack [41 .. 50] 35 | it "chunkedSource" $ do 36 | ref <- newIORef "5\r\n12345\r\n3\r\n678\r\n0\r\n\r\nBLAH" 37 | src <- mkSource $ do 38 | x <- readIORef ref 39 | writeIORef ref S.empty 40 | return x 41 | csrc <- mkCSource src 42 | 43 | x <- replicateM 15 $ readCSource csrc 44 | S.concat x `shouldBe` "12345678" 45 | 46 | y <- replicateM 15 $ readSource src 47 | S.concat y `shouldBe` "BLAH" 48 | it "chunk boundaries" $ do 49 | ref <- 50 | newIORef 51 | [ "5\r\n" 52 | , "12345\r\n3\r" 53 | , "\n678\r\n0\r\n" 54 | , "\r\nBLAH" 55 | ] 56 | src <- mkSource $ do 57 | x <- readIORef ref 58 | case x of 59 | [] -> return S.empty 60 | y : z -> do 61 | writeIORef ref z 62 | return y 63 | csrc <- mkCSource src 64 | 65 | x <- replicateM 15 $ readCSource csrc 66 | S.concat x `shouldBe` "12345678" 67 | 68 | y <- replicateM 15 $ readSource src 69 | S.concat y `shouldBe` "BLAH" 70 | -------------------------------------------------------------------------------- /auto-update/Control/Debounce.hs: -------------------------------------------------------------------------------- 1 | -- | Debounce an action, ensuring it doesn't occur more than once for a given 2 | -- period of time. 3 | -- 4 | -- This is useful as an optimization, for example to ensure that logs are only 5 | -- flushed to disk at most once per second. 6 | -- 7 | -- Example usage: 8 | -- 9 | -- @ 10 | -- > printString <- 'mkDebounce' 'defaultDebounceSettings' 11 | -- { 'debounceAction' = putStrLn "Running action" 12 | -- , 'debounceFreq' = 5000000 -- 5 seconds 13 | -- , 'debounceEdge' = 'DI.trailingEdge' -- Trigger on the trailing edge 14 | -- } 15 | -- > printString 16 | -- Running action 17 | -- > printString 18 | -- \ 19 | -- Running action 20 | -- @ 21 | -- 22 | -- See the fast-logger package ("System.Log.FastLogger") for real-world usage. 23 | -- 24 | -- @since 0.1.2 25 | module Control.Debounce ( 26 | -- * Creation 27 | mkDebounce, 28 | 29 | -- * Settings 30 | DI.DebounceSettings, 31 | defaultDebounceSettings, 32 | 33 | -- ** Accessors 34 | DI.debounceFreq, 35 | DI.debounceAction, 36 | DI.debounceEdge, 37 | DI.debounceThreadName, 38 | 39 | -- ** Edge types 40 | DI.leadingEdge, 41 | DI.leadingMuteEdge, 42 | DI.trailingEdge, 43 | DI.trailingDelayEdge, 44 | ) where 45 | 46 | import Control.Concurrent (newMVar, threadDelay) 47 | import qualified Control.Debounce.Internal as DI 48 | 49 | -- | Default value for creating a 'DebounceSettings'. 50 | -- 51 | -- @since 0.1.2 52 | defaultDebounceSettings :: DI.DebounceSettings 53 | defaultDebounceSettings = 54 | DI.DebounceSettings 55 | { DI.debounceFreq = 1000000 56 | , DI.debounceAction = return () 57 | , DI.debounceEdge = DI.leadingEdge 58 | , DI.debounceThreadName = "Debounce" 59 | } 60 | 61 | -- | Generate an action which will trigger the debounced action to be performed. 62 | -- 63 | -- /N.B. The generated action will always immediately return, regardless of the 'debounceFreq',/ 64 | -- /as the debounced action (and the delay\/cooldown) is always performed in a separate thread./ 65 | -- 66 | -- @since 0.1.2 67 | mkDebounce :: DI.DebounceSettings -> IO (IO ()) 68 | mkDebounce settings = do 69 | baton <- newMVar () 70 | DI.mkDebounceInternal baton threadDelay settings 71 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | stack: 3 | - path: "./auto-update/Control" 4 | component: "auto-update:lib" 5 | - path: "./auto-update/test" 6 | component: "auto-update:test:spec" 7 | 8 | - path: "./mime-types/Network" 9 | component: "mime-types:lib" 10 | 11 | - path: "./time-manager/System" 12 | component: "time-manager:lib" 13 | 14 | - path: "./wai/Network" 15 | component: "wai:lib" 16 | - path: "./wai/test" 17 | component: "wai:test:test" 18 | 19 | - path: "./wai-app-static/Network" 20 | component: "wai-app-static:lib" 21 | - path: "./wai-app-static/WaiAppStatic" 22 | component: "wai-app-static:lib" 23 | - path: "./wai-app-static/test" 24 | component: "wai-app-static:test:runtests" 25 | - path: "./wai-app-static/test.hs" 26 | component: "wai-app-static:test:runtests" 27 | - path: "./wai-app-static/app" 28 | component: "wai-app-static:exe:warp" 29 | 30 | - path: "./wai-conduit/Network" 31 | component: "wai-conduit:lib" 32 | 33 | - path: "./wai-extra/Network" 34 | component: "wai-extra:lib" 35 | - path: "./wai-extra/test" 36 | component: "wai-extra:test:spec" 37 | - path: "./wai-extra/example" 38 | component: "wai-extra:exe:example" 39 | 40 | - path: "./wai-frontend-monadcgi/Network" 41 | component: "wai-frontend-monadcgi:lib" 42 | 43 | - path: "./wai-http2-extra/Network" 44 | component: "wai-http2-extra:lib" 45 | - path: "./wai-http2-extra/test" 46 | component: "wai-http2-extra:test:doctest" 47 | 48 | - path: "./wai-websockets/Network" 49 | component: "wai-websockets:lib" 50 | # HLS can't do Literate Haskell 51 | # - path: "./wai-websockets/server.lhs" 52 | # component: "wai-websockets:exe:wai-websockets-example" 53 | 54 | - path: "./warp/Network" 55 | component: "warp:lib" 56 | - path: "./warp/test/doctests.hs" 57 | component: "warp:test:doctest" 58 | - path: "./warp/test" 59 | component: "warp:test:spec" 60 | - path: "./warp/bench" 61 | component: "warp:bench:parser" 62 | 63 | # Not yet buildable (needs http3 which isn't on hackage) 64 | # - path: "./warp-quic/Network" 65 | # component: "warp-quic:lib" 66 | 67 | - path: "./warp-tls/Network" 68 | component: "warp-tls:lib" 69 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/EventSource/EventStream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | {- code adapted by Mathias Billman originally from Chris Smith https://github.com/cdsmith/gloss-web -} 4 | 5 | -- | 6 | -- Internal module, usually you don't need to use it. 7 | module Network.Wai.EventSource.EventStream ( 8 | ServerEvent (..), 9 | eventToBuilder, 10 | ) where 11 | 12 | import Data.ByteString.Builder 13 | #if __GLASGOW_HASKELL__ < 710 14 | import Data.Monoid 15 | #endif 16 | import Data.Word8 (_colon, _lf) 17 | 18 | -- | 19 | -- Type representing a communication over an event stream. This can be an 20 | -- actual event, a comment, a modification to the retry timer, or a special 21 | -- "close" event indicating the server should close the connection. 22 | data ServerEvent 23 | = ServerEvent 24 | { eventName :: Maybe Builder 25 | , eventId :: Maybe Builder 26 | , eventData :: [Builder] 27 | } 28 | | CommentEvent 29 | { eventComment :: Builder 30 | } 31 | | RetryEvent 32 | { eventRetry :: Int 33 | } 34 | | CloseEvent 35 | 36 | -- | 37 | -- Newline as a Builder. 38 | nl :: Builder 39 | nl = word8 _lf 40 | 41 | -- | 42 | -- Field names as Builder 43 | nameField, idField, dataField, retryField, commentField :: Builder 44 | nameField = string7 "event:" 45 | idField = string7 "id:" 46 | dataField = string7 "data:" 47 | retryField = string7 "retry:" 48 | commentField = word8 _colon 49 | 50 | -- | 51 | -- Wraps the text as a labeled field of an event stream. 52 | field :: Builder -> Builder -> Builder 53 | field l b = l `mappend` b `mappend` nl 54 | 55 | -- | 56 | -- Converts a 'ServerEvent' to its wire representation as specified by the 57 | -- @text/event-stream@ content type. 58 | eventToBuilder :: ServerEvent -> Maybe Builder 59 | eventToBuilder (CommentEvent txt) = Just $ field commentField txt 60 | eventToBuilder (RetryEvent n) = Just $ field retryField (string8 . show $ n) 61 | eventToBuilder CloseEvent = Nothing 62 | eventToBuilder (ServerEvent n i d) = 63 | Just $ 64 | name n (evid i $ mconcat (map (field dataField) d)) `mappend` nl 65 | where 66 | name Nothing = id 67 | name (Just n') = mappend (field nameField n') 68 | evid Nothing = id 69 | evid (Just i') = mappend (field idField i') 70 | -------------------------------------------------------------------------------- /auto-update/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # ChangeLog for auto-update 2 | 3 | ## 0.2.6.1 4 | 5 | * Fixed documentation of when `leadingMuteEdge` and `trailingDelayEdge` were 6 | introduced in `Control.Debounce`. 7 | 8 | ## 0.2.6 9 | 10 | * Using the thread version of AutoUpdate for non-threaded RTS. 11 | [#1020](https://github.com/yesodweb/wai/pull/1020) 12 | 13 | ## 0.2.5 14 | 15 | * Thread less autoupdate 16 | [#1018](https://github.com/yesodweb/wai/pull/1018) 17 | 18 | ## 0.2.4 19 | 20 | * Simple refactoring. 21 | 22 | ## 0.2.3 23 | 24 | * [#996](https://github.com/yesodweb/wai/pull/996): 25 | Refactored the `Control.Debounce` logic to not leak threads. 26 | * [#996](https://github.com/yesodweb/wai/pull/996): 27 | Added extra `DebounceEdge` options for different types of debouncing. 28 | * `LeadingMute`: Action on first trigger, and ignore any triggers during cooldown 29 | * `TrailingDelay`: First trigger starts cooldown, and 30 | triggers during cooldown extend the cooldown. Action when cooldown expires. 31 | 32 | ## 0.2.2 33 | 34 | * NewAPI: updateThreadName, reaperThreadName, debounceThreadName: 35 | Names can be given via this field to threads 36 | for GHC.Conc.Sync.listThreads. 37 | 38 | ## 0.2.1 39 | 40 | * Labeling threads. 41 | 42 | ## 0.2.0 43 | 44 | * Creating Reaper.Internal to export Reaper constructor. 45 | * Hiding Reaper constructor. 46 | * [#985](https://github.com/yesodweb/wai/pull/985): 47 | Add `reaperModify` to the `Reaper` API, allowing workload modification outside 48 | of the main `reaperAction` loop. 49 | 50 | ## 0.1.6 51 | 52 | * [#756](https://github.com/yesodweb/wai/pull/756): 53 | Add control of activation on leading vs. trailing edges for Control.Debounce 54 | 55 | ## 0.1.5 56 | 57 | * [#752](https://github.com/yesodweb/wai/pull/752): 58 | Using the Strict and StrictData language extensions for GHC >8. 59 | 60 | ## 0.1.4.1 61 | 62 | * [#693](https://github.com/yesodweb/wai/pull/693): 63 | Improve documentation for `reaperAction` function. 64 | * [#732](https://github.com/yesodweb/wai/pull/732): 65 | Fixed memory leak in `reaperAdd` function. 66 | 67 | ## 0.1.4 68 | 69 | * Provide updateActionModify API in AutoUpdate [#547](https://github.com/yesodweb/wai/pull/547) 70 | 71 | ## 0.1.3.1 72 | 73 | * Doc improvements 74 | 75 | ## 0.1.3 76 | 77 | * Adding a new AIP - reaperKill 78 | 79 | ## 0.1.2 80 | 81 | * Added Control.Debounce 82 | -------------------------------------------------------------------------------- /wai-extra/Network/Wai/EventSource.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- A WAI adapter to the HTML5 Server-Sent Events API. 3 | -- 4 | -- If running through a proxy like Nginx you might need to add the 5 | -- headers: 6 | -- 7 | -- > [ ("X-Accel-Buffering", "no"), ("Cache-Control", "no-cache")] 8 | -- 9 | -- There is a small example using these functions in the @example@ directory. 10 | module Network.Wai.EventSource ( 11 | ServerEvent (..), 12 | eventSourceAppChan, 13 | eventSourceAppIO, 14 | eventStreamAppRaw, 15 | ) where 16 | 17 | import Control.Concurrent.Chan (Chan, dupChan, readChan) 18 | import Control.Monad.IO.Class (liftIO) 19 | import Data.Function (fix) 20 | import Network.HTTP.Types (hContentType, status200) 21 | import Network.Wai (Application, responseStream) 22 | 23 | import Network.Wai.EventSource.EventStream 24 | 25 | -- | Make a new WAI EventSource application reading events from 26 | -- the given channel. 27 | eventSourceAppChan :: Chan ServerEvent -> Application 28 | eventSourceAppChan chan req sendResponse = do 29 | chan' <- liftIO $ dupChan chan 30 | eventSourceAppIO (readChan chan') req sendResponse 31 | 32 | -- | Make a new WAI EventSource application reading events from 33 | -- the given IO action. 34 | eventSourceAppIO :: IO ServerEvent -> Application 35 | eventSourceAppIO src _ sendResponse = 36 | sendResponse 37 | $ responseStream 38 | status200 39 | [(hContentType, "text/event-stream")] 40 | $ \sendChunk flush -> do 41 | flush 42 | fix $ \loop -> do 43 | se <- src 44 | case eventToBuilder se of 45 | Nothing -> return () 46 | Just b -> sendChunk b >> flush >> loop 47 | 48 | -- | Make a new WAI EventSource application with a handler that emits events. 49 | -- 50 | -- @since 3.0.28 51 | eventStreamAppRaw :: ((ServerEvent -> IO ()) -> IO () -> IO ()) -> Application 52 | eventStreamAppRaw handler _ sendResponse = 53 | sendResponse 54 | $ responseStream 55 | status200 56 | [(hContentType, "text/event-stream")] 57 | $ \sendChunk flush -> handler (sendEvent sendChunk) flush 58 | where 59 | sendEvent sendChunk event = 60 | case eventToBuilder event of 61 | Nothing -> return () 62 | Just b -> sendChunk b 63 | 64 | {- HLint ignore eventStreamAppRaw "Use forM_" -} 65 | -------------------------------------------------------------------------------- /wai-extra/test/Network/Wai/Middleware/ForceSSLSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Network.Wai.Middleware.ForceSSLSpec ( 5 | main, 6 | spec, 7 | ) where 8 | 9 | import Control.Monad (forM_) 10 | import Data.ByteString (ByteString) 11 | #if __GLASGOW_HASKELL__ < 804 12 | import Data.Monoid ((<>)) 13 | #endif 14 | import Network.HTTP.Types (methodPost, status200, status301, status307) 15 | import Network.Wai 16 | import Test.Hspec 17 | 18 | import Network.Wai.Middleware.ForceSSL (forceSSL) 19 | import Network.Wai.Test 20 | 21 | main :: IO () 22 | main = hspec spec 23 | 24 | spec :: Spec 25 | spec = describe "forceSSL" (forM_ hosts $ \host -> hostSpec host) 26 | where 27 | hosts = ["example.com", "example.com:80", "example.com:8080"] 28 | 29 | hostSpec :: ByteString -> Spec 30 | hostSpec host = describe ("forceSSL on host " <> show host <> "") $ do 31 | it "redirects non-https requests to https" $ do 32 | resp <- runApp host forceSSL defaultRequest 33 | 34 | simpleStatus resp `shouldBe` status301 35 | simpleHeaders resp `shouldBe` [("Location", "https://" <> host)] 36 | 37 | it "redirects with 307 in the case of a non-GET request" $ do 38 | resp <- 39 | runApp 40 | host 41 | forceSSL 42 | defaultRequest 43 | { requestMethod = methodPost 44 | } 45 | 46 | simpleStatus resp `shouldBe` status307 47 | simpleHeaders resp `shouldBe` [("Location", "https://" <> host)] 48 | 49 | it "does not redirect already-secure requests" $ do 50 | resp <- runApp host forceSSL defaultRequest{isSecure = True} 51 | 52 | simpleStatus resp `shouldBe` status200 53 | 54 | it "preserves the original host, path, and query string" $ do 55 | resp <- 56 | runApp 57 | host 58 | forceSSL 59 | defaultRequest 60 | { rawPathInfo = "/foo/bar" 61 | , rawQueryString = "?baz=bat" 62 | } 63 | 64 | simpleHeaders resp 65 | `shouldBe` [("Location", "https://" <> host <> "/foo/bar?baz=bat")] 66 | 67 | runApp :: ByteString -> Middleware -> Request -> IO SResponse 68 | runApp host mw req = 69 | runSession 70 | (request req{requestHeaderHost = Just host}) 71 | $ mw app 72 | where 73 | app _ respond = respond $ responseLBS status200 [] "" 74 | -------------------------------------------------------------------------------- /wai-http2-extra/Network/Wai/Middleware/Push/Referer/LRU.hs: -------------------------------------------------------------------------------- 1 | -- from https://jaspervdj.be/posts/2015-02-24-lru-cache.html 2 | module Network.Wai.Middleware.Push.Referer.LRU ( 3 | Cache (..), 4 | Priority, 5 | empty, 6 | insert, 7 | lookup, 8 | ) where 9 | 10 | import Data.Int (Int64) 11 | import Data.OrdPSQ (OrdPSQ) 12 | import qualified Data.OrdPSQ as PSQ 13 | import Prelude hiding (lookup) 14 | 15 | import Network.Wai.Middleware.Push.Referer.Multi (Multi) 16 | import qualified Network.Wai.Middleware.Push.Referer.Multi as M 17 | 18 | type Priority = Int64 19 | 20 | data Cache k v = Cache 21 | { cCapacity :: Int 22 | -- ^ The maximum number of elements in the queue 23 | , cSize :: Int 24 | -- ^ The current number of elements in the queue 25 | , cValLimit :: Int 26 | , cTick :: Priority 27 | -- ^ The next logical time 28 | , cQueue :: OrdPSQ k Priority (Multi v) 29 | } 30 | deriving (Eq, Show) 31 | 32 | empty :: Int -> Int -> Cache k v 33 | empty capacity valLimit 34 | | capacity < 1 = error "Cache.empty: capacity < 1" 35 | | otherwise = 36 | Cache 37 | { cCapacity = capacity 38 | , cSize = 0 39 | , cValLimit = valLimit 40 | , cTick = 0 41 | , cQueue = PSQ.empty 42 | } 43 | 44 | trim :: Ord k => Cache k v -> Cache k v 45 | trim c 46 | | cTick c == maxBound = empty (cCapacity c) (cValLimit c) 47 | | cSize c > cCapacity c = 48 | c 49 | { cSize = cSize c - 1 50 | , cQueue = PSQ.deleteMin (cQueue c) 51 | } 52 | | otherwise = c 53 | 54 | insert :: (Ord k, Ord v) => k -> v -> Cache k v -> Cache k v 55 | insert k v c = case PSQ.alter lookupAndBump k (cQueue c) of 56 | (True, q) -> trim $ c{cTick = cTick c + 1, cQueue = q, cSize = cSize c + 1} 57 | (False, q) -> trim $ c{cTick = cTick c + 1, cQueue = q} 58 | where 59 | lookupAndBump Nothing = (True, Just (cTick c, M.singleton (cValLimit c) v)) 60 | lookupAndBump (Just (_, x)) = (False, Just (cTick c, M.insert v x)) 61 | 62 | lookup :: Ord k => k -> Cache k v -> (Cache k v, [v]) 63 | lookup k c = case PSQ.alter lookupAndBump k (cQueue c) of 64 | (Nothing, _) -> (c, []) 65 | (Just x, q) -> 66 | let c' = trim $ c{cTick = cTick c + 1, cQueue = q} 67 | xs = M.list x 68 | in (c', xs) 69 | where 70 | lookupAndBump Nothing = (Nothing, Nothing) 71 | lookupAndBump (Just (_, x)) = (Just x, Just (cTick c, x)) 72 | -------------------------------------------------------------------------------- /wai-conduit/Network/Wai/Conduit.hs: -------------------------------------------------------------------------------- 1 | -- | A light-weight wrapper around @Network.Wai@ to provide easy conduit support. 2 | module Network.Wai.Conduit ( 3 | -- * Request body 4 | sourceRequestBody, 5 | 6 | -- * Response body 7 | responseSource, 8 | responseRawSource, 9 | 10 | -- * Re-export 11 | module Network.Wai, 12 | ) where 13 | 14 | import Control.Monad (unless) 15 | import Control.Monad.IO.Class (MonadIO, liftIO) 16 | import Data.ByteString (ByteString) 17 | import qualified Data.ByteString as S 18 | import Data.ByteString.Builder (Builder) 19 | import Data.Conduit 20 | import qualified Data.Conduit.List as CL 21 | import Network.HTTP.Types 22 | import Network.Wai 23 | 24 | -- | Stream the request body. 25 | -- 26 | -- Since 3.0.0 27 | sourceRequestBody :: MonadIO m => Request -> ConduitT () ByteString m () 28 | sourceRequestBody req = 29 | loop 30 | where 31 | go = liftIO (getRequestBodyChunk req) 32 | 33 | loop = do 34 | bs <- go 35 | unless (S.null bs) $ do 36 | yield bs 37 | loop 38 | 39 | -- | Create an HTTP response out of a @Source@. 40 | -- 41 | -- Since 3.0.0 42 | responseSource 43 | :: Status -> ResponseHeaders -> ConduitT () (Flush Builder) IO () -> Response 44 | responseSource s hs src = responseStream s hs $ \send flush -> 45 | runConduit $ 46 | src 47 | .| CL.mapM_ 48 | ( \mbuilder -> 49 | case mbuilder of 50 | Chunk b -> send b 51 | Flush -> flush 52 | ) 53 | 54 | -- | Create a raw response using @Source@ and @Sink@ conduits. 55 | -- 56 | -- This is an adapter to Wai's @responseRaw@ for conduits. 57 | -- 58 | -- @Source@ and @Sink@ data are provided. The @Source@ is a byte conduit from 59 | -- the client's socket. The @Sink@ is a byte conduit to the client's socket. 60 | -- 61 | -- The @Response@ argument is a backup response. It is sent to the client if 62 | -- the handler does not support @responseRaw@. 63 | -- 64 | -- Since 3.0.0 65 | responseRawSource 66 | :: (MonadIO m, MonadIO n) 67 | => (ConduitT () ByteString m () -> ConduitT ByteString Void n () -> IO ()) 68 | -> Response 69 | -> Response 70 | responseRawSource app = 71 | responseRaw app' 72 | where 73 | app' recv send = 74 | app src sink 75 | where 76 | src = do 77 | bs <- liftIO recv 78 | unless (S.null bs) $ do 79 | yield bs 80 | src 81 | sink = CL.mapM_ $ liftIO . send 82 | -------------------------------------------------------------------------------- /warp/test/ExceptionSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module ExceptionSpec (main, spec) where 5 | 6 | #if __GLASGOW_HASKELL__ < 709 7 | import Control.Applicative 8 | #endif 9 | import Control.Concurrent.Async (withAsync) 10 | import Control.Exception 11 | import Control.Monad 12 | import qualified Data.Streaming.Network as N 13 | import Network.HTTP.Types hiding (Header) 14 | import Network.Socket (close) 15 | import Network.Wai hiding (Response, responseStatus) 16 | import Network.Wai.Handler.Warp 17 | import Network.Wai.Internal (Request (..)) 18 | import Test.Hspec 19 | 20 | import HTTP 21 | 22 | main :: IO () 23 | main = hspec spec 24 | 25 | withTestServer :: (Int -> IO a) -> IO a 26 | withTestServer inner = bracket 27 | (N.bindRandomPortTCP "127.0.0.1") 28 | (close . snd) 29 | $ \(prt, lsocket) -> do 30 | withAsync (runSettingsSocket defaultSettings lsocket testApp) $ 31 | \_ -> inner prt 32 | 33 | testApp :: Application 34 | testApp (Network.Wai.Internal.Request{pathInfo = [x]}) f 35 | | x == "statusError" = 36 | f $ responseLBS undefined [] "foo" 37 | | x == "headersError" = 38 | f $ responseLBS ok200 undefined "foo" 39 | | x == "headerError" = 40 | f $ responseLBS ok200 [undefined] "foo" 41 | | x == "bodyError" = 42 | f $ responseLBS ok200 [] undefined 43 | | x == "ioException" = do 44 | void $ fail "ioException" 45 | f $ responseLBS ok200 [] "foo" 46 | testApp _ f = 47 | f $ responseLBS ok200 [] "foo" 48 | 49 | spec :: Spec 50 | spec = describe "responds even if there is an exception" $ do 51 | {- Disabling these tests. We can consider forcing evaluation in Warp. 52 | it "statusError" $ do 53 | sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/statusError" 54 | sc `shouldBe` internalServerError500 55 | it "headersError" $ do 56 | sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headersError" 57 | sc `shouldBe` internalServerError500 58 | it "headerError" $ do 59 | sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headerError" 60 | sc `shouldBe` internalServerError500 61 | it "bodyError" $ do 62 | sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/bodyError" 63 | sc `shouldBe` internalServerError500 64 | -} 65 | it "ioException" $ withTestServer $ \prt -> do 66 | sc <- 67 | responseStatus <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException") 68 | sc `shouldBe` internalServerError500 69 | -------------------------------------------------------------------------------- /auto-update/Control/AutoUpdate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | In a multithreaded environment, sharing results of actions can dramatically improve performance. 4 | -- For example, web servers need to return the current time with each HTTP response. 5 | -- For a high-volume server, it's much faster for a dedicated thread to run every 6 | -- second, and write the current time to a shared 'IORef', than it is for each 7 | -- request to make its own call to 'getCurrentTime'. 8 | -- 9 | -- But for a low-volume server, whose request frequency is less than once per 10 | -- second, that approach will result in /more/ calls to 'getCurrentTime' than 11 | -- necessary, and worse, kills idle GC. 12 | -- 13 | -- This library solves that problem by allowing you to define actions which will 14 | -- either be performed by a dedicated thread, or, in times of low volume, will 15 | -- be executed by the calling thread. 16 | -- 17 | -- Example usage: 18 | -- 19 | -- @ 20 | -- import "Data.Time" 21 | -- import "Control.AutoUpdate" 22 | -- 23 | -- getTime <- 'mkAutoUpdate' 'defaultUpdateSettings' 24 | -- { 'updateAction' = 'Data.Time.Clock.getCurrentTime' 25 | -- , 'updateFreq' = 1000000 -- The default frequency, once per second 26 | -- } 27 | -- currentTime <- getTime 28 | -- @ 29 | -- 30 | -- For more examples, . 31 | module Control.AutoUpdate ( 32 | -- * Type 33 | UpdateSettings, 34 | defaultUpdateSettings, 35 | 36 | -- * Accessors 37 | updateAction, 38 | updateFreq, 39 | updateSpawnThreshold, 40 | updateThreadName, 41 | 42 | -- * Creation 43 | mkAutoUpdate, 44 | mkAutoUpdateWithModify, 45 | ) 46 | where 47 | 48 | import Control.AutoUpdate.Types 49 | #ifdef mingw32_HOST_OS 50 | import Control.AutoUpdate.Thread 51 | #else 52 | import qualified Control.AutoUpdate.Event as Event 53 | import qualified Control.AutoUpdate.Thread as Thread 54 | 55 | import GHC.Event 56 | 57 | mkAutoUpdate :: UpdateSettings a -> IO (IO a) 58 | mkAutoUpdate settings = do 59 | mmgr <- getSystemEventManager 60 | case mmgr of 61 | Nothing -> Thread.mkAutoUpdate settings 62 | Just _m -> Event.mkAutoUpdate settings 63 | 64 | mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a) 65 | mkAutoUpdateWithModify settings f = do 66 | mmgr <- getSystemEventManager 67 | case mmgr of 68 | Nothing -> Thread.mkAutoUpdateWithModify settings f 69 | Just _m -> Event.mkAutoUpdateWithModify settings f 70 | #endif 71 | -------------------------------------------------------------------------------- /wai/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # ChangeLog for wai 2 | 3 | ## 3.2.4 4 | 5 | * Add helpers for modifying request headers: `modifyRequest` and `mapRequestHeaders`. [#710](https://github.com/yesodweb/wai/pull/710) [#952](https://github.com/yesodweb/wai/pull/952) 6 | * Small documentation adjustments like adding more `@since` markers. [#952](https://github.com/yesodweb/wai/pull/952) 7 | * Add `setRequestBodyChunks` to mirror `getRequestBodyChunk` and avoid deprecation warnings when using `requestBody` as a setter. [#949](https://github.com/yesodweb/wai/pull/949) 8 | * Overhaul documentation of `Middleware`. [#858](https://github.com/yesodweb/wai/pull/858) 9 | 10 | ## 3.2.3 11 | 12 | * Add documentation recommending streaming request bodies. [#818](https://github.com/yesodweb/wai/pull/818) 13 | * Add two functions, `consumeRequestBodyStrict` and `consumeRequestBodyLazy`, 14 | that are synonyms for `strictRequestBody` and `lazyRequestBody`. [#818](https://github.com/yesodweb/wai/pull/818) 15 | 16 | ## 3.2.2.1 17 | 18 | * Fix missing reexport of `getRequestBodyChunk` [#753](https://github.com/yesodweb/wai/issues/753) 19 | 20 | ## 3.2.2 21 | 22 | * Deprecate `requestBody` in favor of the more clearly named `getRequestBodyChunk`. [#726](https://github.com/yesodweb/wai/pull/726) 23 | 24 | ## 3.2.1.2 25 | 26 | * Remove dependency on blaze-builder [#683](https://github.com/yesodweb/wai/pull/683) 27 | 28 | ## 3.2.1.1 29 | 30 | * Relax upper bound on bytestring-builder 31 | 32 | ## 3.2.1 33 | 34 | * add mapResponseStatus [#532](https://github.com/yesodweb/wai/pull/532) 35 | 36 | ## 3.2.0.1 37 | 38 | * Add missing changelog entry 39 | 40 | ## 3.2.0 41 | 42 | * Major version up due to breaking changes. We chose 3.2.0, not 3.1.0 43 | for consistency with Warp 3.2.0. 44 | * The `Network.Wai.HTTP2` module was removed. 45 | * `tryGetFileSize`, `hContentRange`, `hAcceptRanges`, `contentRangeHeader` and 46 | `chooseFilePart`, `adjustForFilePart` and `parseByteRanges` were removed 47 | from the `Network.Wai.Internal` module. 48 | * New fields for `Request`: `requestHeaderReferer` and `requestHeaderUserAgent`. 49 | 50 | ## 3.0.5.0 51 | 52 | * Avoid using the `IsString` Builder instance 53 | 54 | ## 3.0.4.0 55 | 56 | * A new module `Network.Wai.HTTP2` is exported. 57 | 58 | ## 3.0.3.0 59 | 60 | * `mapResponseHeaders`, `ifRequest` and `modifyResponse` are exported. 61 | 62 | ## 3.0.2.3 63 | 64 | * Allow blaze-builder 0.4 65 | 66 | ## 3.0.2.2 67 | 68 | * Clarify some documentation on `rawPathInfo`. [Relevant Github 69 | discussion](https://github.com/yesodweb/wai/issues/325#issuecomment-69896780). 70 | -------------------------------------------------------------------------------- /warp/Network/Wai/Handler/Warp/HTTP2/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Network.Wai.Handler.Warp.HTTP2.Types where 5 | 6 | import qualified Data.ByteString as BS 7 | import qualified Network.HTTP.Types as H 8 | import Network.HTTP2.Frame 9 | import qualified Network.HTTP2.Server as H2 10 | 11 | import Network.Wai.Handler.Warp.Imports 12 | import Network.Wai.Handler.Warp.Types 13 | 14 | ---------------------------------------------------------------- 15 | 16 | isHTTP2 :: Transport -> Bool 17 | isHTTP2 TCP = False 18 | isHTTP2 tls = useHTTP2 19 | where 20 | useHTTP2 = case tlsNegotiatedProtocol tls of 21 | Nothing -> False 22 | Just proto -> "h2" `BS.isPrefixOf` proto 23 | 24 | ---------------------------------------------------------------- 25 | 26 | -- | HTTP/2 specific data. 27 | -- 28 | -- Since: 3.2.7 29 | data HTTP2Data = HTTP2Data 30 | { http2dataPushPromise :: [PushPromise] 31 | -- ^ Accessor for 'PushPromise' in 'HTTP2Data'. 32 | -- 33 | -- Since: 3.2.7 34 | , http2dataTrailers :: H2.TrailersMaker 35 | -- ^ Accessor for 'H2.TrailersMaker' in 'HTTP2Data'. 36 | -- 37 | -- Since: 3.2.8 but the type changed in 3.3.0 38 | } 39 | 40 | -- | Default HTTP/2 specific data. 41 | -- 42 | -- Since: 3.2.7 43 | defaultHTTP2Data :: HTTP2Data 44 | defaultHTTP2Data = HTTP2Data [] H2.defaultTrailersMaker 45 | 46 | -- | HTTP/2 push promise or sever push. 47 | -- This allows files only for backward-compatibility 48 | -- while the HTTP/2 library supports other types. 49 | -- 50 | -- Since: 3.2.7 51 | data PushPromise = PushPromise 52 | { promisedPath :: ByteString 53 | -- ^ Accessor for a URL path in 'PushPromise'. 54 | -- E.g. \"\/style\/default.css\". 55 | -- 56 | -- Since: 3.2.7 57 | , promisedFile :: FilePath 58 | -- ^ Accessor for 'FilePath' in 'PushPromise'. 59 | -- E.g. \"FILE_PATH/default.css\". 60 | -- 61 | -- Since: 3.2.7 62 | , promisedResponseHeaders :: H.ResponseHeaders 63 | -- ^ Accessor for 'H.ResponseHeaders' in 'PushPromise' 64 | -- \"content-type\" must be specified. 65 | -- Default value: []. 66 | -- 67 | -- 68 | -- Since: 3.2.7 69 | , promisedWeight :: Weight 70 | -- ^ Accessor for 'Weight' in 'PushPromise'. 71 | -- Default value: 16. 72 | -- 73 | -- Since: 3.2.7 74 | } 75 | deriving (Eq, Ord, Show) 76 | 77 | -- | Default push promise. 78 | -- 79 | -- Since: 3.2.7 80 | defaultPushPromise :: PushPromise 81 | defaultPushPromise = PushPromise "" "" [] 16 82 | -------------------------------------------------------------------------------- /warp/attic/pong.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Blaze.ByteString.Builder (copyByteString) 4 | import qualified Data.Conduit as C 5 | import qualified Data.Conduit.List as CL 6 | import Data.Monoid 7 | import Network.HTTP.Types (status200) 8 | import Network.Wai 9 | import Network.Wai.Handler.Warp 10 | 11 | main = run 3000 app 12 | 13 | app req = 14 | ( $ 15 | case rawPathInfo req of 16 | "/builder/withlen" -> builderWithLen 17 | "/builder/nolen" -> builderNoLen 18 | "/file/withlen" -> fileWithLen 19 | "/file/nolen" -> fileNoLen 20 | "/source/withlen" -> sourceWithLen 21 | "/source/nolen" -> sourceNoLen 22 | "/notfound" -> responseFile status200 [] "notfound" Nothing 23 | x -> index x 24 | ) 25 | 26 | builderWithLen = 27 | responseBuilder 28 | status200 29 | [ ("Content-Type", "text/plain") 30 | , ("Content-Length", "4") 31 | ] 32 | $ copyByteString "PONG" 33 | 34 | builderNoLen = 35 | responseBuilder 36 | status200 37 | [ ("Content-Type", "text/plain") 38 | ] 39 | $ copyByteString "PONG" 40 | 41 | sourceWithLen = responseStream 42 | status200 43 | [ ("Content-Type", "text/plain") 44 | , ("Content-Length", "4") 45 | ] 46 | $ \send _ -> send $ copyByteString "PONG" 47 | 48 | sourceNoLen = responseStream 49 | status200 50 | [ ("Content-Type", "text/plain") 51 | ] 52 | $ \send _ -> send $ copyByteString "PONG" 53 | 54 | fileWithLen = 55 | responseFile 56 | status200 57 | [ ("Content-Type", "text/plain") 58 | , ("Content-Length", "4") 59 | ] 60 | "pong.txt" 61 | Nothing 62 | 63 | fileNoLen = 64 | responseFile 65 | status200 66 | [ ("Content-Type", "text/plain") 67 | ] 68 | "pong.txt" 69 | Nothing 70 | 71 | index p = 72 | responseBuilder status200 [("Content-Type", "text/html")] $ 73 | mconcat $ 74 | map 75 | copyByteString 76 | [ "

builder withlen

\n" 77 | , "

builder nolen

\n" 78 | , "

file withlen

\n" 79 | , "

file nolen

\n" 80 | , "

source withlen

\n" 81 | , "

source nolen

\n" 82 | , p 83 | ] 84 | -------------------------------------------------------------------------------- /warp/Network/Wai/Handler/Warp/IO.hs: -------------------------------------------------------------------------------- 1 | module Network.Wai.Handler.Warp.IO where 2 | 3 | import Control.Exception (mask_) 4 | import Data.ByteString.Builder (Builder) 5 | import Data.ByteString.Builder.Extra (Next (Chunk, Done, More), runBuilder) 6 | import Data.IORef (IORef, readIORef, writeIORef) 7 | import Network.Wai.Handler.Warp.Buffer 8 | import Network.Wai.Handler.Warp.Imports 9 | import Network.Wai.Handler.Warp.Types 10 | 11 | toBufIOWith 12 | :: Int -> IORef WriteBuffer -> (ByteString -> IO ()) -> Builder -> IO Integer 13 | toBufIOWith maxRspBufSize writeBufferRef io builder = do 14 | writeBuffer <- readIORef writeBufferRef 15 | loop writeBuffer firstWriter 0 16 | where 17 | firstWriter = runBuilder builder 18 | loop writeBuffer writer bytesSent = do 19 | let buf = bufBuffer writeBuffer 20 | size = bufSize writeBuffer 21 | (len, signal) <- writer buf size 22 | bufferIO buf len io 23 | let totalBytesSent = toInteger len + bytesSent 24 | case signal of 25 | Done -> return totalBytesSent 26 | More minSize next 27 | | size < minSize -> do 28 | when (minSize > maxRspBufSize) $ 29 | error $ 30 | "Sending a Builder response required a buffer of size " 31 | ++ show minSize 32 | ++ " which is bigger than the specified maximum of " 33 | ++ show maxRspBufSize 34 | ++ "!" 35 | -- The current WriteBuffer is too small to fit the next 36 | -- batch of bytes from the Builder so we free it and 37 | -- create a new bigger one. Freeing the current buffer, 38 | -- creating a new one and writing it to the IORef need 39 | -- to be performed atomically to prevent both double 40 | -- frees and missed frees. So we mask async exceptions: 41 | biggerWriteBuffer <- mask_ $ do 42 | bufFree writeBuffer 43 | biggerWriteBuffer <- createWriteBuffer minSize 44 | writeIORef writeBufferRef biggerWriteBuffer 45 | return biggerWriteBuffer 46 | loop biggerWriteBuffer next totalBytesSent 47 | | otherwise -> loop writeBuffer next totalBytesSent 48 | Chunk bs next -> do 49 | io bs 50 | loop writeBuffer next totalBytesSent 51 | -------------------------------------------------------------------------------- /wai-websockets/static/client.js: -------------------------------------------------------------------------------- 1 | function createWebSocket(path) { 2 | var host = window.location.hostname; 3 | if(host == '') host = 'localhost'; 4 | var uri = 'ws://' + host + ':9160' + path; 5 | 6 | var Socket = "MozWebSocket" in window ? MozWebSocket : WebSocket; 7 | return new Socket(uri); 8 | } 9 | 10 | var users = []; 11 | 12 | function refreshUsers() { 13 | $('#users').html(''); 14 | for(i in users) { 15 | $('#users').append($(document.createElement('li')).text(users[i])); 16 | } 17 | } 18 | 19 | function onMessage(event) { 20 | var p = $(document.createElement('p')).text(event.data); 21 | 22 | $('#messages').append(p); 23 | $('#messages').animate({scrollTop: $('#messages')[0].scrollHeight}); 24 | 25 | if(event.data.match(/^[^:]* joined/)) { 26 | var user = event.data.replace(/ .*/, ''); 27 | users.push(user); 28 | refreshUsers(); 29 | } 30 | 31 | if(event.data.match(/^[^:]* disconnected/)) { 32 | var user = event.data.replace(/ .*/, ''); 33 | var idx = users.indexOf(user); 34 | users = users.slice(0, idx).concat(users.slice(idx + 1)); 35 | refreshUsers(); 36 | } 37 | } 38 | 39 | $(document).ready(function () { 40 | $('#join-form').submit(function () { 41 | $('#warnings').html(''); 42 | var user = $('#user').val(); 43 | var ws = createWebSocket('/'); 44 | 45 | ws.onopen = function() { 46 | ws.send('Hi! I am ' + user); 47 | }; 48 | 49 | ws.onmessage = function(event) { 50 | if(event.data.match('^Welcome! Users: ')) { 51 | /* Calculate the list of initial users */ 52 | var str = event.data.replace(/^Welcome! Users: /, ''); 53 | if(str != "") { 54 | users = str.split(", "); 55 | refreshUsers(); 56 | } 57 | 58 | $('#join-section').hide(); 59 | $('#chat-section').show(); 60 | $('#users-section').show(); 61 | 62 | ws.onmessage = onMessage; 63 | 64 | $('#message-form').submit(function () { 65 | var text = $('#text').val(); 66 | ws.send(text); 67 | $('#text').val(''); 68 | return false; 69 | }); 70 | } else { 71 | $('#warnings').append(event.data); 72 | ws.close(); 73 | } 74 | }; 75 | 76 | $('#join').append('Connecting...'); 77 | 78 | return false; 79 | }); 80 | }); 81 | -------------------------------------------------------------------------------- /wai-frontend-monadcgi/Network/Wai/Frontend/MonadCGI.hs: -------------------------------------------------------------------------------- 1 | module Network.Wai.Frontend.MonadCGI ( 2 | cgiToApp, 3 | cgiToAppGeneric, 4 | ) where 5 | 6 | import Control.Monad.IO.Class (liftIO) 7 | import Data.CaseInsensitive (original) 8 | import Network.CGI.Monad 9 | import Network.CGI.Protocol 10 | import Network.HTTP.Types (Status (..)) 11 | import Network.Wai 12 | 13 | import qualified Data.ByteString.Char8 as S8 14 | import qualified Data.ByteString.Lazy as BS 15 | import qualified Data.Map as Map 16 | 17 | import Control.Arrow (first) 18 | import Data.Char (toUpper) 19 | import Data.String (fromString) 20 | 21 | safeRead :: Read a => a -> String -> a 22 | safeRead d s = case reads s of 23 | ((x, _) : _) -> x 24 | _ -> d 25 | 26 | cgiToApp :: CGI CGIResult -> Application 27 | cgiToApp = cgiToAppGeneric id 28 | 29 | cgiToAppGeneric 30 | :: Monad m 31 | => (m (Headers, CGIResult) -> IO (Headers, CGIResult)) 32 | -> CGIT m CGIResult 33 | -> Application 34 | cgiToAppGeneric toIO cgi env sendResponse = do 35 | input <- lazyRequestBody env 36 | let vars = 37 | map (first fixVarName . go) (requestHeaders env) 38 | ++ getCgiVars env 39 | (inputs, body') = decodeInput vars input 40 | req = 41 | CGIRequest 42 | { cgiVars = Map.fromList vars 43 | , cgiInputs = inputs 44 | , cgiRequestBody = body' 45 | } 46 | (headers'', output') <- liftIO $ toIO $ runCGIT cgi req 47 | let output = case output' of 48 | CGIOutput bs -> bs 49 | CGINothing -> BS.empty 50 | let headers' = 51 | map 52 | ( \(HeaderName x, y) -> 53 | (fromString x, S8.pack y) 54 | ) 55 | headers'' 56 | let status' = case lookup (fromString "Status") headers' of 57 | Nothing -> 200 58 | Just s -> safeRead 200 $ S8.unpack s 59 | sendResponse $ responseLBS (Status status' S8.empty) headers' output 60 | where 61 | go (x, y) = (S8.unpack $ original x, S8.unpack y) 62 | 63 | fixVarName :: String -> String 64 | fixVarName = ("HTTP_" ++) . map fixVarNameChar 65 | 66 | fixVarNameChar :: Char -> Char 67 | fixVarNameChar '-' = '_' 68 | fixVarNameChar c = toUpper c 69 | 70 | getCgiVars :: Request -> [(String, String)] 71 | getCgiVars e = 72 | [ ("PATH_INFO", S8.unpack $ rawPathInfo e) 73 | , ("REQUEST_METHOD", show $ requestMethod e) 74 | , 75 | ( "QUERY_STRING" 76 | , case S8.unpack $ rawQueryString e of 77 | '?' : rest -> rest 78 | x -> x 79 | ) 80 | ] 81 | -------------------------------------------------------------------------------- /wai-app-static/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # wai-app-static changelog 2 | 3 | ## 3.1.9 4 | 5 | * Added `NoCache` constructor to `MaxAge` [#977](https://github.com/yesodweb/wai/pull/977) 6 | 7 | ## 3.1.8 8 | 9 | * Added `NoStore` constructor to `MaxAge` [#938](https://github.com/yesodweb/wai/pull/938) 10 | 11 | ## 3.1.7.5 12 | 13 | * Removed dependency of `time`, `old-locale` and `network` [#902](https://github.com/yesodweb/wai/pull/902) 14 | 15 | ## 3.1.7.4 16 | 17 | * Fix a bug when the cryptonite flag is disabled. [#874](https://github.com/yesodweb/wai/pull/874) 18 | 19 | ## 3.1.7.3 20 | 21 | * Introduce a flag to avoid the cryptonite dependency. [#871](https://github.com/yesodweb/wai/pull/871) 22 | 23 | ## 3.1.7.2 24 | 25 | * `optparse-applicative-0.16.0.0` support 26 | 27 | ## 3.1.7.1 28 | 29 | * Update the test suite too 30 | 31 | ## 3.1.7 32 | 33 | * Use 302 instead of 301 redirect, to avoid caching the presence of an index.html file 34 | 35 | ## 3.1.6.3 36 | 37 | * The executable warp obeys `-h` option properly for host 38 | now. Previously this used to invoke the help option. That can be 39 | reached via `--help` as before. 40 | 41 | ## 3.1.6.2 42 | 43 | * Drop dependency on `blaze-builder` 44 | 45 | ## 3.1.6.1 46 | 47 | * Add `<>` import 48 | 49 | ## 3.1.6 50 | 51 | * Make ssAddTrailingSlash work in combination with ssIndices [#569](https://github.com/yesodweb/wai/pull/569) 52 | * Make ssIndices work with ssLookupFile and trailing slashes [#570](https://github.com/yesodweb/wai/pull/570) 53 | 54 | ## 3.1.5 55 | 56 | * Switch to cryponite 57 | 58 | ## 3.1.4.1 59 | 60 | * Support wai/warp 3.2 61 | 62 | ## 3.1.4 63 | 64 | * Reinstate redirectToIndex 65 | 66 | ## 3.1.3 67 | 68 | * Add 404 handler [#467](https://github.com/yesodweb/wai/pull/467) 69 | 70 | ## 3.1.2 71 | 72 | * Honor ssIndices when used with defaultWebAppSettings [#460](https://github.com/yesodweb/wai/pull/460) 73 | 74 | ## 3.1.1 75 | 76 | * Make adding a trailing slash optional [#327](https://github.com/yesodweb/wai/issues/327) [yesod#988](https://github.com/yesodweb/yesod/issues/988) 77 | 78 | ## 3.1.0 79 | 80 | * Drop system-filepath 81 | 82 | ## 3.0.1.1 83 | 84 | * Fix root links 85 | 86 | ## 3.0.1 87 | 88 | * Better HEAD support [#354](https://github.com/yesodweb/wai/issues/354) 89 | 90 | ## 3.0.0.6 91 | 92 | Fix trailing slashes for `UrlMap` and other non-root setups [#325](https://github.com/yesodweb/wai/issues/325) 93 | 94 | ## 3.0.0.4 95 | 96 | Add missing trailing slashes [#312](https://github.com/yesodweb/wai/issues/312) 97 | 98 | ## 3.0.0.3 99 | 100 | Support for time 1.5 101 | -------------------------------------------------------------------------------- /wai-extra/example/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Concurrent (forkIO, threadDelay) 6 | import Control.Concurrent.Chan 7 | import Control.Monad (forever) 8 | import Data.ByteString.Builder (string8) 9 | import Data.Time.Clock.POSIX (getPOSIXTime) 10 | import Network.HTTP.Types (status200) 11 | import Network.Wai (Application, Middleware, pathInfo, responseFile) 12 | import Network.Wai.EventSource ( 13 | ServerEvent (..), 14 | eventSourceAppChan, 15 | eventSourceAppIO, 16 | ) 17 | import Network.Wai.Handler.Warp (run) 18 | import Network.Wai.Middleware.AddHeaders (addHeaders) 19 | import Network.Wai.Middleware.Gzip (defaultGzipSettings, gzip) 20 | 21 | app :: Chan ServerEvent -> Application 22 | app chan req respond = 23 | case pathInfo req of 24 | [] -> 25 | respond $ 26 | responseFile 27 | status200 28 | [("Content-Type", "text/html")] 29 | "example/index.html" 30 | Nothing 31 | ["esold"] -> eventSourceAppChan chan req respond 32 | ["eschan"] -> eventSourceAppChan chan req respond 33 | ["esio"] -> eventSourceAppIO eventIO req respond 34 | _ -> error "unexpected pathInfo" 35 | 36 | eventChan :: Chan ServerEvent -> IO () 37 | eventChan chan = forever $ do 38 | threadDelay 1000000 39 | time <- getPOSIXTime 40 | writeChan chan (ServerEvent Nothing Nothing [string8 . show $ time]) 41 | 42 | eventIO :: IO ServerEvent 43 | eventIO = do 44 | threadDelay 1000000 45 | time <- getPOSIXTime 46 | return $ 47 | ServerEvent 48 | (Just $ string8 "io") 49 | Nothing 50 | [string8 . show $ time] 51 | 52 | eventRaw :: (ServerEvent -> IO ()) -> IO () -> IO () 53 | eventRaw = handle (0 :: Int) 54 | where 55 | handle counter emit flush = do 56 | threadDelay 1000000 57 | _ <- 58 | emit $ 59 | ServerEvent 60 | (Just $ string8 "raw") 61 | Nothing 62 | [string8 . show $ counter] 63 | _ <- flush 64 | handle (counter + 1) emit flush 65 | 66 | main :: IO () 67 | main = do 68 | chan <- newChan 69 | _ <- forkIO . eventChan $ chan 70 | run 8080 (gzip defaultGzipSettings $ headers $ app chan) 71 | where 72 | -- headers required for SSE to work through nginx 73 | -- not required if using warp directly 74 | headers :: Middleware 75 | headers = 76 | addHeaders 77 | [ ("X-Accel-Buffering", "no") 78 | , ("Cache-Control", "no-cache") 79 | ] 80 | -------------------------------------------------------------------------------- /recv/Network/Socket/BufferPool/Buffer.hs: -------------------------------------------------------------------------------- 1 | module Network.Socket.BufferPool.Buffer ( 2 | newBufferPool, 3 | withBufferPool, 4 | mallocBS, 5 | copy, 6 | ) where 7 | 8 | import qualified Data.ByteString as BS 9 | import Data.ByteString.Internal (ByteString (..)) 10 | import Data.ByteString.Unsafe (unsafeDrop, unsafeTake) 11 | import Data.IORef (newIORef, readIORef, writeIORef) 12 | import Foreign.ForeignPtr 13 | import Foreign.Marshal.Alloc (finalizerFree, mallocBytes) 14 | import Foreign.Marshal.Utils (copyBytes) 15 | import Foreign.Ptr (castPtr, plusPtr) 16 | 17 | import Network.Socket.BufferPool.Types 18 | 19 | ---------------------------------------------------------------- 20 | 21 | -- | Creating a buffer pool. 22 | -- The first argument is the lower limit. 23 | -- When the size of the buffer in the poll is lower than this limit, 24 | -- the buffer is thrown awany (and is eventually freed). 25 | -- Then a new buffer is allocated. 26 | -- The second argument is the size for the new allocation. 27 | newBufferPool :: Int -> Int -> IO BufferPool 28 | newBufferPool l h = BufferPool l h <$> newIORef BS.empty 29 | 30 | ---------------------------------------------------------------- 31 | 32 | -- | Using a buffer pool. 33 | -- The second argument is a function which returns 34 | -- how many bytes are filled in the buffer. 35 | -- The buffer in the buffer pool is automatically managed. 36 | withBufferPool :: BufferPool -> (Buffer -> BufSize -> IO Int) -> IO ByteString 37 | withBufferPool (BufferPool l h ref) f = do 38 | buf0 <- readIORef ref 39 | buf <- 40 | if BS.length buf0 >= l 41 | then return buf0 42 | else mallocBS h 43 | consumed <- withForeignBuffer buf f 44 | writeIORef ref $ unsafeDrop consumed buf 45 | return $ unsafeTake consumed buf 46 | 47 | withForeignBuffer :: ByteString -> (Buffer -> BufSize -> IO Int) -> IO Int 48 | withForeignBuffer (PS ps s l) f = withForeignPtr ps $ \p -> f (castPtr p `plusPtr` s) l 49 | {-# INLINE withForeignBuffer #-} 50 | 51 | ---------------------------------------------------------------- 52 | 53 | -- | Allocating a byte string. 54 | mallocBS :: Int -> IO ByteString 55 | mallocBS size = do 56 | ptr <- mallocBytes size 57 | fptr <- newForeignPtr finalizerFree ptr 58 | return $ PS fptr 0 size 59 | {-# INLINE mallocBS #-} 60 | 61 | -- | Copying the bytestring to the buffer. 62 | -- This function returns the point where the next copy should start. 63 | copy :: Buffer -> ByteString -> IO Buffer 64 | copy ptr (PS fp o l) = withForeignPtr fp $ \p -> do 65 | copyBytes ptr (p `plusPtr` o) (fromIntegral l) 66 | return $ ptr `plusPtr` l 67 | {-# INLINE copy #-} 68 | -------------------------------------------------------------------------------- /wai-extra/test/Network/Wai/Middleware/StripHeadersSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Network.Wai.Middleware.StripHeadersSpec ( 5 | main, 6 | spec, 7 | ) where 8 | 9 | import Control.Arrow (first) 10 | import Data.ByteString (ByteString) 11 | import qualified Data.CaseInsensitive as CI 12 | #if __GLASGOW_HASKELL__ < 804 13 | import Data.Monoid ((<>)) 14 | #endif 15 | import Network.HTTP.Types (status200) 16 | import Network.Wai 17 | import Network.Wai.Test (SResponse (simpleHeaders), request, runSession) 18 | import Test.Hspec 19 | 20 | import Network.Wai.Middleware.AddHeaders (addHeaders) 21 | import Network.Wai.Middleware.StripHeaders (stripHeaderIf, stripHeadersIf) 22 | 23 | main :: IO () 24 | main = hspec spec 25 | 26 | spec :: Spec 27 | spec = describe "stripHeader" $ do 28 | let host = "example.com" 29 | let ciTestHeaders = map (first CI.mk) testHeaders 30 | 31 | it "strips a specific header" $ do 32 | resp1 <- runApp host (addHeaders testHeaders) defaultRequest 33 | resp2 <- 34 | runApp 35 | host 36 | (stripHeaderIf "Foo" (const False) . addHeaders testHeaders) 37 | defaultRequest 38 | resp3 <- 39 | runApp 40 | host 41 | (stripHeaderIf "Foo" (const True) . addHeaders testHeaders) 42 | defaultRequest 43 | 44 | simpleHeaders resp1 `shouldBe` ciTestHeaders 45 | simpleHeaders resp2 `shouldBe` ciTestHeaders 46 | simpleHeaders resp3 `shouldBe` drop 1 ciTestHeaders 47 | 48 | it "strips specific set of headers" $ do 49 | resp1 <- runApp host (addHeaders testHeaders) defaultRequest 50 | resp2 <- 51 | runApp 52 | host 53 | (stripHeadersIf ["Bar", "Foo"] (const False) . addHeaders testHeaders) 54 | defaultRequest 55 | resp3 <- 56 | runApp 57 | host 58 | (stripHeadersIf ["Bar", "Foo"] (const True) . addHeaders testHeaders) 59 | defaultRequest 60 | 61 | simpleHeaders resp1 `shouldBe` ciTestHeaders 62 | simpleHeaders resp2 `shouldBe` ciTestHeaders 63 | simpleHeaders resp3 `shouldBe` [last ciTestHeaders] 64 | 65 | testHeaders :: [(ByteString, ByteString)] 66 | testHeaders = [("Foo", "fooey"), ("Bar", "barbican"), ("Baz", "bazooka")] 67 | 68 | runApp :: ByteString -> Middleware -> Request -> IO SResponse 69 | runApp host mw req = 70 | runSession 71 | (request req{requestHeaderHost = Just $ host <> ":80"}) 72 | $ mw app 73 | where 74 | app _ respond = respond $ responseLBS status200 [] "" 75 | -------------------------------------------------------------------------------- /wai-http2-extra/Network/Wai/Middleware/Push/Referer/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Network.Wai.Middleware.Push.Referer.Types ( 4 | URLPath, 5 | MakePushPromise, 6 | defaultMakePushPromise, 7 | Settings (..), 8 | defaultSettings, 9 | ) where 10 | 11 | import Data.ByteString (ByteString) 12 | import qualified Data.ByteString as BS 13 | import Network.Wai.Handler.Warp (PushPromise (..), defaultPushPromise) 14 | 15 | -- | Type for URL path. 16 | type URLPath = ByteString 17 | 18 | -- | Making a push promise based on Referer:, 19 | -- path to be pushed and file to be pushed. 20 | -- If the middleware should push this file in the next time when 21 | -- the page of Referer: is accessed, 22 | -- this function should return 'Just'. 23 | -- If 'Nothing' is returned, 24 | -- the middleware learns nothing. 25 | type MakePushPromise = 26 | URLPath 27 | -- ^ path in referer (key: /index.html) 28 | -> URLPath 29 | -- ^ path to be pushed (value: /style.css) 30 | -> FilePath 31 | -- ^ file to be pushed (file_path/style.css) 32 | -> IO (Maybe PushPromise) 33 | 34 | -- | Learn if the file to be pushed is CSS (.css) or JavaScript (.js) file. 35 | defaultMakePushPromise :: MakePushPromise 36 | defaultMakePushPromise refPath path file = case getCT path of 37 | Nothing -> return Nothing 38 | Just ct -> do 39 | let pp = 40 | defaultPushPromise 41 | { promisedPath = path 42 | , promisedFile = file 43 | , promisedResponseHeaders = 44 | [ ("content-type", ct) 45 | , ("x-http2-push", refPath) 46 | ] 47 | } 48 | return $ Just pp 49 | 50 | getCT :: URLPath -> Maybe ByteString 51 | getCT p 52 | | ".js" `BS.isSuffixOf` p = Just "application/javascript" 53 | | ".css" `BS.isSuffixOf` p = Just "text/css" 54 | | otherwise = Nothing 55 | 56 | -- | Settings for server push based on Referer:. 57 | data Settings = Settings 58 | { makePushPromise :: MakePushPromise 59 | -- ^ Default: 'defaultMakePushPromise' 60 | , duration :: Int 61 | -- ^ Deprecated 62 | , keyLimit :: Int 63 | -- ^ Max number of keys (e.g. index.html) in the learning information. Default: 20 64 | , valueLimit :: Int 65 | -- ^ Max number of values (e.g. style.css) in the learning information. Default: 20 66 | } 67 | 68 | -- | Default settings. 69 | defaultSettings :: Settings 70 | defaultSettings = 71 | Settings 72 | { makePushPromise = defaultMakePushPromise 73 | , duration = 0 74 | , keyLimit = 20 75 | , valueLimit = 20 76 | } 77 | -------------------------------------------------------------------------------- /warp/Network/Wai/Handler/Warp/ResponseHeader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where 5 | 6 | import qualified Data.ByteString as S 7 | import Data.ByteString.Internal (create) 8 | import qualified Data.CaseInsensitive as CI 9 | import Data.List (foldl') 10 | import Data.Word8 11 | import Foreign.Ptr 12 | import GHC.Storable 13 | import qualified Network.HTTP.Types as H 14 | import Network.Socket.BufferPool (copy) 15 | 16 | import Network.Wai.Handler.Warp.Imports 17 | 18 | ---------------------------------------------------------------- 19 | 20 | composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> IO ByteString 21 | composeHeader !httpversion !status !responseHeaders = create len $ \ptr -> do 22 | ptr1 <- copyStatus ptr httpversion status 23 | ptr2 <- copyHeaders ptr1 responseHeaders 24 | void $ copyCRLF ptr2 25 | where 26 | !len = 17 + slen + foldl' fieldLength 0 responseHeaders 27 | fieldLength !l (!k, !v) = l + S.length (CI.original k) + S.length v + 4 28 | !slen = S.length $ H.statusMessage status 29 | 30 | httpVer11 :: ByteString 31 | httpVer11 = "HTTP/1.1 " 32 | 33 | httpVer10 :: ByteString 34 | httpVer10 = "HTTP/1.0 " 35 | 36 | {-# INLINE copyStatus #-} 37 | copyStatus :: Ptr Word8 -> H.HttpVersion -> H.Status -> IO (Ptr Word8) 38 | copyStatus !ptr !httpversion !status = do 39 | ptr1 <- copy ptr httpVer 40 | writeWord8OffPtr ptr1 0 (_0 + fromIntegral r2) 41 | writeWord8OffPtr ptr1 1 (_0 + fromIntegral r1) 42 | writeWord8OffPtr ptr1 2 (_0 + fromIntegral r0) 43 | writeWord8OffPtr ptr1 3 _space 44 | ptr2 <- copy (ptr1 `plusPtr` 4) (H.statusMessage status) 45 | copyCRLF ptr2 46 | where 47 | httpVer 48 | | httpversion == H.HttpVersion 1 1 = httpVer11 49 | | otherwise = httpVer10 50 | (q0, r0) = H.statusCode status `divMod` 10 51 | (q1, r1) = q0 `divMod` 10 52 | r2 = q1 `mod` 10 53 | 54 | {-# INLINE copyHeaders #-} 55 | copyHeaders :: Ptr Word8 -> [H.Header] -> IO (Ptr Word8) 56 | copyHeaders !ptr [] = return ptr 57 | copyHeaders !ptr (h : hs) = do 58 | ptr1 <- copyHeader ptr h 59 | copyHeaders ptr1 hs 60 | 61 | {-# INLINE copyHeader #-} 62 | copyHeader :: Ptr Word8 -> H.Header -> IO (Ptr Word8) 63 | copyHeader !ptr (k, v) = do 64 | ptr1 <- copy ptr (CI.original k) 65 | writeWord8OffPtr ptr1 0 _colon 66 | writeWord8OffPtr ptr1 1 _space 67 | ptr2 <- copy (ptr1 `plusPtr` 2) v 68 | copyCRLF ptr2 69 | 70 | {-# INLINE copyCRLF #-} 71 | copyCRLF :: Ptr Word8 -> IO (Ptr Word8) 72 | copyCRLF !ptr = do 73 | writeWord8OffPtr ptr 0 _cr 74 | writeWord8OffPtr ptr 1 _lf 75 | return $! ptr `plusPtr` 2 76 | -------------------------------------------------------------------------------- /warp-quic/Network/Wai/Handler/WarpQUIC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | WAI handler for HTTP/3 based on QUIC. 5 | module Network.Wai.Handler.WarpQUIC where 6 | 7 | import qualified Data.ByteString as BS 8 | import qualified Network.HQ.Server as HQ 9 | import qualified Network.HTTP3.Server as H3 10 | import Network.QUIC 11 | import Network.QUIC.Server as Q 12 | import Network.Socket (Socket) 13 | import Network.TLS (cipherID) 14 | import Network.Wai 15 | import Network.Wai.Handler.Warp hiding (run) 16 | import Network.Wai.Handler.Warp.Internal hiding (Connection) 17 | 18 | -- | QUIC server settings. 19 | type QUICSettings = ServerConfig 20 | 21 | runQUICSocket :: QUICSettings -> Settings -> Socket -> Application -> IO () 22 | runQUICSocket quicsettings settings sock app = 23 | withII settings $ \ii -> 24 | Q.runWithSockets [sock] quicsettings $ quicApp settings app ii 25 | 26 | runQUICSockets :: QUICSettings -> Settings -> [Socket] -> Application -> IO () 27 | runQUICSockets quicsettings settings ss app = 28 | withII settings $ \ii -> 29 | Q.runWithSockets ss quicsettings $ quicApp settings app ii 30 | 31 | -- | Running warp with HTTP/3 on QUIC. 32 | runQUIC :: QUICSettings -> Settings -> Application -> IO () 33 | runQUIC quicsettings settings app = 34 | withII settings $ \ii -> 35 | Q.run quicsettings $ quicApp settings app ii 36 | 37 | quicApp 38 | :: Settings 39 | -> Application 40 | -> InternalInfo 41 | -> Connection 42 | -> IO () 43 | quicApp settings app ii conn = do 44 | info <- getConnectionInfo conn 45 | mccc <- clientCertificateChain conn 46 | let addr = remoteSockAddr info 47 | malpn = alpn info 48 | transport = 49 | QUIC 50 | { quicNegotiatedProtocol = malpn 51 | , quicChiperID = cipherID $ cipher info 52 | , quicClientCertificate = mccc 53 | } 54 | pread = pReadMaker ii 55 | timmgr = timeoutManager ii 56 | #if !MIN_VERSION_http3(0,1,0) 57 | conf = H3.Config H3.defaultHooks pread timmgr 58 | #else 59 | conf = 60 | H3.defaultConfig 61 | { H3.confPositionReadMaker = pread 62 | , H3.confTimeoutManager = timmgr 63 | } 64 | #endif 65 | case malpn of 66 | Nothing -> return () 67 | Just appProto -> do 68 | let runX 69 | | "h3" `BS.isPrefixOf` appProto = H3.run 70 | | otherwise = HQ.run 71 | label 72 | | "h3" `BS.isPrefixOf` appProto = "Warp HTTP/3" 73 | | otherwise = "Warp HQ" 74 | runX conn conf $ http2server label settings ii transport addr app 75 | --------------------------------------------------------------------------------