-
Notifications
You must be signed in to change notification settings - Fork 1
/
Request.hs
172 lines (155 loc) · 6.21 KB
/
Request.hs
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
159
160
161
162
163
164
165
166
167
168
169
170
171
172
{-# LANGUAGE FlexibleContexts, OverloadedStrings, TypeOperators,
ScopedTypeVariables, CPP #-}
module Network.Wai.Servlet.Request
( HttpServletRequest
, ServletRequest
, makeWaiRequest
, makeWaiRequestSettings
, requestHeaders
, requestMethod ) where
import qualified Network.Wai.Internal as W
import qualified Network.HTTP.Types as H
import Network.Socket (SockAddr (SockAddrInet,SockAddrInet6),
tupleToHostAddress,tupleToHostAddress6)
import Foreign.ForeignPtr (ForeignPtr,newForeignPtr,newForeignPtr_)
import Foreign.Marshal.Alloc (finalizerFree)
import Foreign.Ptr (Ptr)
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as BSInt (fromForeignPtr)
import qualified Data.ByteString.Char8 as BSChar (pack)
import qualified Data.ByteString.UTF8 as BSUTF8 (fromString)
import qualified Data.CaseInsensitive as CI
import Data.Word
import Data.List (intercalate)
import Data.Maybe (fromMaybe,catMaybes)
import Control.Monad (when)
import Java
import Java.Array
#ifdef INTEROP
import qualified Interop.Java.IO as JIO
#else
import qualified Java.IO as JIO
#endif
import Javax.Servlet
import Network.Wai.Servlet.Settings
doJavaWith :: (Class c) => c -> Java c a -> a
#ifdef PURE_JAVA_WITH
doJavaWith = pureJavaWith
#else
doJavaWith = unsafePerformJavaWith
#endif
foreign import java unsafe "@static network.wai.servlet.Utils.toByteArray"
toByteArray :: (is <: JIO.InputStream) => is -> JByteArray
foreign import java unsafe "@static network.wai.servlet.Utils.toByteBuffer"
toByteBuffer :: JByteArray -> Ptr Word8
foreign import java unsafe "@static network.wai.servlet.Utils.size"
size :: Ptr Word8 -> Int
makeWaiRequest :: HttpServletRequest -> W.Request
makeWaiRequest = makeWaiRequestSettings defaultSettings
makeWaiRequestSettings :: Settings -> HttpServletRequest
-> W.Request
makeWaiRequestSettings settings req = W.Request
{ W.requestMethod = requestMethod req
, W.httpVersion = httpVersion req
, W.rawPathInfo = rawPath
, W.rawQueryString = rawQuery
, W.requestHeaders = requestHeaders req
, W.isSecure = isSecureRequest req
, W.remoteHost = remoteHost req
, W.pathInfo = path
, W.queryString = query
, W.requestBody = requestBody req
, W.vault = mempty
, W.requestBodyLength = requestBodyLength req
, W.requestHeaderHost = header "Host"
, W.requestHeaderRange = header "Range"
, W.requestHeaderReferer = header "Referer"
, W.requestHeaderUserAgent = header "User-Agent" }
where encoding = getUriEncoding settings
rawPath = rawPathInfo encoding req
path = H.decodePathSegments $ pathInfo encoding req
rawQuery = queryString encoding req
query = H.parseQuery rawQuery
header name = fmap snd $ requestHeader req name
requestMethod :: (a <: HttpServletRequest) => a -> H.Method
requestMethod req = doJavaWith req $ do
method <- getMethod
return $ BSChar.pack method
httpVersion :: (a <: ServletRequest) => a -> H.HttpVersion
httpVersion req = doJavaWith req $ do
httpVer <- getProtocol
return $ case httpVer of
"HTTP/0.9" -> H.http09
"HTTP/1.0" -> H.http10
"HTTP/1.1" -> H.http11
"HTTP/2.0" -> H.http20
encode :: CharEncoding -> Maybe String -> B.ByteString
encode _ Nothing = B.empty
encode UTF8 (Just str) = BSUTF8.fromString str
encode ISO88591 (Just str) = BSChar.pack str
rawPathInfo :: (a <: HttpServletRequest) => CharEncoding -> a -> B.ByteString
rawPathInfo enc req = doJavaWith req $ do
path <- getPathInfo
case path of
Nothing -> return B.empty
Just str -> do
let segments = wordsWhen (=='/') str
return $ B.intercalate "/" $
map (H.urlEncode False . encode enc . Just) segments
pathInfo :: (a <: HttpServletRequest) => CharEncoding -> a -> B.ByteString
pathInfo enc req = doJavaWith req $ do
path <- getPathInfo
return $ encode enc path
queryString :: (a <: HttpServletRequest) => CharEncoding -> a -> B.ByteString
queryString enc req = doJavaWith req $ do
query <- getQueryString
return $ encode enc query
requestHeaders :: (a <: HttpServletRequest) => a -> H.RequestHeaders
requestHeaders req = doJavaWith req $ do
names <- getHeaderNames
return $ catMaybes $ map (requestHeader req . fromJString) $
fromJava names
requestHeader :: (a <: HttpServletRequest) => a -> String -> Maybe H.Header
requestHeader req name = doJavaWith req $ do
mjhdrs <- getHeaders name
return $ mjhdrs >>= f
where f jhdrs = if null hdrs then Nothing else Just (hdrn,hdrs')
where hdrs = map fromJString $ fromJava jhdrs
hdrs' = BSChar.pack $ intercalate "," hdrs
hdrn = CI.mk $ BSChar.pack name
isSecureRequest :: (a <: ServletRequest) => a -> Bool
isSecureRequest req = doJavaWith req $ isSecure
remoteHost :: (a <: ServletRequest) => a -> SockAddr
remoteHost req = doJavaWith req $ do
ipStr <- getRemoteAddr
portInt <- getRemotePort
let ip = wordsWhen (=='.') ipStr
ip' = if (length ip == 1) then wordsWhen (==':') ipStr else ip
port = fromIntegral portInt
return $ case length ip' of
4 -> let [ip1,ip2,ip3,ip4] = map read ip' in
SockAddrInet port $ tupleToHostAddress (ip1,ip2,ip3,ip4)
8 -> let [ip1,ip2,ip3,ip4,ip5,ip6,ip7,ip8] = map read ip' in
SockAddrInet6 port 0
(tupleToHostAddress6 (ip1,ip2,ip3,ip4,ip5,ip6,ip7,ip8)) 0
_ -> error $ "Error parsing ip: " ++ ipStr
wordsWhen :: (Char -> Bool) -> String -> [String]
wordsWhen p s = case dropWhile p s of
"" -> []
s' -> w : wordsWhen p s''
where (w, s'') = break p s'
requestBody :: (a <: ServletRequest) => a -> IO B.ByteString
requestBody req = do
is <- javaWith req getInputStream
let bytes = toByteArray is
ptr = toByteBuffer bytes
l <- javaWith bytes alength
fptr <- newForeignPtr_ ptr
-- fptr <- newForeignPtr finalizerFree ptr
-- TODO: There is a bug in the MemoryManager that prevents us from using this.
return $ if l == 0 then B.empty
else BSInt.fromForeignPtr fptr 0 l
requestBodyLength :: (a <: ServletRequest) => a -> W.RequestBodyLength
requestBodyLength req = doJavaWith req $ do
l <- getContentLength
return $ W.KnownLength (fromIntegral $ if l < 0 then 0 else l)