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