{-# LANGUAGE CPP #-}
module Httpd
( Request, Response, Server
, mkResponse
, reqMethod, reqURI, reqHeaders, reqBody
, shed
#ifdef WARP_TESTS
, warp
#endif
)
where
import Control.Applicative
import Control.Arrow ( (***) )
import Control.DeepSeq
import Control.Monad
import Control.Monad.Trans ( liftIO )
import Data.ByteString as B ( empty, concat, length, ByteString )
import Data.ByteString.Char8 as BC ( pack, unpack )
import Data.ByteString.Lazy.Char8 as BLC ( pack )
#ifdef WARP_TESTS
import qualified Data.CaseInsensitive as CI ( mk, original )
#endif
import Data.Maybe ( fromJust )
import Network.URI ( URI, parseRelativeReference )
import Network.Socket
( getAddrInfo, AddrInfo, defaultHints, addrAddress, addrFamily
, addrFlags, addrSocketType, AddrInfoFlag(AI_PASSIVE), socket, Family(AF_UNSPEC,AF_INET6)
, defaultProtocol, SocketType(Stream), listen, setSocketOption
)
#ifdef WARP_TESTS
#if MIN_VERSION_network(2,4,0)
import Network.Socket ( bind )
#else
import Network.Socket ( bindSocket, Socket, SockAddr )
#endif
#endif
import qualified Network.Shed.Httpd as Shed
( Request, Response(Response), initServer
, reqMethod, reqURI, reqHeaders, reqBody
)
#ifdef WARP_TESTS
import qualified Data.Conduit.Lazy as Warp
( lazyConsume )
import qualified Network.HTTP.Types as Warp
( Status(..) )
import qualified Network.Wai as Warp
( Request(requestMethod, requestHeaders, rawPathInfo, requestBody)
, responseLBS )
import qualified Network.Wai.Handler.Warp as Warp
( runSettingsSocket, defaultSettings, setPort )
#endif
data Request = Request
{
reqMethod :: String,
reqURI :: URI,
reqHeaders :: [(String, String)],
reqBody :: String
}
data Response = Response
{
respStatus :: Int,
respHeaders :: [(String, String)],
respBody :: String
}
mkResponse :: Int -> [(String, String)] -> String -> Response
mkResponse = Response
type Server = Int -> (Request -> IO Response) -> IO ()
shed :: Server
shed port handler =
() <$ Shed.initServer
port
(liftM responseToShed . handler . requestFromShed)
where
responseToShed (Response status hdrs body) =
Shed.Response status hdrs body
chomp = reverse . strip '\r' . reverse
strip c (c':str) | c == c' = str
strip c str = str
requestFromShed request =
Request
{
reqMethod = Shed.reqMethod request,
reqURI = Shed.reqURI request,
reqHeaders = map (id *** chomp) $ Shed.reqHeaders request,
reqBody = Shed.reqBody request
}
#if !MIN_VERSION_bytestring(0,10,0)
instance NFData B.ByteString where
rnf = rnf . B.length
#endif
#ifdef WARP_TESTS
#if !MIN_VERSION_network(2,4,0)
bind :: Socket -> SockAddr -> IO ()
bind = bindSocket
#endif
warp :: Bool -> Server
warp ipv6 port handler = do
addrinfos <- getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream })
(Just $ if ipv6 then "::1" else "127.0.0.1")
(Just . show $ port)
case addrinfos of
[] -> fail "Couldn't obtain address information in warp"
(addri:_) -> do
sock <- socket (addrFamily addri) Stream defaultProtocol
bind sock (addrAddress addri)
listen sock 5
Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest -> do
request <- requestFromWarp warpRequest
response <- handler request
return (responseToWarp response)
where
responseToWarp (Response status hdrs body) =
Warp.responseLBS
(Warp.Status status B.empty)
(map headerToWarp hdrs)
(BLC.pack body)
headerToWarp (name, value) = (CI.mk (BC.pack name), BC.pack value)
headerFromWarp (name, value) =
(BC.unpack (CI.original name), BC.unpack value)
requestFromWarp request = do
body <- Warp.lazyConsume (Warp.requestBody request)
body `deepseq` return ()
return $
Request
{
reqMethod = BC.unpack (Warp.requestMethod request),
reqURI = fromJust . parseRelativeReference .
BC.unpack . Warp.rawPathInfo $
request,
reqHeaders = map headerFromWarp (Warp.requestHeaders request),
reqBody = BC.unpack (B.concat body)
}
#endif