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
146
147
148
149
150
151
152
153
154
155
156
157
158
|
{-# 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 qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy.Char8 as BLC
#ifdef WARP_TESTS
import qualified Data.CaseInsensitive as CI
#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, SocketOption(ReuseAddr)
)
#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
#if !MIN_VERSION_wai(3,0,0)
import qualified Data.Conduit.Lazy as Warp
#endif
import qualified Network.HTTP.Types as Warp
( Status(..) )
import qualified Network.Wai as Warp
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
setSocketOption sock ReuseAddr 1
bind sock (addrAddress addri)
listen sock 5
#if MIN_VERSION_wai(3,0,0)
Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest warpRespond -> do
request <- requestFromWarp warpRequest
response <- handler request
warpRespond (responseToWarp response)
#else
Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest -> do
request <- requestFromWarp warpRequest
response <- handler request
return (responseToWarp response)
#endif
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
#if MIN_VERSION_wai(3,0,1)
body <- fmap BLC.unpack $ Warp.strictRequestBody request
#else
body <- fmap BLC.unpack $ Warp.lazyRequestBody request
body `deepseq` return ()
#endif
return $
Request
{
reqMethod = BC.unpack (Warp.requestMethod request),
reqURI = fromJust . parseRelativeReference .
BC.unpack . Warp.rawPathInfo $
request,
reqHeaders = map headerFromWarp (Warp.requestHeaders request),
reqBody = body
}
#endif
|
