1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: combinators.short-circuit math math.order math.parser
4 kernel sequences sequences.deep peg peg.parsers assocs arrays
5 hashtables strings namespaces make ascii ;
8 : except ( quot -- parser )
9 [ not ] compose satisfy ; inline
11 : except-these ( quots -- parser )
12 [ 1|| ] curry except ; inline
14 : tspecial? ( ch -- ? )
15 "()<>@,;:\\\"/[]?={} \t" member? ;
17 : token-parser ( -- parser )
18 { [ control? ] [ tspecial? ] } except-these repeat1 ;
20 : case-insensitive ( parser -- parser' )
21 [ flatten >string >lower ] action ;
23 : case-sensitive ( parser -- parser' )
24 [ flatten >string ] action ;
26 : space-parser ( -- parser )
27 [ " \t" member? ] satisfy repeat0 hide ;
29 : one-of ( strings -- parser )
30 [ token ] map choice ;
32 : http-method-parser ( -- parser )
33 { "OPTIONS" "GET" "HEAD" "POST" "PUT" "DELETE" "TRACE" "CONNECT" } one-of ;
35 : url-parser ( -- parser )
36 [ " \t\r\n" member? ] except repeat1 case-sensitive ;
38 : http-version-parser ( -- parser )
47 ] seq* [ "" concat-as ] action ;
49 : full-request-parser ( -- parser )
60 : simple-request-parser ( -- parser )
67 ] seq* [ "1.0" suffix! ] action ;
69 PEG: parse-request-line ( string -- triple )
70 ! Triple is { method url version }
71 full-request-parser simple-request-parser 2array choice ;
73 : text-parser ( -- parser )
76 : response-code-parser ( -- parser )
77 [ digit? ] satisfy 3 exactly-n [ string>number ] action ;
79 : response-message-parser ( -- parser )
80 text-parser repeat0 case-sensitive ;
82 PEG: parse-response-line ( string -- triple )
83 ! Triple is { version code message }
88 response-code-parser ,
90 response-message-parser ,
93 : crlf-parser ( -- parser )
96 : lws-parser ( -- parser )
97 [ " \t" member? ] satisfy repeat1 ;
99 : qdtext-parser ( -- parser )
100 { [ CHAR: " = ] [ control? ] } except-these ;
102 : quoted-char-parser ( -- parser )
103 "\\" token hide any-char 2seq ;
105 : quoted-string-parser ( -- parser )
106 quoted-char-parser qdtext-parser 2choice repeat0 "\"" "\"" surrounded-by ;
108 : ctext-parser ( -- parser )
109 { [ control? ] [ "()" member? ] } except-these ;
111 : comment-parser ( -- parser )
112 ctext-parser comment-parser 2choice repeat0 "(" ")" surrounded-by ;
114 : field-name-parser ( -- parser )
115 token-parser case-insensitive ;
117 : field-content-parser ( -- parser )
118 quoted-string-parser case-sensitive
119 text-parser repeat0 case-sensitive
122 PEG: parse-header-line ( string -- pair )
123 ! Pair is either { name value } or { f value }. If f, its a
124 ! continuation of the previous header line.
130 field-content-parser ,
133 lws-parser [ drop f ] action ,
134 field-content-parser ,
138 : word-parser ( -- parser )
139 token-parser quoted-string-parser 2choice ;
141 : value-parser ( -- parser )
143 [ ";" member? ] except repeat0
144 2choice case-sensitive ;
146 : attr-parser ( -- parser )
147 token-parser case-sensitive ;
149 : av-pair-parser ( -- parser )
154 [ "=" token , space-parser , value-parser , ] seq* [ last ] action optional ,
158 : av-pairs-parser ( -- parser )
159 av-pair-parser ";" token list-of optional ;
161 PEG: (parse-set-cookie) ( string -- alist )
162 av-pairs-parser just [ sift ] action ;
164 : cookie-value-parser ( -- parser )
174 [ ";,=" member? not ] satisfy repeat0 [ drop f ] action
177 PEG: (parse-cookie) ( string -- alist )
178 cookie-value-parser [ ";," member? ] satisfy list-of
179 optional just [ sift ] action ;