/
Base.hs
994 lines (847 loc) · 34.1 KB
/
Base.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
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : Network.HTTP.Base
-- Copyright : See LICENSE file
-- License : BSD
--
-- Maintainer : Ganesh Sittampalam <ganesh@earth.li>
-- Stability : experimental
-- Portability : non-portable (not tested)
--
-- Definitions of @Request@ and @Response@ types along with functions
-- for normalizing them. It is assumed to be an internal module; user
-- code should, if possible, import @Network.HTTP@ to access the functionality
-- that this module provides.
--
-- Additionally, the module exports internal functions for working with URLs,
-- and for handling the processing of requests and responses coming back.
--
-----------------------------------------------------------------------------
module Network.HTTP.Base
(
-- ** Constants
httpVersion -- :: String
-- ** HTTP
, Request(..)
, Response(..)
, RequestMethod(..)
, Request_String
, Response_String
, HTTPRequest
, HTTPResponse
-- ** URL Encoding
, urlEncode
, urlDecode
, urlEncodeVars
-- ** URI authority parsing
, URIAuthority(..)
, parseURIAuthority
-- internal
, uriToAuthorityString -- :: URI -> String
, uriAuthToString -- :: URIAuth -> String
, uriAuthPort -- :: Maybe URI -> URIAuth -> Int
, reqURIAuth -- :: Request ty -> URIAuth
, parseResponseHead -- :: [String] -> Result ResponseData
, parseRequestHead -- :: [String] -> Result RequestData
, ResponseNextStep(..)
, matchResponse
, ResponseData
, ResponseCode
, RequestData
, NormalizeRequestOptions(..)
, defaultNormalizeRequestOptions -- :: NormalizeRequestOptions ty
, RequestNormalizer
, normalizeRequest -- :: NormalizeRequestOptions ty -> Request ty -> Request ty
, splitRequestURI
, getAuth
, normalizeRequestURI
, normalizeHostHeader
, findConnClose
-- internal export (for the use by Network.HTTP.{Stream,ByteStream} )
, linearTransfer
, hopefulTransfer
, chunkedTransfer
, uglyDeathTransfer
, readTillEmpty1
, readTillEmpty2
, defaultGETRequest
, defaultGETRequest_
, mkRequest
, setRequestBody
, defaultUserAgent
, httpPackageVersion
, libUA {- backwards compatibility, will disappear..soon -}
, catchIO
, catchIO_
, responseParseError
, getRequestVersion
, getResponseVersion
, setRequestVersion
, setResponseVersion
, failHTTPS
) where
import Network.URI
( URI(uriAuthority, uriPath, uriScheme)
, URIAuth(URIAuth, uriUserInfo, uriRegName, uriPort)
, parseURIReference
)
import Control.Monad ( guard )
import Control.Monad.Error ()
import Data.Bits ( (.&.), (.|.), shiftL, shiftR )
import Data.Word ( Word8 )
import Data.Char ( digitToInt, intToDigit, toLower, isDigit,
isAscii, isAlphaNum, ord, chr )
import Data.List ( partition, find )
import Data.Maybe ( listToMaybe, fromMaybe )
import Numeric ( readHex )
import Network.Stream
import Network.BufferType ( BufferOp(..), BufferType(..) )
import Network.HTTP.Headers
import Network.HTTP.Utils ( trim, crlf, sp, readsOne )
import qualified Network.HTTP.Base64 as Base64 (encode)
import Text.Read.Lex (readDecP)
import Text.ParserCombinators.ReadP
( ReadP, readP_to_S, char, (<++), look, munch, munch1 )
import Control.Exception as Exception (catch, IOException)
import qualified Paths_HTTP as Self (version)
import Data.Version (showVersion)
-----------------------------------------------------------------
------------------ URI Authority parsing ------------------------
-----------------------------------------------------------------
data URIAuthority = URIAuthority { user :: Maybe String,
password :: Maybe String,
host :: String,
port :: Maybe Int
} deriving (Eq,Show)
-- | Parse the authority part of a URL.
--
-- > RFC 1732, section 3.1:
-- >
-- > //<user>:<password>@<host>:<port>/<url-path>
-- > Some or all of the parts "<user>:<password>@", ":<password>",
-- > ":<port>", and "/<url-path>" may be excluded.
parseURIAuthority :: String -> Maybe URIAuthority
parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s))
pURIAuthority :: ReadP URIAuthority
pURIAuthority = do
(u,pw) <- (pUserInfo `before` char '@')
<++ return (Nothing, Nothing)
h <- rfc2732host <++ munch (/=':')
p <- orNothing (char ':' >> readDecP)
look >>= guard . null
return URIAuthority{ user=u, password=pw, host=h, port=p }
-- RFC2732 adds support for '[literal-ipv6-address]' in the host part of a URL
rfc2732host :: ReadP String
rfc2732host = do
_ <- char '['
res <- munch1 (/=']')
_ <- char ']'
return res
pUserInfo :: ReadP (Maybe String, Maybe String)
pUserInfo = do
u <- orNothing (munch (`notElem` ":@"))
p <- orNothing (char ':' >> munch (/='@'))
return (u,p)
before :: Monad m => m a -> m b -> m a
before a b = a >>= \x -> b >> return x
orNothing :: ReadP a -> ReadP (Maybe a)
orNothing p = fmap Just p <++ return Nothing
-- This function duplicates old Network.URI.authority behaviour.
uriToAuthorityString :: URI -> String
uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u)
uriAuthToString :: URIAuth -> String
uriAuthToString ua =
concat [ uriUserInfo ua
, uriRegName ua
, uriPort ua
]
uriAuthPort :: Maybe URI -> URIAuth -> Int
uriAuthPort mbURI u =
case uriPort u of
(':':s) -> readsOne id (default_port mbURI) s
_ -> default_port mbURI
where
default_port Nothing = default_http
default_port (Just url) =
case map toLower $ uriScheme url of
"http:" -> default_http
"https:" -> default_https
-- todo: refine
_ -> default_http
default_http = 80
default_https = 443
failHTTPS :: Monad m => URI -> m ()
failHTTPS uri
| map toLower (uriScheme uri) == "https:" = fail "https not supported"
| otherwise = return ()
-- Fish out the authority from a possibly normalized Request, i.e.,
-- the information may either be in the request's URI or inside
-- the Host: header.
reqURIAuth :: Request ty -> URIAuth
reqURIAuth req =
case uriAuthority (rqURI req) of
Just ua -> ua
_ -> case lookupHeader HdrHost (rqHeaders req) of
Nothing -> error ("reqURIAuth: no URI authority for: " ++ show req)
Just h ->
case toHostPort h of
(ht,p) -> URIAuth { uriUserInfo = ""
, uriRegName = ht
, uriPort = p
}
where
-- Note: just in case you're wondering..the convention is to include the ':'
-- in the port part..
toHostPort h = break (==':') h
-----------------------------------------------------------------
------------------ HTTP Messages --------------------------------
-----------------------------------------------------------------
-- Protocol version
httpVersion :: String
httpVersion = "HTTP/1.1"
-- | The HTTP request method, to be used in the 'Request' object.
-- We are missing a few of the stranger methods, but these are
-- not really necessary until we add full TLS.
data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE | CONNECT | Custom String
deriving(Eq)
instance Show RequestMethod where
show x =
case x of
HEAD -> "HEAD"
PUT -> "PUT"
GET -> "GET"
POST -> "POST"
DELETE -> "DELETE"
OPTIONS -> "OPTIONS"
TRACE -> "TRACE"
CONNECT -> "CONNECT"
Custom c -> c
rqMethodMap :: [(String, RequestMethod)]
rqMethodMap = [("HEAD", HEAD),
("PUT", PUT),
("GET", GET),
("POST", POST),
("DELETE", DELETE),
("OPTIONS", OPTIONS),
("TRACE", TRACE),
("CONNECT", CONNECT)]
--
-- for backwards-ish compatibility; suggest
-- migrating to new Req/Resp by adding type param.
--
type Request_String = Request String
type Response_String = Response String
-- Hmm..I really want to use these for the record
-- type, but it will upset codebases wanting to
-- migrate (and live with using pre-HTTPbis versions.)
type HTTPRequest a = Request a
type HTTPResponse a = Response a
-- | An HTTP Request.
-- The 'Show' instance of this type is used for message serialisation,
-- which means no body data is output.
data Request a =
Request { rqURI :: URI -- ^ might need changing in future
-- 1) to support '*' uri in OPTIONS request
-- 2) transparent support for both relative
-- & absolute uris, although this should
-- already work (leave scheme & host parts empty).
, rqMethod :: RequestMethod
, rqHeaders :: [Header]
, rqBody :: a
}
-- Notice that request body is not included,
-- this show function is used to serialise
-- a request for the transport link, we send
-- the body separately where possible.
instance Show (Request a) where
show req@(Request u m h _) =
show m ++ sp ++ alt_uri ++ sp ++ ver ++ crlf
++ foldr (++) [] (map show (dropHttpVersion h)) ++ crlf
where
ver = fromMaybe httpVersion (getRequestVersion req)
alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/'
then u { uriPath = '/' : uriPath u }
else u
instance HasHeaders (Request a) where
getHeaders = rqHeaders
setHeaders rq hdrs = rq { rqHeaders=hdrs }
-- | For easy pattern matching, HTTP response codes @xyz@ are
-- represented as @(x,y,z)@.
type ResponseCode = (Int,Int,Int)
-- | @ResponseData@ contains the head of a response payload;
-- HTTP response code, accompanying text description + header
-- fields.
type ResponseData = (ResponseCode,String,[Header])
-- | @RequestData@ contains the head of a HTTP request; method,
-- its URL along with the auxillary/supporting header data.
type RequestData = (RequestMethod,URI,[Header])
-- | An HTTP Response.
-- The 'Show' instance of this type is used for message serialisation,
-- which means no body data is output, additionally the output will
-- show an HTTP version of 1.1 instead of the actual version returned
-- by a server.
data Response a =
Response { rspCode :: ResponseCode
, rspReason :: String
, rspHeaders :: [Header]
, rspBody :: a
}
-- This is an invalid representation of a received response,
-- since we have made the assumption that all responses are HTTP/1.1
instance Show (Response a) where
show rsp@(Response (a,b,c) reason headers _) =
ver ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf
++ foldr (++) [] (map show (dropHttpVersion headers)) ++ crlf
where
ver = fromMaybe httpVersion (getResponseVersion rsp)
instance HasHeaders (Response a) where
getHeaders = rspHeaders
setHeaders rsp hdrs = rsp { rspHeaders=hdrs }
------------------------------------------------------------------
------------------ Request Building ------------------------------
------------------------------------------------------------------
-- | Deprecated. Use 'defaultUserAgent'
libUA :: String
libUA = "hs-HTTP-4000.0.9"
{-# DEPRECATED libUA "Use defaultUserAgent instead (but note the user agent name change)" #-}
-- | A default user agent string. The string is @\"haskell-HTTP/$version\"@
-- where @$version@ is the version of this HTTP package.
--
defaultUserAgent :: String
defaultUserAgent = "haskell-HTTP/" ++ httpPackageVersion
-- | The version of this HTTP package as a string, e.g. @\"4000.1.2\"@. This
-- may be useful to include in a user agent string so that you can determine
-- from server logs what version of this package HTTP clients are using.
-- This can be useful for tracking down HTTP compatibility quirks.
--
httpPackageVersion :: String
httpPackageVersion = showVersion Self.version
defaultGETRequest :: URI -> Request_String
defaultGETRequest uri = defaultGETRequest_ uri
defaultGETRequest_ :: BufferType a => URI -> Request a
defaultGETRequest_ uri = mkRequest GET uri
-- | 'mkRequest method uri' constructs a well formed
-- request for the given HTTP method and URI. It does not
-- normalize the URI for the request _nor_ add the required
-- Host: header. That is done either explicitly by the user
-- or when requests are normalized prior to transmission.
mkRequest :: BufferType ty => RequestMethod -> URI -> Request ty
mkRequest meth uri = req
where
req =
Request { rqURI = uri
, rqBody = empty
, rqHeaders = [ Header HdrContentLength "0"
, Header HdrUserAgent defaultUserAgent
]
, rqMethod = meth
}
empty = buf_empty (toBufOps req)
-- set rqBody, Content-Type and Content-Length headers.
setRequestBody :: Request_String -> (String, String) -> Request_String
setRequestBody req (typ, body) = req' { rqBody=body }
where
req' = replaceHeader HdrContentType typ .
replaceHeader HdrContentLength (show $ length body) $
req
{-
-- stub out the user info.
updAuth = fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri)
withHost =
case uriToAuthorityString uri{uriAuthority=updAuth} of
"" -> id
h -> ((Header HdrHost h):)
uri_req
| forProxy = uri
| otherwise = snd (splitRequestURI uri)
-}
toBufOps :: BufferType a => Request a -> BufferOp a
toBufOps _ = bufferOps
-----------------------------------------------------------------
------------------ Parsing --------------------------------------
-----------------------------------------------------------------
-- Parsing a request
parseRequestHead :: [String] -> Result RequestData
parseRequestHead [] = Left ErrorClosed
parseRequestHead (com:hdrs) = do
(version,rqm,uri) <- requestCommand com (words com)
hdrs' <- parseHeaders hdrs
return (rqm,uri,withVer version hdrs')
where
withVer [] hs = hs
withVer (h:_) hs = withVersion h hs
requestCommand l _yes@(rqm:uri:version) =
case (parseURIReference uri, lookup rqm rqMethodMap) of
(Just u, Just r) -> return (version,r,u)
(Just u, Nothing) -> return (version,Custom rqm,u)
_ -> parse_err l
requestCommand l _
| null l = failWith ErrorClosed
| otherwise = parse_err l
parse_err l = responseParseError "parseRequestHead"
("Request command line parse failure: " ++ l)
-- Parsing a response
parseResponseHead :: [String] -> Result ResponseData
parseResponseHead [] = failWith ErrorClosed
parseResponseHead (sts:hdrs) = do
(version,code,reason) <- responseStatus sts (words sts)
hdrs' <- parseHeaders hdrs
return (code,reason, withVersion version hdrs')
where
responseStatus _l _yes@(version:code:reason) =
return (version,match code,concatMap (++" ") reason)
responseStatus l _no
| null l = failWith ErrorClosed -- an assumption
| otherwise = parse_err l
parse_err l =
responseParseError
"parseResponseHead"
("Response status line parse failure: " ++ l)
match [a,b,c] = (digitToInt a,
digitToInt b,
digitToInt c)
match _ = (-1,-1,-1) -- will create appropriate behaviour
-- To avoid changing the @RequestData@ and @ResponseData@ types
-- just for this (and the upstream backwards compat. woes that
-- will result in), encode version info as a custom header.
-- Used by 'parseResponseData' and 'parseRequestData'.
--
-- Note: the Request and Response types do not currently represent
-- the version info explicitly in their record types. You have to use
-- {get,set}{Request,Response}Version for that.
withVersion :: String -> [Header] -> [Header]
withVersion v hs
| v == httpVersion = hs -- don't bother adding it if the default.
| otherwise = (Header (HdrCustom "X-HTTP-Version") v) : hs
-- | @getRequestVersion req@ returns the HTTP protocol version of
-- the request @req@. If @Nothing@, the default 'httpVersion' can be assumed.
getRequestVersion :: Request a -> Maybe String
getRequestVersion r = getHttpVersion r
-- | @setRequestVersion v req@ returns a new request, identical to
-- @req@, but with its HTTP version set to @v@.
setRequestVersion :: String -> Request a -> Request a
setRequestVersion s r = setHttpVersion r s
-- | @getResponseVersion rsp@ returns the HTTP protocol version of
-- the response @rsp@. If @Nothing@, the default 'httpVersion' can be
-- assumed.
getResponseVersion :: Response a -> Maybe String
getResponseVersion r = getHttpVersion r
-- | @setResponseVersion v rsp@ returns a new response, identical to
-- @rsp@, but with its HTTP version set to @v@.
setResponseVersion :: String -> Response a -> Response a
setResponseVersion s r = setHttpVersion r s
-- internal functions for accessing HTTP-version info in
-- requests and responses. Not exported as it exposes ho
-- version info is represented internally.
getHttpVersion :: HasHeaders a => a -> Maybe String
getHttpVersion r =
fmap toVersion $
find isHttpVersion $
getHeaders r
where
toVersion (Header _ x) = x
setHttpVersion :: HasHeaders a => a -> String -> a
setHttpVersion r v =
setHeaders r $
withVersion v $
dropHttpVersion $
getHeaders r
dropHttpVersion :: [Header] -> [Header]
dropHttpVersion hs = filter (not.isHttpVersion) hs
isHttpVersion :: Header -> Bool
isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = True
isHttpVersion _ = False
-----------------------------------------------------------------
------------------ HTTP Send / Recv ----------------------------------
-----------------------------------------------------------------
data ResponseNextStep
= Continue
| Retry
| Done
| ExpectEntity
| DieHorribly String
matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep
matchResponse rqst rsp =
case rsp of
(1,0,0) -> Continue
(1,0,1) -> Done -- upgrade to TLS
(1,_,_) -> Continue -- default
(2,0,4) -> Done
(2,0,5) -> Done
(2,_,_) -> ans
(3,0,4) -> Done
(3,0,5) -> Done
(3,_,_) -> ans
(4,1,7) -> Retry -- Expectation failed
(4,_,_) -> ans
(5,_,_) -> ans
(a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised")
where
ans | rqst == HEAD = Done
| otherwise = ExpectEntity
-----------------------------------------------------------------
------------------ A little friendly funtionality ---------------
-----------------------------------------------------------------
{-
I had a quick look around but couldn't find any RFC about
the encoding of data on the query string. I did find an
IETF memo, however, so this is how I justify the urlEncode
and urlDecode methods.
Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org)
Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved.
Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`"
URI delims: "<" | ">" | "#" | "%" | <">
Unallowed ASCII: <US-ASCII coded characters 00-1F and 7F hexadecimal>
<US-ASCII coded character 20 hexadecimal>
Also unallowed: any non-us-ascii character
Escape method: char -> '%' a b where a, b :: Hex digits
-}
replacement_character :: Char
replacement_character = '\xfffd'
-- | Encode a single Haskell Char to a list of Word8 values, in UTF8 format.
--
-- Shamelessly stolen from utf-8string-0.3.7
encodeChar :: Char -> [Word8]
encodeChar = map fromIntegral . go . ord
where
go oc
| oc <= 0x7f = [oc]
| oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6)
, 0x80 + oc .&. 0x3f
]
| oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12)
, 0x80 + ((oc `shiftR` 6) .&. 0x3f)
, 0x80 + oc .&. 0x3f
]
| otherwise = [ 0xf0 + (oc `shiftR` 18)
, 0x80 + ((oc `shiftR` 12) .&. 0x3f)
, 0x80 + ((oc `shiftR` 6) .&. 0x3f)
, 0x80 + oc .&. 0x3f
]
-- | Decode a UTF8 string packed into a list of Word8 values, directly to String
--
-- Shamelessly stolen from utf-8string-0.3.7
decode :: [Word8] -> String
decode [ ] = ""
decode (c:cs)
| c < 0x80 = chr (fromEnum c) : decode cs
| c < 0xc0 = replacement_character : decode cs
| c < 0xe0 = multi1
| c < 0xf0 = multi_byte 2 0xf 0x800
| c < 0xf8 = multi_byte 3 0x7 0x10000
| c < 0xfc = multi_byte 4 0x3 0x200000
| c < 0xfe = multi_byte 5 0x1 0x4000000
| otherwise = replacement_character : decode cs
where
multi1 = case cs of
c1 : ds | c1 .&. 0xc0 == 0x80 ->
let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f)
in if d >= 0x000080 then toEnum d : decode ds
else replacement_character : decode ds
_ -> replacement_character : decode cs
multi_byte :: Int -> Word8 -> Int -> [Char]
multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask))
where
aux 0 rs acc
| overlong <= acc && acc <= 0x10ffff &&
(acc < 0xd800 || 0xdfff < acc) &&
(acc < 0xfffe || 0xffff < acc) = chr acc : decode rs
| otherwise = replacement_character : decode rs
aux n (r:rs) acc
| r .&. 0xc0 == 0x80 = aux (n-1) rs
$ shiftL acc 6 .|. fromEnum (r .&. 0x3f)
aux _ rs _ = replacement_character : decode rs
-- This function is a bit funny because potentially the input String could contain some actual Unicode
-- characters (though this shouldn't happen for most use cases), so we have to preserve those characters
-- while simultaneously decoding any UTF-8 data
urlDecode :: String -> String
urlDecode = go []
where
go bs ('%':a:b:rest) = go (fromIntegral (16 * digitToInt a + digitToInt b) : bs) rest
go bs (h:t) | fromEnum h < 256 = go (fromIntegral (fromEnum h) : bs) t -- Treat ASCII as just another byte of UTF-8
go [] [] = []
go [] (h:t) = h : go [] t -- h >= 256, so can't be part of any UTF-8 byte sequence
go bs rest = decode (reverse bs) ++ go [] rest
urlEncode :: String -> String
urlEncode [] = []
urlEncode (ch:t)
| (isAscii ch && isAlphaNum ch) || ch `elem` "-_.~" = ch : urlEncode t
| not (isAscii ch) = foldr escape (urlEncode t) (encodeChar ch)
| otherwise = escape (fromIntegral (fromEnum ch)) (urlEncode t)
where
escape b rs = '%':showH (b `div` 16) (showH (b `mod` 16) rs)
showH :: Word8 -> String -> String
showH x xs
| x <= 9 = to (o_0 + x) : xs
| otherwise = to (o_A + (x-10)) : xs
where
to = toEnum . fromIntegral
fro = fromIntegral . fromEnum
o_0 = fro '0'
o_A = fro 'A'
-- Encode form variables, useable in either the
-- query part of a URI, or the body of a POST request.
-- I have no source for this information except experience,
-- this sort of encoding worked fine in CGI programming.
urlEncodeVars :: [(String,String)] -> String
urlEncodeVars ((n,v):t) =
let (same,diff) = partition ((==n) . fst) t
in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same)
++ urlEncodeRest diff
where urlEncodeRest [] = []
urlEncodeRest diff = '&' : urlEncodeVars diff
urlEncodeVars [] = []
-- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@
-- header.
getAuth :: Monad m => Request ty -> m URIAuthority
getAuth r =
-- ToDo: verify that Network.URI functionality doesn't take care of this (now.)
case parseURIAuthority auth of
Just x -> return x
Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'"
where
auth = maybe (uriToAuthorityString uri) id (findHeader HdrHost r)
uri = rqURI r
{-# DEPRECATED normalizeRequestURI "Please use Network.HTTP.Base.normalizeRequest instead" #-}
normalizeRequestURI :: Bool{-do close-} -> {-URI-}String -> Request ty -> Request ty
normalizeRequestURI doClose h r =
(if doClose then replaceHeader HdrConnection "close" else id) $
insertHeaderIfMissing HdrHost h $
r { rqURI = (rqURI r){ uriScheme = ""
, uriAuthority = Nothing
}}
-- | @NormalizeRequestOptions@ brings together the various defaulting\/normalization options
-- over 'Request's. Use 'defaultNormalizeRequestOptions' for the standard selection of option
data NormalizeRequestOptions ty
= NormalizeRequestOptions
{ normDoClose :: Bool
, normForProxy :: Bool
, normUserAgent :: Maybe String
, normCustoms :: [RequestNormalizer ty]
}
-- | @RequestNormalizer@ is the shape of a (pure) function that rewrites
-- a request into some normalized form.
type RequestNormalizer ty = NormalizeRequestOptions ty -> Request ty -> Request ty
defaultNormalizeRequestOptions :: NormalizeRequestOptions ty
defaultNormalizeRequestOptions = NormalizeRequestOptions
{ normDoClose = False
, normForProxy = False
, normUserAgent = Just defaultUserAgent
, normCustoms = []
}
-- | @normalizeRequest opts req@ is the entry point to use to normalize your
-- request prior to transmission (or other use.) Normalization is controlled
-- via the @NormalizeRequestOptions@ record.
normalizeRequest :: NormalizeRequestOptions ty
-> Request ty
-> Request ty
normalizeRequest opts req = foldr (\ f -> f opts) req normalizers
where
--normalizers :: [RequestNormalizer ty]
normalizers =
( normalizeHostURI
: normalizeBasicAuth
: normalizeConnectionClose
: normalizeUserAgent
: normCustoms opts
)
-- | @normalizeUserAgent ua x req@ augments the request @req@ with
-- a @User-Agent: ua@ header if @req@ doesn't already have a
-- a @User-Agent:@ set.
normalizeUserAgent :: RequestNormalizer ty
normalizeUserAgent opts req =
case normUserAgent opts of
Nothing -> req
Just ua ->
case findHeader HdrUserAgent req of
Just u | u /= defaultUserAgent -> req
_ -> replaceHeader HdrUserAgent ua req
-- | @normalizeConnectionClose opts req@ sets the header @Connection: close@
-- to indicate one-shot behavior iff @normDoClose@ is @True@. i.e., it then
-- _replaces_ any an existing @Connection:@ header in @req@.
normalizeConnectionClose :: RequestNormalizer ty
normalizeConnectionClose opts req
| normDoClose opts = replaceHeader HdrConnection "close" req
| otherwise = req
-- | @normalizeBasicAuth opts req@ sets the header @Authorization: Basic...@
-- if the "user:pass@" part is present in the "http://user:pass@host/path"
-- of the URI. If Authorization header was present already it is not replaced.
normalizeBasicAuth :: RequestNormalizer ty
normalizeBasicAuth _ req =
case getAuth req of
Just uriauth ->
case (user uriauth, password uriauth) of
(Just u, Just p) ->
insertHeaderIfMissing HdrAuthorization astr req
where
astr = "Basic " ++ base64encode (u ++ ":" ++ p)
base64encode = Base64.encode . stringToOctets :: String -> String
stringToOctets = map (fromIntegral . fromEnum) :: String -> [Word8]
(_, _) -> req
Nothing ->req
-- | @normalizeHostURI forProxy req@ rewrites your request to have it
-- follow the expected formats by the receiving party (proxy or server.)
--
normalizeHostURI :: RequestNormalizer ty
normalizeHostURI opts req =
case splitRequestURI uri of
("",_uri_abs)
| forProxy ->
case findHeader HdrHost req of
Nothing -> req -- no host/authority in sight..not much we can do.
Just h -> req{rqURI=uri{ uriAuthority=Just URIAuth{uriUserInfo="", uriRegName=hst, uriPort=pNum}
, uriScheme=if (null (uriScheme uri)) then "http" else uriScheme uri
}}
where
hst = case span (/='@') user_hst of
(as,'@':bs) ->
case span (/=':') as of
(_,_:_) -> bs
_ -> user_hst
_ -> user_hst
(user_hst, pNum) =
case span isDigit (reverse h) of
(ds,':':bs) -> (reverse bs, ':':reverse ds)
_ -> (h,"")
| otherwise ->
case findHeader HdrHost req of
Nothing -> req -- no host/authority in sight..not much we can do...complain?
Just{} -> req
(h,uri_abs)
| forProxy -> insertHeaderIfMissing HdrHost h req
| otherwise -> replaceHeader HdrHost h req{rqURI=uri_abs} -- Note: _not_ stubbing out user:pass
where
uri0 = rqURI req
-- stub out the user:pass
uri = uri0{uriAuthority=fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri0)}
forProxy = normForProxy opts
{- Comments re: above rewriting:
RFC 2616, section 5.1.2:
"The most common form of Request-URI is that used to identify a
resource on an origin server or gateway. In this case the absolute
path of the URI MUST be transmitted (see section 3.2.1, abs_path) as
the Request-URI, and the network location of the URI (authority) MUST
be transmitted in a Host header field."
We assume that this is the case, so we take the host name from
the Host header if there is one, otherwise from the request-URI.
Then we make the request-URI an abs_path and make sure that there
is a Host header.
-}
splitRequestURI :: URI -> ({-authority-}String, URI)
splitRequestURI uri = (uriToAuthorityString uri, uri{uriScheme="", uriAuthority=Nothing})
-- Adds a Host header if one is NOT ALREADY PRESENT..
{-# DEPRECATED normalizeHostHeader "Please use Network.HTTP.Base.normalizeRequest instead" #-}
normalizeHostHeader :: Request ty -> Request ty
normalizeHostHeader rq =
insertHeaderIfMissing HdrHost
(uriToAuthorityString $ rqURI rq)
rq
-- Looks for a "Connection" header with the value "close".
-- Returns True when this is found.
findConnClose :: [Header] -> Bool
findConnClose hdrs =
maybe False
(\ x -> map toLower (trim x) == "close")
(lookupHeader HdrConnection hdrs)
-- | Used when we know exactly how many bytes to expect.
linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a))
linearTransfer readBlk n = fmapE (\str -> Right ([],str)) (readBlk n)
-- | Used when nothing about data is known,
-- Unfortunately waiting for a socket closure
-- causes bad behaviour. Here we just
-- take data once and give up the rest.
hopefulTransfer :: BufferOp a
-> IO (Result a)
-> [a]
-> IO (Result ([Header],a))
hopefulTransfer bufOps readL strs
= readL >>=
either (\v -> return $ Left v)
(\more -> if (buf_isEmpty bufOps more)
then return (Right ([], buf_concat bufOps $ reverse strs))
else hopefulTransfer bufOps readL (more:strs))
-- | A necessary feature of HTTP\/1.1
-- Also the only transfer variety likely to
-- return any footers.
chunkedTransfer :: BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> IO (Result ([Header], a))
chunkedTransfer bufOps readL readBlk = chunkedTransferC bufOps readL readBlk [] 0
chunkedTransferC :: BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
chunkedTransferC bufOps readL readBlk acc n = do
v <- readL
case v of
Left e -> return (Left e)
Right line
| size == 0 ->
-- last chunk read; look for trailing headers..
fmapE (\ strs -> do
ftrs <- parseHeaders (map (buf_toStr bufOps) strs)
-- insert (computed) Content-Length header.
let ftrs' = Header HdrContentLength (show n) : ftrs
return (ftrs',buf_concat bufOps (reverse acc)))
(readTillEmpty2 bufOps readL [])
| otherwise -> do
some <- readBlk size
case some of
Left e -> return (Left e)
Right cdata -> do
_ <- readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.?
chunkedTransferC bufOps readL readBlk (cdata:acc) (n+size)
where
size
| buf_isEmpty bufOps line = 0
| otherwise =
case readHex (buf_toStr bufOps line) of
(hx,_):_ -> hx
_ -> 0
-- | Maybe in the future we will have a sensible thing
-- to do here, at that time we might want to change
-- the name.
uglyDeathTransfer :: String -> IO (Result ([Header],a))
uglyDeathTransfer loc = return (responseParseError loc "Unknown Transfer-Encoding")
-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)
readTillEmpty1 :: BufferOp a
-> IO (Result a)
-> IO (Result [a])
readTillEmpty1 bufOps readL =
readL >>=
either (return . Left)
(\ s ->
if buf_isLineTerm bufOps s
then readTillEmpty1 bufOps readL
else readTillEmpty2 bufOps readL [s])
-- | Read lines until an empty line (CRLF),
-- also accepts a connection close as end of
-- input, which is not an HTTP\/1.1 compliant
-- thing to do - so probably indicates an
-- error condition.
readTillEmpty2 :: BufferOp a
-> IO (Result a)
-> [a]
-> IO (Result [a])
readTillEmpty2 bufOps readL list =
readL >>=
either (return . Left)
(\ s ->
if buf_isLineTerm bufOps s || buf_isEmpty bufOps s
then return (Right $ reverse (s:list))
else readTillEmpty2 bufOps readL (s:list))
--
-- Misc
--
-- | @catchIO a h@ handles IO action exceptions throughout codebase; version-specific
-- tweaks better go here.
catchIO :: IO a -> (IOException -> IO a) -> IO a
catchIO a h = Exception.catch a h
catchIO_ :: IO a -> IO a -> IO a
catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h)
responseParseError :: String -> String -> Result a
responseParseError loc v = failWith (ErrorParse (loc ++ ' ':v))