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