1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
{-# 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
|
