extra/http/http.factor

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