basis/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 http http.server
   5 http.server.redirection http.server.responses
   6 http.server.filters 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 : secure-connection? ( -- ? ) url get protocol>> "https" = ;
  36
  37 : if-secure ( quot -- response )
  38     {
  39         { [ secure-connection? ] [ call ] }
  40         { [ request get method>> "POST" = ] [ drop <400> ] }
  41         [ drop url get <secure-redirect> ]
  42     } cond ; inline
  43
  44 M: secure-only call-responder*
  45     '[ _ _ call-next-method ] if-secure ;