libs/http.factor

   1 ! Copyright (C) 2003, 2005 Slava Pestov
   2 IN: http
   3 USING: errors hashtables io kernel math namespaces parser
   4 sequences strings ;
   5
   6 : header-line ( line -- )
   7     ": " split1 dup [ swap set ] [ 2drop ] if ;
   8
   9 : (read-header) ( hash -- hash )
  10     readln dup
  11     empty? [ drop ] [ header-line (read-header) ] if ;
  12
  13 : read-header ( -- hash )
  14     [ (read-header) ] make-hash ;
  15
  16 : url-quotable? ( ch -- ? )
  17     #! In a URL, can this character be used without
  18     #! URL-encoding?
  19     dup letter?
  20     over LETTER? or
  21     over digit? or
  22     swap "/_?." member? or ; foldable
  23
  24 : url-encode ( str -- str )
  25     [
  26         [
  27             dup url-quotable? [
  28                 ,
  29             ] [
  30                 CHAR: % , >hex 2 CHAR: 0 pad-left %
  31             ] if
  32         ] each
  33     ] "" make ;
  34
  35 : catch-hex> ( str -- n/f )
  36     #! Push f if string is not a valid hex literal.
  37     [ hex> ] catch [ drop f ] when ;
  38
  39 : url-decode-hex ( index str -- )
  40     2dup length 2 - >= [
  41         2drop
  42     ] [
  43         >r 1+ dup 2 + r> subseq  catch-hex> [ , ] when*
  44     ] if ;
  45
  46 : url-decode-% ( index str -- index str )
  47     2dup url-decode-hex >r 3 + r> ;
  48
  49 : url-decode-+-or-other ( index str ch -- index str )
  50     dup CHAR: + = [ drop CHAR: \s ] when , >r 1+ r> ;
  51
  52 : url-decode-iter ( index str -- )
  53     2dup length >= [
  54         2drop
  55     ] [
  56         2dup nth dup CHAR: % = [
  57             drop url-decode-%
  58         ] [
  59             url-decode-+-or-other
  60         ] if url-decode-iter
  61     ] if ;
  62
  63 : url-decode ( str -- str )
  64     [ 0 swap url-decode-iter ] "" make ;
  65
  66 : build-url ( path query-params -- str )
  67     [
  68         swap % dup hash-empty? [
  69             "?" %
  70             dup hash>alist
  71             [ [ url-encode ] map "=" join ] map "&" join %
  72         ] unless drop
  73     ] "" make ;
  74
  75 PROVIDE: libs/http ;