1 (* Copyright (C
) 2009 Matthew Fluet
.
2 * Copyright (C
) 1999-2006 Henry Cejtin
, Matthew Fluet
, Suresh
3 * Jagannathan
, and Stephen Weeks
.
5 * MLton is released under a BSD
-style license
.
6 * See the file MLton
-LICENSE for details
.
17 val UPALPHA
= isChar
Char.isUpper
18 val LOALPHA
= isChar
Char.isLower
19 val ALPHA
= isChar
Char.isAlpha
20 val DIGIT
= isChar
Char.isDigit
21 val CTL
= isChar
Char.isCntrl
26 val CRLF
= string "\r\n"
27 (* #
"\n" is not
in the spec for CRLF
, but Netscape generates it
. *)
28 val CRLF
= or
[CRLF
, char #
"\n"]
29 val LWS
= seq
[optional CRLF
, oneOrMore (or
[SP
, HT
])]
30 val TEXT
= isNotChar
Char.isCntrl
31 val HEX
= isChar
Char.isHexDigit
32 val separatorChars
= "()<>@,;:\\\"/ []?= {} \t"
33 val separators
= oneOf separatorChars
39 andalso not (Char.isCntrl c
)
40 andalso not (String.contains (separatorChars
, c
)))))
41 val dquote
= char
Char.dquote
42 val qdtext
= isChar (fn c
=>
44 andalso not (c
= Char.dquote
))
45 val quotedpair
= seq
[char #
"\\", CHAR
]
47 seq
[dquote
, star (or
[qdtext
, quotedpair
]), dquote
]
51 andalso not (c
= #
"(")
52 andalso not (c
= #
")"))
55 * star (or
[ctext
, quoted
-pair
, comment
]),
58 val major
' = Save
.new ()
59 val minor
' = Save
.new ()
62 save (oneOrMore DIGIT
, major
'),
64 save (oneOrMore DIGIT
, minor
')]
65 val fieldname
' = Save
.new ()
67 (* fieldname should just be token
, but the stupid Microsoft server
68 * includes spaces
in its
"Content Location" field
, so we need to accept
69 * more
. The easies thing is just to take anything but a
":".
71 (* save (token
, fieldname
') *)
72 save (star (notChar #
":"), fieldname
')
74 (* fieldcontent should just be TEXT
, but nytimes stores control
75 * characters
in cookies
, and thus
, need to allow more
.
78 isChar (fn c
=> c
>= #
" ")
79 val fieldvalue
' = Save
.new ()
80 val fieldvalue
= star (or
[fieldcontent
, LWS
])
84 compileDFA (seq
[fieldname
, char #
":",
85 save (optional fieldvalue
, fieldvalue
'),
87 val method
' = Save
.new ()
88 val method
= save (token
, method
')
89 val star
' = Save
.new ()
90 val absoluteUrl
' = Save
.new ()
91 val absPath
' = Save
.new ()
92 val authority
' = Save
.new ()
93 val query
' = Save
.new ()
96 in or
[save (char #
"*", star
'),
97 save (absoluteUrl
, absoluteUrl
'),
98 seq
[save (absPath
, absPath
'),
99 optional (seq
[char #
"?", save (query
, query
')])],
100 save (authority
, authority
')]
105 compileDFA (seq
[method
, SP
, requestUrl
, SP
, version
, CRLF
]))
107 Promise
.lazy (fn () => compileDFA (oneOrMore DIGIT
))
108 val status
' = Save
.new ()
109 val status
= save (seq
[DIGIT
, DIGIT
, DIGIT
], status
')
111 star (isChar (fn c
=>
112 Char.isPrint c
andalso c
<> #
"\r" andalso c
<> #
"\n"))
115 (fn () => compileDFA (seq
[version
, SP
, status
, SP
, reason
, CRLF
]))
123 | Extension
of string
132 [(Connect
, "CONNECT"),
136 (Options
, "OPTIONS"),
142 case List.peek (map
, fn (_
, s
') => s
= s
') of
149 | _
=> #
2 (valOf (List.peek (map
, fn (h
', _
) => h
= h
')))
151 val layout
= Layout
.str
o toString
156 datatype t
= T
of {major
: int,
159 fun toString (T
{major
, minor
}) =
165 val layout
= Layout
.str
o toString
167 val v10
= T
{major
= 1, minor
= 0}
168 val v11
= T
{major
= 1, minor
= 1}
173 fun int s
= valOf (Int.fromString (Substring
.toString
174 (Match
.lookup (m
, s
))))
175 in {minor
= int minor
',
180 structure RequestUrl
=
182 structure Path
= Url
.Path
186 | Path
of {path
: Path
.t
,
187 query
: string option
}
188 | Authority
of string
192 | Url url
=> Url
.toString url
193 | Path
{path
, query
} =>
194 concat
[Path
.toString path
,
197 | SOME q
=> concat
["?", if !Url
.escapeQuery
202 val layout
= Layout
.str
o toString
211 | AcceptCharset
of string
212 | AcceptEncoding
of string
213 | AcceptLanguage
of string
214 | AcceptRanges
of string
217 | Authorization
of string
218 | CacheControl
of string
219 | Connection
of string
220 | ContentEncoding
of string
221 | ContentLanguage
of string
222 | ContentLength
of int
223 | ContentLocation
of string
224 | ContentMD5
of string
225 | ContentRange
of string
226 | ContentType
of string
232 | Extension
of {name
: string, value
: string}
236 | LastModified
of string
239 | ProxyAuthenticate
of string
240 | ProxyConnection
of string
242 | RetryAfter
of string
244 | SetCookie
of string
246 | TransferEncoding
of string
248 | UserAgent
of string
251 | WWWAuthenticate
of string
255 fn Accept s
=> concat
["Accept: ", s
]
256 | AcceptCharset s
=> concat
["Accept-Charset: ", s
]
257 | AcceptEncoding s
=> concat
["Accept-Encoding: ", s
]
258 | AcceptLanguage s
=> concat
["Accept-Language: ", s
]
259 | AcceptRanges s
=> concat
["Accept-Ranges: ", s
]
260 | Age s
=> concat
["Age: ", s
]
261 | Allow s
=> concat
["Allow: ", s
]
262 | Authorization s
=> concat
["Authorization: Basic ", Base64
.encode s
]
263 | CacheControl s
=> concat
["Cache-Control: ", s
]
264 | Connection s
=> concat
["Connection: ", s
]
265 | ContentEncoding s
=> concat
["Content-Encoding: ", s
]
266 | ContentLanguage s
=> concat
["Content-Language: ", s
]
267 | ContentLength s
=> concat
["Content-Length: ", Int.toString s
]
268 | ContentLocation s
=> concat
["Content-Location: ", s
]
269 | ContentMD5 s
=> concat
["Content-MD5: ", s
]
270 | ContentRange s
=> concat
["Content-Range: ", s
]
271 | ContentType s
=> concat
["Content-Type: ", s
]
272 | Cookie s
=> concat
["Cookie: ", s
]
273 | Date s
=> concat
["Date: ", s
]
274 | ETag s
=> concat
["Etag: ", s
]
275 | Expect s
=> concat
["Expect: ", s
]
276 | Expires s
=> concat
["Expires: ", s
]
277 | Extension
{name
, value
} => concat
[name
, ": ", value
]
278 | From s
=> concat
["From: ", s
]
279 | Host s
=> concat
["Host: ", s
]
280 | IfMatch s
=> concat
["If-Match: ", s
]
281 | LastModified s
=> concat
["Last-Modified: ", s
]
282 | Location s
=> concat
["Location: ", s
]
283 | Pragma s
=> concat
["Pragma: ", s
]
284 | ProxyAuthenticate s
=> concat
["Proxy-Authenticate: ", s
]
285 | ProxyConnection s
=> concat
["Proxy-Connection: ", s
]
286 | Referer s
=> concat
["Referer: ", s
]
287 | RetryAfter s
=> concat
["Retry-After: ", s
]
288 | Server s
=> concat
["Server: ", s
]
289 | SetCookie s
=> concat
["Set-Cookie: ", s
]
290 | Trailer s
=> concat
["Trailer: ", s
]
291 | TransferEncoding s
=> concat
["Transfer-Encoding: ", s
]
292 | Upgrade s
=> concat
["Upgrade: ", s
]
293 | UserAgent s
=> concat
["User-Agent: ", s
]
294 | Vary s
=> concat
["Vary: ", s
]
295 | Via s
=> concat
["Via: ", s
]
296 | WWWAuthenticate s
=> concat
["WWW-Authenticate: ", s
]
297 | Warning s
=> concat
["Warning: ", s
]
299 val layout
= Layout
.str
o toString
301 fun toStrings (hs
: t list
): string list
=
302 List.concatMap (hs
, fn h
=> [toString h
, "\r\n"])
304 val cons
: string -> string -> t option
=
306 (fn s
=> fn s
' => SOME (Extension
{name
= s
, value
= s
'}),
307 [("accept", SOME
o Accept
),
308 ("accept-charset", SOME
o AcceptCharset
),
309 ("accept-encoding", SOME
o AcceptEncoding
),
310 ("accept-language", SOME
o AcceptLanguage
),
311 ("accept-ranges", SOME
o AcceptRanges
),
313 ("allow", SOME
o Allow
),
317 val enc
= Save
.new ()
318 val reg
= compileNFA (seq
[string "Basic ", save (anys
, enc
)])
323 (Compiled
.matchAll (reg
, s
), fn m
=>
325 (Base64
.decode (Match
.lookupString (m
, enc
))))
328 ("cache-control", SOME
o CacheControl
),
329 ("connection", SOME
o Connection
),
330 ("content-encoding", SOME
o ContentEncoding
),
331 ("content-language", SOME
o ContentLanguage
),
335 in if Regexp
.Compiled
.matchesAll (contentLength (), s
)
336 then Option
.map (Int.fromString s
, ContentLength
)
339 ("content-location", SOME
o ContentLocation
),
340 ("content-md5", SOME
o ContentMD5
),
341 ("content-range", SOME
o ContentRange
),
342 ("content-type", SOME
o ContentType
),
343 ("cookie", SOME
o Cookie
),
344 ("date", SOME
o Date
),
345 ("etag", SOME
o ETag
),
346 ("expect", SOME
o Expect
),
347 ("expires", SOME
o Expires
),
348 ("from", SOME
o From
),
349 ("host", SOME
o Host
),
350 ("if-match", SOME
o IfMatch
),
351 ("last-modified", SOME
o LastModified
),
352 ("location", SOME
o Location
),
353 ("pragma", SOME
o Pragma
),
354 ("proxy-authenticate", SOME
o ProxyAuthenticate
),
355 ("proxy-connection", SOME
o ProxyConnection
),
356 ("referer", SOME
o Referer
),
357 ("retry-after", SOME
o RetryAfter
),
358 ("server", SOME
o Server
),
359 ("set-cookie", SOME
o SetCookie
),
360 ("trailer", SOME
o Trailer
),
361 ("transfer-encoding", SOME
o TransferEncoding
),
362 ("upgrade", SOME
o Upgrade
),
363 ("user-agent", SOME
o UserAgent
),
364 ("vary", SOME
o Vary
),
366 ("www-authenticate", SOME
o WWWAuthenticate
),
367 ("warning", SOME
o Warning
)])
369 fun fromString (s
: string): t list Result
.t
=
371 val no
= Result
.No (concat
["invalid header: ", s
])
372 val n
= String.size s
373 fun loop (i
: int, ac
: t list
) =
375 then Result
.Yes (rev ac
)
377 in case Compiled
.matchLong (messageheader (), s
, i
) of
381 val {lookup
, ...} = Match
.stringFuns m
382 val fieldname
= String.toLower (lookup fieldname
')
384 String.dropl (lookup fieldvalue
', Char.isSpace
)
385 in case cons fieldname fieldvalue
of
388 loop (i
+ Match
.length m
, header
:: ac
)
395 Trace
.trace ("Http.Header.fromString",
397 Result
.layout (List.layout layout
))
400 fun input (ins
: In
.t
): t list Result
.t
=
402 fun loop (headers
: string list
): string list
=
403 case In
.inputLine ins
of
408 else loop (l
:: headers
)
410 fromString (concat (rev (loop
[])))
416 datatype t
= T
of {method
: Method
.t
,
419 headers
: Header
.t list
}
421 val regexp
= Regexp
.requestLine
423 fun toString (T
{method
, url
, version
, headers
}) =
424 concat ([Method
.toString method
,
426 RequestUrl
.toString url
,
428 Version
.toString version
,
430 @ Header
.toStrings headers
433 val layout
= Layout
.str
o toString
435 fun output (r
, out
) = Out
.output (out
, toString r
)
437 fun requestLine (s
: string) =
441 (Compiled
.matchAll (requestLine (), s
), fn m
=>
443 val {peek
, lookup
, exists
, ...} = Match
.stringFuns m
444 val method
= Method
.fromString (lookup method
')
449 else if exists absoluteUrl
'
450 then Url (Url
.getMatch m
)
452 (case peek authority
' of
454 Path
{path
= Url
.Regexp
.getAbsPath m
,
455 query
= Url
.Regexp
.peekQuery m
}
456 | SOME s
=> Authority s
)
457 val version
= Version
.extract m
465 Trace
.trace ("Http.Request.requestLine",
467 Option
.layout (fn {method
, url
, version
} =>
469 [("method", Method
.layout method
),
470 ("url", RequestUrl
.layout url
),
471 ("version", Version
.layout version
)]))
474 val requestIsValid
= Option
.isSome
o requestLine
476 fun input (ins
: In
.t
): t Result
.t
=
477 case In
.inputLine ins
of
480 case requestLine l
of
482 | SOME
{method
, url
, version
} =>
484 (Header
.input ins
, fn hs
=>
491 Trace
.trace ("Http.Request.input", In
.layout
, Result
.layout layout
) input
501 val appends
= Appends
505 val empty
= String ""
507 fun sizePlus (r
: t
, ac
: int): int =
509 Appends rs
=> List.fold (rs
, ac
, sizePlus
)
510 | File f
=> ac
+ Position
.toInt (File
.size f
)
511 |
String s
=> ac
+ String.size s
513 fun size (r
: t
): int = sizePlus (r
, 0)
515 fun toStrings (r
: t
, ac
: string list
): string list
=
517 Appends rs
=> List.fold (rev rs
, ac
, toStrings
)
518 | File f
=> File
.contents f
:: ac
519 |
String s
=> s
:: ac
521 fun toString (r
: t
): string = concat (toStrings (r
, []))
523 fun output (r
: t
, out
: Out
.t
): unit
=
525 fun loop (r
: t
): unit
=
527 Appends rs
=> List.foreach (rs
, loop
)
528 | File f
=> File
.outputContents (f
, out
)
529 |
String s
=> Out
.output (out
, s
)
539 datatype t
= Url | Multipart
551 fun toString (v
: t
): string =
553 File f
=> File
.contents f
556 fun toRope (v
: t
): Rope
.t
=
558 File f
=> Rope
.file f
559 |
String s
=> Rope
.string s
563 T
of {encoding
: Encoding
.t
,
564 fields
: {name
: string,
565 value
: Value
.t
} list
}
567 fun dquote s
= concat
["\"", s
, "\""]
569 fun encode (T
{encoding
, fields
}): {contentType
: string} * Rope
.t
=
572 ({contentType
= "application/x-www-form-urlencoded"},
574 (rev fields
, Rope
.empty
, fn ({name
, value
}, r
) =>
578 (Value
.toString value
, fn c
=>
585 | _
=> Url
.Char.escapeHex c
))
587 Rope
.appends
[Rope
.string (concat
[name
, "="]),
592 | Encoding
.Multipart
=>
597 if i
< 28 then #
"-" else Random
.charFrom
"0123456789")
599 ({contentType
= concat
["multipart/form-data; boundary=",
602 (fields
, Rope
.string (concat
["--", boundary
, "--"]),
603 fn ({name
, value
}, rope
) =>
607 Value
.File f
=> concat
["; filename=", dquote f
]
608 | Value
.String _
=> ""
613 ["--", boundary
, "\r\n",
614 "Content-Disposition: form-data; name=", dquote name
,
616 Value
.toRope value
, Rope
.string "\r\n", rope
]
621 (* ------------------------------------------------- *)
623 (* ------------------------------------------------- *)
625 structure Path
= Url
.Path
627 fun fetch
{head
: bool,
628 headers
: Header
.t list
,
630 proxy
: {host
: string, port
: int} option
,
636 Url
.T
{authority
= SOME
{user
, host
, port
},
637 fragment
, path
, query
,
638 scheme
= SOME Scheme
.Http
} =>
640 val headers
= Header
.Host host
:: headers
641 val (method
, headers
, postit
) =
644 (if head
then Method
.Head
else Method
.Get
,
649 datatype z
= datatype Post
.Encoding
.t
650 val ({contentType
}, rope
) = Post
.encode post
653 @
[Header
.ContentType contentType
,
654 Header
.ContentLength (Rope
.size rope
)]
656 (Method
.Post
, headers
,
657 fn out
=> (Rope
.output (rope
, out
)
658 ; Out
.output (out
, "\r\n")))
660 val (scheme
, authority
) =
661 if Option
.isSome proxy
662 then (SOME Scheme
.Http
,
668 Url
.T
{scheme
= scheme
,
669 authority
= authority
,
676 | SOME user
=> Header
.Authorization user
:: headers
678 Request
.T
{method
= method
,
679 url
= RequestUrl
.Url url
,
680 version
= Version
.v10
,
683 Net
.connect (case proxy
of
684 NONE
=> {host
= host
,
689 val print
= Out
.outputc out
690 val () = Request
.output (request
, out
)
692 val () = Out
.close out
695 | _
=> Error
.bug (concat
["Htt.fetch: ", Url
.toString url
])
699 Trace
.trace ("Http.fetch", fn {url
, ...} => Url
.layout url
, Layout
.ignore
)
702 (* ------------------------------------------------- *)
704 (* ------------------------------------------------- *)
716 | Extension
of string
721 | HTTPVersionNotSupported
722 | InternalServerError
728 | NonAuthoritativeInformation
737 | ProxyAuthenticationRequired
738 | RequestEntityTooLarge
741 | RequestedRangeNotSatisfiable
748 | UnsupportedMediaType
752 [(Continue
, "100", "Continue"),
753 (SwitchingProtocols
, "101", "Switching Protocols"),
755 (Created
, "201", "Created"),
756 (Accepted
, "202", "Accepted"),
757 (NonAuthoritativeInformation
, "203", "Non-Authoritative Information"),
758 (NoContent
, "204", "No Content"),
759 (ResetContent
, "205", "Reset Content"),
760 (PartialContent
, "206", "Partial Content"),
761 (MultipleChoices
, "300", "Multiple Choices"),
762 (MovedPermanently
, "301", "Moved Permanently"),
763 (Found
, "302", "Found"),
764 (SeeOther
, "303", "See Other"),
765 (NotModified
, "304", "Not Modified"),
766 (UseProxy
, "305", "Use Proxy"),
767 (TemporaryRedirect
, "307", "Temporary Redirect"),
768 (BadRequest
, "400", "Bad Request"),
769 (Unauthorized
, "401", "Unauthorized"),
770 (PaymentRequired
, "402", "Payment Required"),
771 (Forbidden
, "403", "Forbidden"),
772 (NotFound
, "404", "Not Found"),
773 (MethodNotAllowed
, "405", "Method Not Allowed"),
774 (NotAcceptable
, "406", "Not Acceptable"),
775 (ProxyAuthenticationRequired
, "407", "Proxy Authentication Required"),
776 (RequestTimeout
, "408", "Request Time-out"),
777 (Conflict
, "409", "Conflict"),
778 (Gone
, "410", "Gone"),
779 (LengthRequired
, "411", "Length Required"),
780 (PreconditionFailed
, "412", "Precondition Failed"),
781 (RequestEntityTooLarge
, "413", "Request Entity Too Large"),
782 (RequestUriTooLarge
, "414", "Request-URI Too Large"),
783 (UnsupportedMediaType
, "415", "Unsupported Media Type"),
784 (RequestedRangeNotSatisfiable
, "416",
785 "Requested range not satisfiable"),
786 (ExpectationFailed
, "417", "Expectation Failed"),
787 (InternalServerError
, "500", "Internal Server Error"),
788 (NotImplemented
, "501", "Not Implemented"),
789 (BadGateway
, "502", "Bad Gateway"),
790 (ServiceUnavailable
, "503", "Service Unavailable"),
791 (GatewayTimeout
, "504", "Gateway Time-out"),
792 (HTTPVersionNotSupported
, "505", "HTTP Version not supported")]
795 List.revMap (all
, fn (status
, code
, reason
) =>
801 case List.peek (all
, fn {code
, ...} => s
= code
) of
803 | SOME
{status
, ...} => status
806 fun make (ext
, sel
) (s
: t
) =
809 | _
=> sel (valOf (List.peek (all
, fn {status
, ...} => s
= status
)))
811 val code
= make (fn c
=> c
, #code
)
812 val reason
= make (fn _
=> "Extension Status Code - No Reason",
817 (* ------------------------------------------------- *)
819 (* ------------------------------------------------- *)
823 datatype t
= T
of {version
: Version
.t
,
825 headers
: Header
.t list
}
827 val regexp
= Regexp
.responseLine
829 fun toString (T
{version
, status
, headers
}) =
830 concat ([Version
.toString version
, " ",
831 Status
.code status
, " ",
832 Status
.reason status
, "\r\n"]
833 @ Header
.toStrings headers
836 val layout
= Layout
.str
o toString
838 fun output (r
, out
) = Out
.output (out
, toString r
)
840 fun input (ins
: In
.t
): t Result
.t
=
841 case In
.inputLine ins
of
847 case Compiled
.matchAll (responseLine (), l
) of
851 val {lookup
, ...} = Match
.stringFuns m
852 val version
= Version
.extract m
853 val status
= Status
.fromString (lookup status
')
855 Result
.map (Header
.input ins
, fn hs
=>
856 T
{version
= version
,