extra/http/parsers/parsers.factor

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