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