basis/http/parsers/parsers.factor

   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 ;
   6 IN: http.parsers
   7
   8 : except ( quot -- parser )
   9     [ not ] compose satisfy ; inline
  10
  11 : except-these ( quots -- parser )
  12     [ 1|| ] curry except ; inline
  13
  14 : cookie-key-disallow? ( ch -- ? )
  15     " \t,;=" member? ;
  16
  17 : tspecial? ( ch -- ? )
  18     "()<>@,;:\\\"/[]?={} \t" member? ;
  19
  20 : cookie-key-parser ( -- parser )
  21     { [ control? ] [ cookie-key-disallow? ] } except-these repeat1 ;
  22
  23 : token-parser ( -- parser )
  24     { [ control? ] [ tspecial? ] } except-these repeat1 ;
  25
  26 : case-insensitive ( parser -- parser' )
  27     [ flatten >string >lower ] action ;
  28
  29 : case-sensitive ( parser -- parser' )
  30     [ flatten >string ] action ;
  31
  32 : space-parser ( -- parser )
  33     [ " \t" member? ] satisfy repeat0 hide ;
  34
  35 : one-of ( strings -- parser )
  36     [ token ] map choice ;
  37
  38 : http-method-parser ( -- parser )
  39     { "OPTIONS" "GET" "HEAD" "POST" "PUT" "DELETE" "TRACE" "CONNECT" "PATCH" } one-of ;
  40
  41 : url-parser ( -- parser )
  42     [ " \t\r\n" member? ] except repeat1 case-sensitive ;
  43
  44 : http-version-parser ( -- parser )
  45     [
  46         "HTTP" token hide ,
  47         space-parser ,
  48         "/" token hide ,
  49         space-parser ,
  50         "1" token ,
  51         "." token ,
  52         { "0" "1" } one-of ,
  53     ] seq* [ "" concat-as ] action ;
  54
  55 : full-request-parser ( -- parser )
  56     [
  57         space-parser ,
  58         http-method-parser ,
  59         space-parser ,
  60         url-parser ,
  61         space-parser ,
  62         http-version-parser ,
  63         space-parser ,
  64     ] seq* ;
  65
  66 : simple-request-parser ( -- parser )
  67     [
  68         space-parser ,
  69         "GET" token ,
  70         space-parser ,
  71         url-parser ,
  72         space-parser ,
  73     ] seq* [ "1.0" suffix! ] action ;
  74
  75 PEG: parse-request-line ( string -- triple )
  76     ! Triple is { method url version }
  77     full-request-parser simple-request-parser 2array choice ;
  78
  79 : text-parser ( -- parser )
  80     [ control? ] except ;
  81
  82 : response-code-parser ( -- parser )
  83     [ digit? ] satisfy 3 exactly-n [ string>number ] action ;
  84
  85 : response-message-parser ( -- parser )
  86     text-parser repeat0 case-sensitive ;
  87
  88 PEG: parse-response-line ( string -- triple )
  89     ! Triple is { version code message }
  90     [
  91         space-parser ,
  92         http-version-parser ,
  93         space-parser ,
  94         response-code-parser ,
  95         space-parser ,
  96         response-message-parser ,
  97     ] seq* just ;
  98
  99 : crlf-parser ( -- parser )
 100     "\r\n" token ;
 101
 102 : lws-parser ( -- parser )
 103     [ " \t" member? ] satisfy repeat1 ;
 104
 105 : qdtext-parser ( -- parser )
 106     { [ CHAR: \" = ] [ control? ] } except-these ;
 107
 108 : quoted-char-parser ( -- parser )
 109     "\\" token hide any-char 2seq ;
 110
 111 : quoted-string-parser ( -- parser )
 112     quoted-char-parser qdtext-parser 2choice repeat0 "\"" "\"" surrounded-by ;
 113
 114 : ctext-parser ( -- parser )
 115     { [ control? ] [ "()" member? ] } except-these ;
 116
 117 : comment-parser ( -- parser )
 118     ctext-parser comment-parser 2choice repeat0 "(" ")" surrounded-by ;
 119
 120 : field-name-parser ( -- parser )
 121     token-parser case-insensitive ;
 122
 123 : field-content-parser ( -- parser )
 124     quoted-string-parser case-sensitive
 125     text-parser repeat0 case-sensitive
 126     2choice ;
 127
 128 PEG: parse-header-line ( string -- pair )
 129     ! Pair is either { name value } or { f value }. If f, its a
 130     ! continuation of the previous header line.
 131     [
 132         field-name-parser ,
 133         space-parser ,
 134         ":" token hide ,
 135         space-parser ,
 136         field-content-parser ,
 137     ] seq*
 138     [
 139         lws-parser [ drop f ] action ,
 140         field-content-parser ,
 141     ] seq*
 142     2choice ;
 143
 144 : word-parser ( -- parser )
 145     token-parser quoted-string-parser 2choice ;
 146
 147 : value-parser ( -- parser )
 148     quoted-string-parser
 149     [ ";" member? ] except repeat0
 150     2choice case-sensitive ;
 151
 152 : attr-parser ( -- parser )
 153     cookie-key-parser case-sensitive ;
 154
 155 : av-pair-parser ( -- parser )
 156     [
 157         space-parser ,
 158         attr-parser ,
 159         space-parser ,
 160         [ "=" token , space-parser , value-parser , ] seq* [ last ] action optional ,
 161         space-parser ,
 162     ] seq* ;
 163
 164 : av-pairs-parser ( -- parser )
 165     av-pair-parser ";" token list-of optional ;
 166
 167 PEG: (parse-set-cookie) ( string -- alist )
 168     av-pairs-parser just [ sift ] action ;
 169
 170 : cookie-value-parser ( -- parser )
 171     [
 172         space-parser ,
 173         attr-parser ,
 174         space-parser ,
 175         "=" token hide ,
 176         space-parser ,
 177         value-parser ,
 178         space-parser ,
 179     ] seq*
 180     [ ";,=" member? not ] satisfy repeat0 [ drop f ] action
 181     2choice ;
 182
 183 PEG: (parse-cookie) ( string -- alist )
 184     cookie-value-parser [ ";," member? ] satisfy list-of
 185     optional just [ sift ] action ;