{- 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)