basis/http/parsers/parsers.factor

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