extra/furnace/redirection/redirection.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel accessors combinators namespaces fry
   4 io.servers.connection urls
   5 http http.server http.server.redirection http.server.filters
   6 furnace ;
   7 IN: furnace.redirection
   8
   9 : <redirect> ( url -- response )
  10     adjust-url request get method>> {
  11         { "GET" [ <temporary-redirect> ] }
  12         { "HEAD" [ <temporary-redirect> ] }
  13         { "POST" [ <permanent-redirect> ] }
  14     } case ;
  15
  16 : >secure-url ( url -- url' )
  17     clone
  18         "https" >>protocol
  19         secure-port >>port ;
  20
  21 : <secure-redirect> ( url -- response )
  22     >secure-url <redirect> ;
  23
  24 TUPLE: redirect-responder to ;
  25
  26 : <redirect-responder> ( url -- responder )
  27     redirect-responder boa ;
  28
  29 M: redirect-responder call-responder* nip to>> <redirect> ;
  30
  31 TUPLE: secure-only < filter-responder ;
  32
  33 C: <secure-only> secure-only
  34
  35 : if-secure ( quot -- )
  36     >r url get protocol>> "http" =
  37     [ url get <secure-redirect> ]
  38     r> if ; inline
  39
  40 M: secure-only call-responder*
  41     '[ , , call-next-method ] if-secure ;