! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit math math.order math.parser
-kernel sequences sequences.deep peg peg.parsers assocs arrays
-hashtables strings namespaces make ascii ;
+USING: arrays ascii combinators.short-circuit kernel make
+math.parser peg peg.parsers sequences sequences.deep strings ;
IN: http.parsers
: except ( quot -- parser )
: except-these ( quots -- parser )
[ 1|| ] curry except ; inline
+: cookie-key-disallow? ( ch -- ? )
+ " \t,;=" member? ;
+
: tspecial? ( ch -- ? )
"()<>@,;:\\\"/[]?={} \t" member? ;
-: 'token' ( -- parser )
+: cookie-key-parser ( -- parser )
+ { [ control? ] [ cookie-key-disallow? ] } except-these repeat1 ;
+
+: token-parser ( -- parser )
{ [ control? ] [ tspecial? ] } except-these repeat1 ;
: case-insensitive ( parser -- parser' )
: case-sensitive ( parser -- parser' )
[ flatten >string ] action ;
-: 'space' ( -- parser )
+: space-parser ( -- parser )
[ " \t" member? ] satisfy repeat0 hide ;
: one-of ( strings -- parser )
[ token ] map choice ;
-: 'http-method' ( -- parser )
- { "OPTIONS" "GET" "HEAD" "POST" "PUT" "DELETE" "TRACE" "CONNECT" } one-of ;
+: http-method-parser ( -- parser )
+ { "OPTIONS" "GET" "HEAD" "POST" "PUT" "DELETE" "TRACE" "CONNECT" "PATCH" } one-of ;
-: 'url' ( -- parser )
+: url-parser ( -- parser )
[ " \t\r\n" member? ] except repeat1 case-sensitive ;
-: 'http-version' ( -- parser )
+: http-version-parser ( -- parser )
[
"HTTP" token hide ,
- 'space' ,
+ space-parser ,
"/" token hide ,
- 'space' ,
+ space-parser ,
"1" token ,
"." token ,
{ "0" "1" } one-of ,
] seq* [ "" concat-as ] action ;
-: 'full-request' ( -- parser )
+: full-request-parser ( -- parser )
[
- 'space' ,
- 'http-method' ,
- 'space' ,
- 'url' ,
- 'space' ,
- 'http-version' ,
- 'space' ,
+ space-parser ,
+ http-method-parser ,
+ space-parser ,
+ url-parser ,
+ space-parser ,
+ http-version-parser ,
+ space-parser ,
] seq* ;
-: 'simple-request' ( -- parser )
+: simple-request-parser ( -- parser )
[
- 'space' ,
+ space-parser ,
"GET" token ,
- 'space' ,
- 'url' ,
- 'space' ,
+ space-parser ,
+ url-parser ,
+ space-parser ,
] seq* [ "1.0" suffix! ] action ;
PEG: parse-request-line ( string -- triple )
- #! Triple is { method url version }
- 'full-request' 'simple-request' 2array choice ;
+ ! Triple is { method url version }
+ full-request-parser simple-request-parser 2array choice ;
-: 'text' ( -- parser )
+: text-parser ( -- parser )
[ control? ] except ;
-: 'response-code' ( -- parser )
+: response-code-parser ( -- parser )
[ digit? ] satisfy 3 exactly-n [ string>number ] action ;
-: 'response-message' ( -- parser )
- 'text' repeat0 case-sensitive ;
+: response-message-parser ( -- parser )
+ text-parser repeat0 case-sensitive ;
PEG: parse-response-line ( string -- triple )
- #! Triple is { version code message }
+ ! Triple is { version code message }
[
- 'space' ,
- 'http-version' ,
- 'space' ,
- 'response-code' ,
- 'space' ,
- 'response-message' ,
+ space-parser ,
+ http-version-parser ,
+ space-parser ,
+ response-code-parser ,
+ space-parser ,
+ response-message-parser ,
] seq* just ;
-: 'crlf' ( -- parser )
+: crlf-parser ( -- parser )
"\r\n" token ;
-: 'lws' ( -- parser )
+: lws-parser ( -- parser )
[ " \t" member? ] satisfy repeat1 ;
-: 'qdtext' ( -- parser )
- { [ CHAR: " = ] [ control? ] } except-these ;
+: qdtext-parser ( -- parser )
+ { [ CHAR: \" = ] [ control? ] } except-these ;
-: 'quoted-char' ( -- parser )
+: quoted-char-parser ( -- parser )
"\\" token hide any-char 2seq ;
-: 'quoted-string' ( -- parser )
- 'quoted-char' 'qdtext' 2choice repeat0 "\"" "\"" surrounded-by ;
+: quoted-string-parser ( -- parser )
+ quoted-char-parser qdtext-parser 2choice repeat0 "\"" "\"" surrounded-by ;
-: 'ctext' ( -- parser )
+: ctext-parser ( -- parser )
{ [ control? ] [ "()" member? ] } except-these ;
-: 'comment' ( -- parser )
- 'ctext' 'comment' 2choice repeat0 "(" ")" surrounded-by ;
+: comment-parser ( -- parser )
+ ctext-parser comment-parser 2choice repeat0 "(" ")" surrounded-by ;
-: 'field-name' ( -- parser )
- 'token' case-insensitive ;
+: field-name-parser ( -- parser )
+ token-parser case-insensitive ;
-: 'field-content' ( -- parser )
- 'quoted-string' case-sensitive
- 'text' repeat0 case-sensitive
+: field-content-parser ( -- parser )
+ quoted-string-parser case-sensitive
+ text-parser repeat0 case-sensitive
2choice ;
PEG: parse-header-line ( string -- pair )
- #! Pair is either { name value } or { f value }. If f, its a
- #! continuation of the previous header line.
+ ! Pair is either { name value } or { f value }. If f, its a
+ ! continuation of the previous header line.
[
- 'field-name' ,
- 'space' ,
+ field-name-parser ,
+ space-parser ,
":" token hide ,
- 'space' ,
- 'field-content' ,
+ space-parser ,
+ field-content-parser ,
] seq*
[
- 'lws' [ drop f ] action ,
- 'field-content' ,
+ lws-parser [ drop f ] action ,
+ field-content-parser ,
] seq*
2choice ;
-: 'word' ( -- parser )
- 'token' 'quoted-string' 2choice ;
+: word-parser ( -- parser )
+ token-parser quoted-string-parser 2choice ;
-: 'value' ( -- parser )
- 'quoted-string'
+: value-parser ( -- parser )
+ quoted-string-parser
[ ";" member? ] except repeat0
2choice case-sensitive ;
-: 'attr' ( -- parser )
- 'token' case-sensitive ;
+: attr-parser ( -- parser )
+ cookie-key-parser case-sensitive ;
-: 'av-pair' ( -- parser )
+: av-pair-parser ( -- parser )
[
- 'space' ,
- 'attr' ,
- 'space' ,
- [ "=" token , 'space' , 'value' , ] seq* [ last ] action optional ,
- 'space' ,
+ space-parser ,
+ attr-parser ,
+ space-parser ,
+ [ "=" token , space-parser , value-parser , ] seq* [ last ] action optional ,
+ space-parser ,
] seq* ;
-: 'av-pairs' ( -- parser )
- 'av-pair' ";" token list-of optional ;
+: av-pairs-parser ( -- parser )
+ av-pair-parser ";" token list-of optional ;
PEG: (parse-set-cookie) ( string -- alist )
- 'av-pairs' just [ sift ] action ;
+ av-pairs-parser just [ sift ] action ;
-: 'cookie-value' ( -- parser )
+: cookie-value-parser ( -- parser )
[
- 'space' ,
- 'attr' ,
- 'space' ,
+ space-parser ,
+ attr-parser ,
+ space-parser ,
"=" token hide ,
- 'space' ,
- 'value' ,
- 'space' ,
+ space-parser ,
+ value-parser ,
+ space-parser ,
] seq*
[ ";,=" member? not ] satisfy repeat0 [ drop f ] action
2choice ;
PEG: (parse-cookie) ( string -- alist )
- 'cookie-value' [ ";," member? ] satisfy list-of
+ cookie-value-parser [ ";," member? ] satisfy list-of
optional just [ sift ] action ;
projects / factor.git / blobdiff