extra/http/http.factor

   1 ! Copyright (C) 2003, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel combinators math namespaces
   4
   5 assocs sequences splitting sorting sets debugger
   6 strings vectors hashtables quotations arrays byte-arrays
   7 math.parser calendar calendar.format present
   8
   9 io io.server io.sockets.secure
  10
  11 unicode.case unicode.categories qualified
  12
  13 urls html.templates xml xml.data xml.writer ;
  14
  15 EXCLUDE: fry => , ;
  16
  17 IN: http
  18
  19 : crlf ( -- ) "\r\n" write ;
  20
  21 : add-header ( value key assoc -- )
  22     [ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ;
  23
  24 : header-line ( line -- )
  25     dup first blank? [
  26         [ blank? ] left-trim
  27         "last-header" get
  28         "header" get
  29         add-header
  30     ] [
  31         ": " split1 dup [
  32             swap >lower dup "last-header" set
  33             "header" get add-header
  34         ] [
  35             2drop
  36         ] if
  37     ] if ;
  38
  39 : read-lf ( -- string )
  40     "\n" read-until CHAR: \n assert= ;
  41
  42 : read-crlf ( -- string )
  43     "\r" read-until
  44     [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
  45
  46 : read-header-line ( -- )
  47     read-crlf dup
  48     empty? [ drop ] [ header-line read-header-line ] if ;
  49
  50 : read-header ( -- assoc )
  51     H{ } clone [
  52         "header" [ read-header-line ] with-variable
  53     ] keep ;
  54
  55 : header-value>string ( value -- string )
  56     {
  57         { [ dup timestamp? ] [ timestamp>http-string ] }
  58         { [ dup array? ] [ [ header-value>string ] map "; " join ] }
  59         [ present ]
  60     } cond ;
  61
  62 : check-header-string ( str -- str )
  63     #! http://en.wikipedia.org/wiki/HTTP_Header_Injection
  64     dup "\r\n" intersect empty?
  65     [ "Header injection attack" throw ] unless ;
  66
  67 : write-header ( assoc -- )
  68     >alist sort-keys [
  69         swap url-encode write ": " write
  70         header-value>string check-header-string write crlf
  71     ] assoc-each crlf ;
  72
  73 TUPLE: cookie name value path domain expires max-age http-only ;
  74
  75 : <cookie> ( value name -- cookie )
  76     cookie new
  77         swap >>name
  78         swap >>value ;
  79
  80 : parse-cookies ( string -- seq )
  81     [
  82         f swap
  83
  84         ";" split [
  85             [ blank? ] trim "=" split1 swap >lower {
  86                 { "expires" [ cookie-string>timestamp >>expires ] }
  87                 { "max-age" [ string>number seconds >>max-age ] }
  88                 { "domain" [ >>domain ] }
  89                 { "path" [ >>path ] }
  90                 { "httponly" [ drop t >>http-only ] }
  91                 { "" [ drop ] }
  92                 [ <cookie> dup , nip ]
  93             } case
  94         ] each
  95
  96         drop
  97     ] { } make ;
  98
  99 : (unparse-cookie) ( key value -- )
 100     {
 101         { f [ drop ] }
 102         { t [ , ] }
 103         [
 104             {
 105                 { [ dup timestamp? ] [ timestamp>cookie-string ] }
 106                 { [ dup duration? ] [ dt>seconds number>string ] }
 107                 [ ]
 108             } cond
 109             "=" swap 3append ,
 110         ]
 111     } case ;
 112
 113 : unparse-cookie ( cookie -- strings )
 114     [
 115         dup name>> >lower over value>> (unparse-cookie)
 116         "path" over path>> (unparse-cookie)
 117         "domain" over domain>> (unparse-cookie)
 118         "expires" over expires>> (unparse-cookie)
 119         "max-age" over max-age>> (unparse-cookie)
 120         "httponly" over http-only>> (unparse-cookie)
 121         drop
 122     ] { } make ;
 123
 124 : unparse-cookies ( cookies -- string )
 125     [ unparse-cookie ] map concat "; " join ;
 126
 127 TUPLE: request
 128 method
 129 url
 130 version
 131 header
 132 post-data
 133 cookies ;
 134
 135 : set-header ( request/response value key -- request/response )
 136     pick header>> set-at ;
 137
 138 : <request> ( -- request )
 139     request new
 140         "1.1" >>version
 141         <url>
 142             "http" >>protocol
 143             H{ } clone >>query
 144         >>url
 145         H{ } clone >>header
 146         V{ } clone >>cookies
 147         "close" "connection" set-header
 148         "Factor http.client vocabulary" "user-agent" set-header ;
 149
 150 : read-method ( request -- request )
 151     " " read-until [ "Bad request: method" throw ] unless
 152     >>method ;
 153
 154 : check-absolute ( url -- url )
 155     dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
 156
 157 : read-url ( request -- request )
 158     " " read-until [
 159         dup empty? [ drop read-url ] [ >url check-absolute >>url ] if
 160     ] [ "Bad request: URL" throw ] if ;
 161
 162 : parse-version ( string -- version )
 163     "HTTP/" ?head [ "Bad request: version" throw ] unless
 164     dup { "1.0" "1.1" } member? [ "Bad request: version" throw ] unless ;
 165
 166 : read-request-version ( request -- request )
 167     read-crlf [ CHAR: \s = ] left-trim
 168     parse-version
 169     >>version ;
 170
 171 : read-request-header ( request -- request )
 172     read-header >>header ;
 173
 174 : header ( request/response key -- value )
 175     swap header>> at ;
 176
 177 TUPLE: post-data raw content content-type ;
 178
 179 : <post-data> ( raw content-type -- post-data )
 180     post-data new
 181         swap >>content-type
 182         swap >>raw ;
 183
 184 : parse-post-data ( post-data -- post-data )
 185     [ ] [ raw>> ] [ content-type>> ] tri {
 186         { "application/x-www-form-urlencoded" [ query>assoc ] }
 187         { "text/xml" [ string>xml ] }
 188         [ drop ]
 189     } case >>content ;
 190
 191 : read-post-data ( request -- request )
 192     dup method>> "POST" = [
 193         [ ]
 194         [ "content-length" header string>number read ]
 195         [ "content-type" header ] tri
 196         <post-data> parse-post-data >>post-data
 197     ] when ;
 198
 199 : extract-host ( request -- request )
 200     [ ] [ url>> ] [ "host" header parse-host ] tri
 201     [ >>host ] [ >>port ] bi*
 202     ensure-port
 203     drop ;
 204
 205 : extract-cookies ( request -- request )
 206     dup "cookie" header [ parse-cookies >>cookies ] when* ;
 207
 208 : parse-content-type-attributes ( string -- attributes )
 209     " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
 210
 211 : parse-content-type ( content-type -- type encoding )
 212     ";" split1 parse-content-type-attributes "charset" swap at ;
 213
 214 : detect-protocol ( request -- request )
 215     dup url>> remote-address get secure? "https" "http" ? >>protocol drop ;
 216
 217 : read-request ( -- request )
 218     <request>
 219     read-method
 220     read-url
 221     read-request-version
 222     read-request-header
 223     read-post-data
 224     detect-protocol
 225     extract-host
 226     extract-cookies ;
 227
 228 : write-method ( request -- request )
 229     dup method>> write bl ;
 230
 231 : write-request-url ( request -- request )
 232     dup url>> relative-url present write bl ;
 233
 234 : write-version ( request -- request )
 235     "HTTP/" write dup request-version write crlf ;
 236
 237 : url-host ( url -- string )
 238     [ host>> ] [ port>> ] bi dup "http" protocol-port =
 239     [ drop ] [ ":" swap number>string 3append ] if ;
 240
 241 : write-request-header ( request -- request )
 242     dup header>> >hashtable
 243     over url>> host>> [ over url>> url-host "host" pick set-at ] when
 244     over post-data>> [
 245         [ raw>> length "content-length" pick set-at ]
 246         [ content-type>> "content-type" pick set-at ]
 247         bi
 248     ] when*
 249     over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
 250     write-header ;
 251
 252 GENERIC: >post-data ( object -- post-data )
 253
 254 M: post-data >post-data ;
 255
 256 M: string >post-data "application/octet-stream" <post-data> ;
 257
 258 M: byte-array >post-data "application/octet-stream" <post-data> ;
 259
 260 M: xml >post-data xml>string "text/xml" <post-data> ;
 261
 262 M: assoc >post-data assoc>query "application/x-www-form-urlencoded" <post-data> ;
 263
 264 M: f >post-data ;
 265
 266 : unparse-post-data ( request -- request )
 267     [ >post-data ] change-post-data ;
 268
 269 : write-post-data ( request -- request )
 270     dup method>> "POST" = [ dup post-data>> raw>> write ] when ;
 271
 272 : write-request ( request -- )
 273     unparse-post-data
 274     write-method
 275     write-request-url
 276     write-version
 277     write-request-header
 278     write-post-data
 279     flush
 280     drop ;
 281
 282 GENERIC: write-response ( response -- )
 283
 284 GENERIC: write-full-response ( request response -- )
 285
 286 TUPLE: response
 287 version
 288 code
 289 message
 290 header
 291 cookies
 292 content-type
 293 content-charset
 294 body ;
 295
 296 : <response> ( -- response )
 297     response new
 298         "1.1" >>version
 299         H{ } clone >>header
 300         "close" "connection" set-header
 301         now timestamp>http-string "date" set-header
 302         V{ } clone >>cookies ;
 303
 304 : read-response-version ( response -- response )
 305     " \t" read-until
 306     [ "Bad response: version" throw ] unless
 307     parse-version
 308     >>version ;
 309
 310 : read-response-code ( response -- response )
 311     " \t" read-until [ "Bad response: code" throw ] unless
 312     string>number [ "Bad response: code" throw ] unless*
 313     >>code ;
 314
 315 : read-response-message ( response -- response )
 316     read-crlf >>message ;
 317
 318 : read-response-header ( response -- response )
 319     read-header >>header
 320     dup "set-cookie" header parse-cookies >>cookies
 321     dup "content-type" header [
 322         parse-content-type [ >>content-type ] [ >>content-charset ] bi*
 323     ] when* ;
 324
 325 : read-response ( -- response )
 326     <response>
 327     read-response-version
 328     read-response-code
 329     read-response-message
 330     read-response-header ;
 331
 332 : write-response-version ( response -- response )
 333     "HTTP/" write
 334     dup version>> write bl ;
 335
 336 : write-response-code ( response -- response )
 337     dup code>> number>string write bl ;
 338
 339 : write-response-message ( response -- response )
 340     dup message>> write crlf ;
 341
 342 : unparse-content-type ( request -- content-type )
 343     [ content-type>> "application/octet-stream" or ]
 344     [ content-charset>> ] bi
 345     [ "; charset=" swap 3append ] when* ;
 346
 347 : write-response-header ( response -- response )
 348     dup header>> clone
 349     over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when*
 350     over unparse-content-type "content-type" pick set-at
 351     write-header ;
 352
 353 : write-response-body ( response -- response )
 354     dup body>> call-template ;
 355
 356 M: response write-response ( respose -- )
 357     write-response-version
 358     write-response-code
 359     write-response-message
 360     write-response-header
 361     flush
 362     drop ;
 363
 364 M: response write-full-response ( request response -- )
 365     dup write-response
 366     swap method>> "HEAD" = [ write-response-body ] unless ;
 367
 368 : get-cookie ( request/response name -- cookie/f )
 369     [ cookies>> ] dip '[ , _ name>> = ] find nip ;
 370
 371 : delete-cookie ( request/response name -- )
 372     over cookies>> [ get-cookie ] dip delete ;
 373
 374 : put-cookie ( request/response cookie -- request/response )
 375     [ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
 376     over cookies>> push ;
 377
 378 TUPLE: raw-response
 379 version
 380 code
 381 message
 382 body ;
 383
 384 : <raw-response> ( -- response )
 385     raw-response new
 386         "1.1" >>version ;
 387
 388 M: raw-response write-response ( respose -- )
 389     write-response-version
 390     write-response-code
 391     write-response-message
 392     write-response-body
 393     drop ;
 394
 395 M: raw-response write-full-response ( response -- )
 396     write-response nip ;