http-listen (empty) → 0.1.0.0

raw patch · 9 files changed

+785/−0 lines, 9 filesdep +HTTPdep +basedep +bytestringsetup-changed

Dependencies added: HTTP, base, bytestring, exceptions, network, transformers

Files

• AUTHORS +1/−0
• COPYING +121/−0
• ChangeLog +17/−0
• INSTALL +13/−0
• NEWS +23/−0
• README.md +14/−0
• Setup.hs +2/−0
• http-listen.cabal +52/−0
• src/Network/HTTP/Listen.hs +542/−0

@@ -0,0 +1,1 @@+fr33domlover <fr33domlover@riseup.net>

@@ -0,0 +1,121 @@+Creative Commons Legal Code++CC0 1.0 Universal++    CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE+    LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN+    ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS+    INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES+    REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS+    PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM+    THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED+    HEREUNDER.++Statement of Purpose++The laws of most jurisdictions throughout the world automatically confer+exclusive Copyright and Related Rights (defined below) upon the creator+and subsequent owner(s) (each and all, an "owner") of an original work of+authorship and/or a database (each, a "Work").++Certain owners wish to permanently relinquish those rights to a Work for+the purpose of contributing to a commons of creative, cultural and+scientific works ("Commons") that the public can reliably and without fear+of later claims of infringement build upon, modify, incorporate in other+works, reuse and redistribute as freely as possible in any form whatsoever+and for any purposes, including without limitation commercial purposes.+These owners may contribute to the Commons to promote the ideal of a free+culture and the further production of creative, cultural and scientific+works, or to gain reputation or greater distribution for their Work in+part through the use and efforts of others.++For these and/or other purposes and motivations, and without any+expectation of additional consideration or compensation, the person+associating CC0 with a Work (the "Affirmer"), to the extent that he or she+is an owner of Copyright and Related Rights in the Work, voluntarily+elects to apply CC0 to the Work and publicly distribute the Work under its+terms, with knowledge of his or her Copyright and Related Rights in the+Work and the meaning and intended legal effect of CC0 on those rights.++1. Copyright and Related Rights. A Work made available under CC0 may be+protected by copyright and related or neighboring rights ("Copyright and+Related Rights"). Copyright and Related Rights include, but are not+limited to, the following:++  i. the right to reproduce, adapt, distribute, perform, display,+     communicate, and translate a Work;+ ii. moral rights retained by the original author(s) and/or performer(s);+iii. publicity and privacy rights pertaining to a person's image or+     likeness depicted in a Work;+ iv. rights protecting against unfair competition in regards to a Work,+     subject to the limitations in paragraph 4(a), below;+  v. rights protecting the extraction, dissemination, use and reuse of data+     in a Work;+ vi. database rights (such as those arising under Directive 96/9/EC of the+     European Parliament and of the Council of 11 March 1996 on the legal+     protection of databases, and under any national implementation+     thereof, including any amended or successor version of such+     directive); and+vii. other similar, equivalent or corresponding rights throughout the+     world based on applicable law or treaty, and any national+     implementations thereof.++2. Waiver. To the greatest extent permitted by, but not in contravention+of, applicable law, Affirmer hereby overtly, fully, permanently,+irrevocably and unconditionally waives, abandons, and surrenders all of+Affirmer's Copyright and Related Rights and associated claims and causes+of action, whether now known or unknown (including existing as well as+future claims and causes of action), in the Work (i) in all territories+worldwide, (ii) for the maximum duration provided by applicable law or+treaty (including future time extensions), (iii) in any current or future+medium and for any number of copies, and (iv) for any purpose whatsoever,+including without limitation commercial, advertising or promotional+purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each+member of the public at large and to the detriment of Affirmer's heirs and+successors, fully intending that such Waiver shall not be subject to+revocation, rescission, cancellation, termination, or any other legal or+equitable action to disrupt the quiet enjoyment of the Work by the public+as contemplated by Affirmer's express Statement of Purpose.++3. Public License Fallback. Should any part of the Waiver for any reason+be judged legally invalid or ineffective under applicable law, then the+Waiver shall be preserved to the maximum extent permitted taking into+account Affirmer's express Statement of Purpose. In addition, to the+extent the Waiver is so judged Affirmer hereby grants to each affected+person a royalty-free, non transferable, non sublicensable, non exclusive,+irrevocable and unconditional license to exercise Affirmer's Copyright and+Related Rights in the Work (i) in all territories worldwide, (ii) for the+maximum duration provided by applicable law or treaty (including future+time extensions), (iii) in any current or future medium and for any number+of copies, and (iv) for any purpose whatsoever, including without+limitation commercial, advertising or promotional purposes (the+"License"). The License shall be deemed effective as of the date CC0 was+applied by Affirmer to the Work. Should any part of the License for any+reason be judged legally invalid or ineffective under applicable law, such+partial invalidity or ineffectiveness shall not invalidate the remainder+of the License, and in such case Affirmer hereby affirms that he or she+will not (i) exercise any of his or her remaining Copyright and Related+Rights in the Work or (ii) assert any associated claims and causes of+action with respect to the Work, in either case contrary to Affirmer's+express Statement of Purpose.++4. Limitations and Disclaimers.++ a. No trademark or patent rights held by Affirmer are waived, abandoned,+    surrendered, licensed or otherwise affected by this document.+ b. Affirmer offers the Work as-is and makes no representations or+    warranties of any kind concerning the Work, express, implied,+    statutory or otherwise, including without limitation warranties of+    title, merchantability, fitness for a particular purpose, non+    infringement, or the absence of latent or other defects, accuracy, or+    the present or absence of errors, whether or not discoverable, all to+    the greatest extent permissible under applicable law.+ c. Affirmer disclaims responsibility for clearing rights of other persons+    that may apply to the Work or any use thereof, including without+    limitation any person's Copyright and Related Rights in the Work.+    Further, Affirmer disclaims responsibility for obtaining any necessary+    consents, permissions or other rights required for any use of the+    Work.+ d. Affirmer understands and acknowledges that Creative Commons is not a+    party to this document and has no duty or obligation with respect to+    this CC0 or use of the Work.

