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 )
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 )
27 [ " \t" member? ] satisfy repeat0 hide ;
29 : one-of ( strings -- parser )
30 [ token ] map choice ;
32 : 'http-method' ( -- parser )
33 { "OPTIONS" "GET" "HEAD" "POST" "PUT" "DELETE" "TRACE" "CONNECT" } one-of ;
36 [ " \t\r\n" member? ] except repeat1 case-sensitive ;
38 : 'http-version' ( -- parser )
47 ] seq* [ "" concat-as ] action ;
49 : 'full-request' ( -- parser )
60 : 'simple-request' ( -- parser )
67 ] seq* [ "1.0" suffix! ] action ;
69 PEG: parse-request-line ( string -- triple )
70 #! Triple is { method url version }
71 'full-request' 'simple-request' 2array choice ;
73 : 'text' ( -- parser )
76 : 'response-code' ( -- parser )
77 [ digit? ] satisfy 3 exactly-n [ string>number ] action ;
79 : 'response-message' ( -- parser )
80 'text' repeat0 case-sensitive ;
82 PEG: parse-response-line ( string -- triple )
83 #! Triple is { version code message }
93 : 'crlf' ( -- parser )
97 [ " \t" member? ] satisfy repeat1 ;
99 : 'qdtext' ( -- parser )
100 { [ CHAR: " = ] [ control? ] } except-these ;
102 : 'quoted-char' ( -- parser )
103 "\\" token hide any-char 2seq ;
105 : 'quoted-string' ( -- parser )
106 'quoted-char' 'qdtext' 2choice repeat0 "\"" "\"" surrounded-by ;
108 : 'ctext' ( -- parser )
109 { [ control? ] [ "()" member? ] } except-these ;
111 : 'comment' ( -- parser )
112 'ctext' 'comment' 2choice repeat0 "(" ")" surrounded-by ;
114 : 'field-name' ( -- parser )
115 'token' case-insensitive ;
117 : 'field-content' ( -- parser )
118 'quoted-string' case-sensitive
119 'text' 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.
133 'lws' [ drop f ] action ,
138 : 'word' ( -- parser )
139 'token' 'quoted-string' 2choice ;
141 : 'value' ( -- parser )
143 [ ";" member? ] except repeat0
144 2choice case-sensitive ;
146 : 'attr' ( -- parser )
147 'token' case-sensitive ;
149 : 'av-pair' ( -- parser )
154 [ "=" token , 'space' , 'value' , ] seq* [ last ] action optional ,
158 : 'av-pairs' ( -- parser )
159 'av-pair' ";" token list-of optional ;
161 PEG: (parse-set-cookie) ( string -- alist )
162 'av-pairs' just [ sift ] action ;
164 : 'cookie-value' ( -- parser )
174 [ ";,=" member? not ] satisfy repeat0 [ drop f ] action
177 PEG: (parse-cookie) ( string -- alist )
178 'cookie-value' [ ";," member? ] satisfy list-of
179 optional just [ sift ] action ;