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