@@ -0,0 +1,17 @@+The changes are recorded by the version control system, Darcs. To see a log+quickly from the terminal, run:++  $ darcs changes --repo http://dev.rel4tion.org/fr33domlover/http-listen++There is also a web interface at <http://darcs.rel4tion.org> which, among other+things, can display the history log.++To see the log in a local clone, first get a copy of the repository if you+haven't yet:++  $ darcs get http://dev.rel4tion.org/fr33domlover/http-listen++Then move into the newly created directory and run darcs:++  $ cd http-listen+  $ darcs changes

@@ -0,0 +1,13 @@+Install from Hackage:++    $ cabal install http-listen++Install from unpacked release tarball or source repo:++    $ cd http-listen+    $ cabal install++Just play with it without installing:++    $ cabal build+    $ cabal repl

@@ -0,0 +1,23 @@+This file lists the user-visible interesting changes between releases. For a+full list of changes to the source, see the ChangeLog.++++http-listen 0.1.0.0 -- 2015-08-06+=================================++General, build and documentation changes:++* (This is the first release, so everything is new)++New APIs, features and enhancements:++* (This is the first release, so everything is a new feature)++Bug fixes:++* (This is just the first release)++Dependency changes:++* (This is the first release)

@@ -0,0 +1,14 @@+See the .cabal file for more info and link to project website the version+control.++The official download location is Hackage:++<http://hackage.haskell.org/package/http-listen>++This library is free software, and is committed to software freedom. It is+released to the public domain using the CC0 Public Domain Dedication. For the+boring "legal" details see the file 'COPYING'.++See the file 'INSTALL' for hints on installation. The file 'ChangeLog' explains+how to see the history log of the changes done in the code. 'NEWS' provides a+friendly overview of the changes for each release.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,52 @@+name:                http-listen+version:             0.1.0.0+synopsis:            Listen to HTTP requests and handle them in arbitrary ways.+description:+  In HTTP connections, there is a client side which sends requests (such as GET+  and POST), and a server side which receives and parses them. Often, the+  server side is a web server which responds to requests by sending some HTML+  pages back. But sometimes it's just a listener.+  .+  For example, a Git server may offer web hooks. It could send a POST request+  whenever a commit is made, or a new repository is created. You then set up a+  program that listens to these POSTs and reacts by reporting them to the+  project's IRC channel or a mailing list.+  .+  Most HTTP packages assume a typical web server which handles requests by+  returning HTTP responses. This package tries to fill a gap by providing an+  API for simple listeners which don't necessarily serve web pages, and can do+  things like reporting to IRC.+  .+  Some features are missing and will be added soon:+  .+  * Connection timeouts+  * Logging (currently errors are written to stdout, no other logging done)+homepage:            http://rel4tion.org/projects/http-listen/+bug-reports:         http://rel4tion.org/projects/http-listen/tickets/+license:             PublicDomain+license-file:        COPYING+author:              fr33domlover+maintainer:          fr33domlover@riseup.net+copyright:           ♡ Copying is an act of love. Please copy, reuse and share.+category:            Network, Web+build-type:          Simple+extra-source-files:  AUTHORS ChangeLog COPYING INSTALL NEWS README.md+cabal-version:       >=1.10++source-repository head+  type:                darcs+  location:            http://dev.rel4tion.org/fr33domlover/http-listen++library+  exposed-modules:     Network.HTTP.Listen+  -- other-modules:       +  -- other-extensions:    +  build-depends:       base         >=4.7 && <5+                     , bytestring+                     , exceptions   >=0.8+                     --, fast-logger  >=2.4+                     , HTTP         >=4000.2+                     , network+                     , transformers >=0.4.1+  hs-source-dirs:      src+  default-language:    Haskell2010

@@ -0,0 +1,542 @@+{- This file is part of http-listen.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++-- | This module offers several ways to create an HTTP listener, hopefully+-- covering common use cases. They are described below, from high level to low+-- level. But before that, here's a quick start example.+--+-- = Quickstart+--+-- Create a source file containing the following:+--+-- > import qualified Data.ByteString.Lazy as B+-- > import           Network.HTTP+-- > import           Network.HTTP.Listen+-- >+-- > listener :: Listener B.ByteString IO+-- > listener request = print request >> return Nothing+-- >+-- > main :: IO+-- > main = run 8999 listener+--+-- Install the http-listen package from Hackage:+--+-- > $ cabal install http-listen+--+-- Run the program:+--+-- > $ runhaskell hello.hs+--+-- Now point your web browser to @http://localhost:8999@. It will fail to load+-- anything, since our listener doesn't send any response, but in the terminal+-- you'll see the HTTP request printed.+--+-- = Running a Listener+--+-- A 'Listener' is a function which takes an HTTP request and returns an action+-- in some monad @m@. Since receiving HTTP requests is an IO activity, @m@ must+-- be a 'MonadIO' instance. For example, the 'IO' monad itself, or a monad+-- transformer stack on top of 'IO'.+--+-- The IO action optionally returns an HTTP response, which is then sent back+-- to the client. Setting up the headers of the response, and in particular the+-- @connection@ header (which affects HTTP connection persistence), are up to+-- the listener. The library decides based on it (and based on the request)+-- whether to close the connection or keep it open. If you don't need to send+-- anything back to the client, just write your listener function to return+-- 'Nothing'.+--+-- A 'Listener' handles requests with content encoded into a specific type.+-- That type must be an instance of 'HStream' (a class from the HTTP package).+-- The HTTP package provides instances for 'String' and for strict and lazy+-- bytestrings. You can write your own instances, but in most cases you+-- probably won't need to. Perhaps instances for 'Data.Text.Text' and its lazy+-- version could be useful.+--+-- Here is an example listener, which takes requests containing lazy+-- 'Data.ByteString.Lazy.ByteString' data, and returns an 'IO' action. All it+-- does is print the HTTP request it got into standard output.+--+-- > import qualified Data.ByteString.Lazy as B+-- > import           Network.HTTP+-- > import           Network.HTTP.Listen+-- >+-- > listener :: Listener B.ByteString IO+-- > listener request = do+-- >     print request+-- >     return Nothing+--+-- Once we've defined the listener, we can run a loop which listens to TCP+-- connections, reads HTTP responses from them and applies our listener+-- function. There are two ready functions which run such a loop, 'run' and+-- 'runWithBlocking'. The difference is that 'run' handles each connection in+-- a separate thread (using 'forkIO'), while 'runWithBlocking' does everything+-- in a single thread.+--+-- Both functions take 2 parameters. A port number and the listener function.+-- For example, run our listener on port 8999 like this:+--+-- > run 8999 listener+--+-- Another difference between blocking and non-blocking runs, is that blocking+-- runs support listeners operating in any instance of 'MonadIO' and+-- 'C.MonadMask', while non-blocking ones are IO only. This may seem like a+-- restriction, but it actually makes sense: When using a single thread, you+-- can use some monad transformer stack with state and logging and other+-- effects. When forking to a new thread on each connection, you don't use or+-- need any extra effects because the logic happens in a separate thread. In+-- that separate thread you can use whatever monad(s) you wish.+--+-- On the technical side, 'forkIO' takes an IO action of type @IO ()@, so+-- that's what the non-blocking run needs to use.+--+-- = Handling Clients+--+-- To get a bit more control, you can write your own (blocking or non-blocking)+-- client handling loop. The primary components are:+--+-- * 'prepareSocket' opens a server socket listening to connections+-- * 'handleClient' handles a client connection in a new thread+-- * 'handleClientBlocking' is a version that runs in the current thread+--+-- There are a few more utility functions you may find useful.+--+-- Let's write a simple loop which accepts connections from clients and handles+-- them in separate worker threads which apply our listener. We'll use the same+-- listener from the previous section.+--+-- > listener :: Listener B.ByteString IO+-- > listener request = { ... same as above .... }+-- >+-- > main =+-- >     bracket+-- >         (prepareSocket 8999)+-- >         close+-- >         (\ sock -> forever $ handleClient sock listener)+--+-- = Manual Control+--+-- This is the lowest level layer provided by this module. It wraps the+-- relevant parts of the @network@ and @HTTP@ packages, creating a network API+-- for web listeners. It may be useful if you need more flexibility that the+-- higher level layers can provide.+--+-- Let's write a simple program using this API, which handles a single+-- connection and exits. For simplicity, we'll assume a single HTTP request is+-- received per connection, so we'll close the connection after getting one+-- request. In reality, connections can be used for sending multiple requests+-- (in HTTP 1.1, connection reuse is the default behavior).+--+-- As usual, we begin by preparing a server socket:+--+-- > main :: IO ()+-- > main = do+-- >     sock <- prepareSocket 8999+-- >     -- ...+--+-- Then we wait for a connection from a client:+--+-- > main = do+-- >     sock <- prepareSocket 8999+-- >     conn <- acceptConnection sock+-- >     -- ...+--+-- Once we have a connection, we open a stream for receiving data. After+-- opening a stream successfully, we don't need the connection value anymore+-- (the stream value is now holding the newly open socket).+--+-- Opening a stream and further actions could happen in a separate thread, so+-- that all the main thread does is accept connections. For simplicity, let's+-- just do this in the same thread.+--+-- > main = do+-- >     sock <- prepareSocket 8999+-- >     conn <- acceptConnection sock+-- >     stream <- openStream conn+-- >     -- ...+--+-- Now we can read an HTTP request from the client:+--+-- > main = do+-- >     sock <- prepareSocket 8999+-- >     conn <- acceptConnection sock+-- >     stream <- openStream conn+-- >     result <- receiveRequest stream+-- >     -- ...+--+-- Since we're done with the connection, let's close the stream. We're also+-- done accepting connections, so let's close the server socket too.+--+-- > main = do+-- >     sock <- prepareSocket 8999+-- >     conn <- acceptConnection sock+-- >     stream <- openStream conn+-- >     result <- receiveRequest stream+-- >     closeStream stream+-- >     close sock+-- >     -- ...+--+-- Finally, let's display what we got:+--+-- > main = do+-- >     sock <- prepareSocket 8999+-- >     conn <- acceptConnection sock+-- >     stream <- openStream conn+-- >     result <- receiveRequest stream+-- >     closeStream stream+-- >     close sock+-- >     case result of+-- >         Left err -> print err+-- >         Right (request :: Request B.ByteString) -> print request+--+-- This is of course over simplified. We didn't consider connection+-- persistence. We should probably handle exceptions here to make sure the+-- sockets are safely closed even in case of error, e.g. using 'bracket'. We+-- could also use a timeout to avoid accumulating unused connections. But all+-- of that can be done on top of the basics shown above, or using the higher+-- level APIs.+module Network.HTTP.Listen+    ( -- * Basics+      Connection ()+    , Stream ()+    , prepareSocket+    , acceptConnection+    , openStream+    , receiveRequest+    , sendResponse+    , closeStream+    , closeConnection+    -- * Utilities+    , HttpVersion (..)+    , parseHttpVersion+    , HasHttpVersion (..)+    , httpVersion'+    , reqPersist+    , respPersist+    , persist+    , pipelined+    -- * Client Handling+    , Listener+    , listenerNull+    , listenerPrint+    , listenerPong+    , handleRequest+    , handleClient+    , handleClientBlocking+    -- * Running+    , run+    , runWithBlocking+    )+where++import           Control.Concurrent         (forkIO)+import           Control.Exception          (bracket)+import           Control.Monad              (forever, void, when)+import qualified Control.Monad.Catch        as C+import           Control.Monad.IO.Class+import qualified Data.ByteString.Lazy       as B+import qualified Data.ByteString.Lazy.Char8 as BC+import           Data.Char                  (digitToInt, isDigit, toLower)+import           Data.Maybe                 (fromMaybe)+import           Network.HTTP               hiding ( Connection+                                                   , openStream+                                                   , httpVersion+                                                   )+import           Network.Socket             hiding (Stream)+import qualified Network.Socket             as S (SocketType (Stream))+import           Network.Stream             (Result)++-------------------------------------------------------------------------------+-- Basics+-------------------------------------------------------------------------------++-- | Handle to a connection from an HTTP client (technically, a TCP client in+-- general).+data Connection = Connection+    { connSocket :: Socket+    , connAddr   :: SockAddr+    }++-- | A stream of data passing over a 'Connection'.+newtype Stream t = Stream { unStream :: HandleStream t }++-- Represent a boolean as an integer, 0 or 1.+pseudoBool :: Integral a => Bool -> a+pseudoBool False = 0+pseudoBool True  = 1++-- | Initialize a server socket and start listening to connections from+-- clients. After calling this, the returned socket can accept connections.+prepareSocket :: Int -> IO Socket+prepareSocket port = do+    let hints = defaultHints+            { addrSocketType = S.Stream+            , addrFlags      = [AI_PASSIVE, AI_ADDRCONFIG]+            }+    addrs <- getAddrInfo (Just hints) Nothing (Just $ show port)+    let addr = head addrs+    sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+    setSocketOption sock ReuseAddr (pseudoBool True)+    bind sock (addrAddress addr)+    listen sock maxListenQueue+    return sock++-- Get the address (for TCP, the IP address) of the client.+getHost :: SockAddr -> String+getHost = show++-- Get the port of the open connection with the client.+getPort :: SockAddr -> Int+getPort (SockAddrInet port _)      = fromIntegral port+getPort (SockAddrInet6 port _ _ _) = fromIntegral port+getPort (SockAddrUnix _)           = -1+getPort (SockAddrCan _)            = -1++-- | Given an initialized server socket, wait for a connection from a client.+-- It can be called repeatedly, in a loop, by the main server thread to accept+-- all the incoming connections.+acceptConnection :: Socket -> IO Connection+acceptConnection sock = do+    (csock, addr) <- accept sock+    return $ Connection csock addr++-- | Open a data stream over a connection. The stream holds the connection+-- state too, so after calling this function you don't need the 'Connection'+-- value anymore.+openStream :: HStream t => Connection -> IO (Stream t)+openStream (Connection csock addr) = do+    s <- openSocketStream (getHost addr) (getPort addr) csock+    return $ Stream s++-- | Read an HTTP request from an open stream.+receiveRequest :: HStream t => Stream t -> IO (Result (Request t))+receiveRequest = receiveHTTP . unStream++-- | Send an HTTP response back to the client through the open stream.+sendResponse :: HStream t => Stream t -> Response t -> IO ()+sendResponse = respondHTTP . unStream++-- | Close an open stream. This closes the connection with the client. Don't+-- try to send or receive anything from the stream after closing it.+closeStream :: HStream t => Stream t -> IO ()+closeStream = Network.HTTP.close . unStream++-- | Close an open connection. Use this only if you want to close the+-- connection before opening a stream. If you opened a stream over the+-- connection, use 'closeStream' to close it.+closeConnection :: Connection -> IO ()+closeConnection = Network.Socket.close . connSocket++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++-- | An HTTP protocol version.+data HttpVersion = HttpVersion Int Int deriving Eq++-- | A class for types which have an HTTP version. In other words, an HTTP+-- request or an HTTP response (but other instances are of course possible if+-- you need then for any reason).+class HasHttpVersion a where+    httpVersion :: a -> Maybe HttpVersion++-- | Parse an HTTP version string, e.g. @"HTTP/1.1"@, into an 'HttpVersion'+-- value. If the string isn't a valid version string, return 'Nothing'.+parseHttpVersion :: String -> Maybe HttpVersion+parseHttpVersion ['H', 'T', 'T', 'P', '/', ma, '.', mi] =+    if isDigit ma && isDigit mi+        then Just $ HttpVersion (digitToInt ma) (digitToInt mi)+        else Nothing+parseHttpVersion _ = Nothing++instance HasHttpVersion (Request t) where+    httpVersion r = getRequestVersion r >>= parseHttpVersion++instance HasHttpVersion (Response t) where+    httpVersion r = getResponseVersion r >>= parseHttpVersion++-- | This is like 'httpVersion', but returns a default version (currently HTTP+-- 1.0) if the no version is explicity specified.+httpVersion' :: HasHttpVersion r => r -> HttpVersion+httpVersion' r = fromMaybe (HttpVersion 1 0) $ httpVersion r++-- Get value of the Connection header.+getConnHeader :: HasHeaders r => r -> Maybe String+getConnHeader = findHeader HdrConnection++-- Like 'getConnHeader', but returns the value in lowercase.+getConnHeaderL :: HasHeaders r => r -> Maybe String+getConnHeaderL = fmap (map toLower) . getConnHeader++-- Whether the object specifies Close in its Connection header.+hasClose :: HasHeaders r => r -> Bool+hasClose = maybe False (== "close") . getConnHeaderL++-- Whether the object specifies Keep-Alive in its Connection header.+hasKeepAlive :: HasHeaders r => r -> Bool+hasKeepAlive = maybe False (== "keep-alive") . getConnHeaderL++-- Whether a persistent connection is indicated by the headers and the version.+isPersistent' :: HasHeaders r => r -> HttpVersion -> Bool+isPersistent' r version =+    if version == HttpVersion 1 1+        -- In HTTP 1.1 connections are persistent unless declared otherwise+        then not $ hasClose r+        -- Before HTTP 1.1 need to specify Keep-Alive+        else hasKeepAlive r++-- Whether a persistent connection is indicated.+isPersistent :: (HasHeaders r, HasHttpVersion r) => r -> Bool+isPersistent r = isPersistent' r (httpVersion' r)++-- | Check whether the request indicates the connection should be persistent.+reqPersist :: Request t -> Bool+reqPersist = isPersistent++-- | Check whether, assuming the request indicated a persistent connection, the+-- given response too indicates the connection should persist.+respPersist :: Response t -> Bool+respPersist = isPersistent++-- | Check whether, given the request and its response, the connection should+-- persist (i.e. kept open after the response it sent).+persist :: Request t -> Response t -> Bool+persist q s = reqPersist q && respPersist s++-- | Check whether the connection should be pipelined, i.e. whether the server+-- should allow the client to receive multiple requests without waiting for the+-- response every time.+pipelined :: Request t -> Bool+pipelined request =+    let version = httpVersion' request+    in  version == HttpVersion 1 1 && isPersistent' request version++-------------------------------------------------------------------------------+-- Handling Clients+-------------------------------------------------------------------------------++-- | An HTTP listener application. It gets an HTTP request with a body encoded+-- as type @t@, and returns an 'IO' action to run in reaction to the request.+-- The action can optionally return an HTTP response, which will be sent back+-- to the client.+type Listener t m = Request t -> m (Maybe (Response t))++-- | This listener does nothing. Perhaps it can be useful for benchmarking.+-- Anyway, it's here for completeness.+listenerNull :: Listener B.ByteString IO+listenerNull _request = return Nothing++-- | This listener prints the request details to the console (stdout).+listenerPrint :: Listener B.ByteString IO+listenerPrint request = print request >> return Nothing++-- | This listener sends the message "It works!", and the request body if any,+-- back to the client.+listenerPong :: Listener B.ByteString IO+listenerPong request = return . Just $ Response+    { rspCode    = (2, 0, 0)+    , rspReason  = "OK"+    , rspHeaders =+        [ Header HdrContentType "text/plain; charset=UTF-8"+        , Header HdrConnection  "close"+        ]+    , rspBody    = BC.pack "It works!\n\n" `B.append` rqBody request+    }++-- | Read a single request from the stream. If successful, apply the listener+-- function to it and send back a response if it returns one. Finally, return+-- whether the connection should persist ('True') or close ('False').+handleRequest :: (HStream t, MonadIO m) => Stream t -> Listener t m -> m Bool+handleRequest s listener = do+    result <- liftIO $ receiveRequest s+    case result of+        Left err -> do+            liftIO $ putStrLn $ "Error: " ++ show err+            return False+        Right request -> do+            mresp <- listener request+            case mresp of+                Just response -> do+                    liftIO $ sendResponse s response+                    return $+                        isPersistent request && isPersistent response+                Nothing -> return $ pipelined request++-- Repeatedly read and handle requests, until it's time to close the+-- connection.+requestLoop :: (HStream t, MonadIO m) => Stream t -> Listener t m -> m ()+requestLoop strm listener = loop strm+    where+    loop s = do+        proceed <- handleRequest s listener+        when proceed $ loop s++-- Manage a connection with a client.+handleClient' :: (HStream t, MonadIO m) => Connection -> Listener t m -> m ()+handleClient' conn listener = do+    s <- liftIO $ openStream conn+    requestLoop s listener+    liftIO $ closeStream s++-- | Wait for a connection from a client. When it arrives, fork to a new+-- thread. In that thread, receive HTTP requests and handle them using the+-- listener. Finally, close the connection.+handleClient :: HStream t+             => Socket+             -> Listener t IO+             -> IO ()+handleClient sock listener = do+    conn <- acceptConnection sock+    void $ forkIO $ handleClient' conn listener++-- | Like 'handleClient', but run everything in the current thread instead of+-- forking to a new one. Note that the listener itself could launch actions in+-- new threads.+handleClientBlocking :: (HStream t, MonadIO m)+                     => Socket+                     -> Listener t m+                     -> m ()+handleClientBlocking sock listener = do+    conn <- liftIO $ acceptConnection sock+    handleClient' conn listener++-------------------------------------------------------------------------------+-- Running a Listener+-------------------------------------------------------------------------------++-- | Run an HTTP listener. Open a server socket, listen to connections from+-- clients and handle them using the listener in separate worker threads.+run :: HStream t+    => Int+    -> Listener t IO+    -> IO ()+run port listener =+    bracket+        (prepareSocket port)+        Network.Socket.close+        (\ sock -> forever $ handleClient sock listener)++-- | Like 'run', but does everything in the current thread instead of forking+-- to a new one. Note that the listener itself could launch actions in new+-- threads.+runWithBlocking :: (HStream t, MonadIO m, C.MonadMask m)+                => Int+                -> Listener t m+                -> m ()+runWithBlocking port listener =+    C.bracket+        (liftIO $ prepareSocket port)+        (liftIO . Network.Socket.close)+        (\ sock -> forever $ handleClientBlocking sock listener)