basis/furnace/asides/asides.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators db.tuples db.types
   4 furnace.cache furnace.redirection furnace.sessions
   5 furnace.utilities hashtables html.templates.chloe.syntax http
   6 http.server kernel logging math.parser namespaces urls ;
   7 IN: furnace.asides
   8
   9 TUPLE: aside < server-state
  10 session method url post-data ;
  11
  12 : <aside> ( id -- aside )
  13     aside new-server-state ;
  14
  15 aside "ASIDES" {
  16     { "session" "SESSION" BIG-INTEGER +not-null+ }
  17     { "method" "METHOD" { VARCHAR 10 } }
  18     { "url" "URL" URL }
  19     { "post-data" "POST_DATA" FACTOR-BLOB }
  20 } define-persistent
  21
  22 CONSTANT: aside-id-key "__a"
  23
  24 TUPLE: asides < server-state-manager ;
  25
  26 : <asides> ( responder -- responder' )
  27     asides new-server-state-manager ;
  28
  29 SYMBOL: aside-id
  30
  31 : get-aside ( id -- aside )
  32     dup [ aside get-state ] when check-session ;
  33
  34 : request-aside-id ( request -- id )
  35     aside-id-key swap request-params at string>number ;
  36
  37 : request-aside ( request -- aside )
  38     request-aside-id get-aside ;
  39
  40 : set-aside ( aside -- )
  41     [ id>> aside-id set ] when* ;
  42
  43 : init-asides ( asides -- )
  44     asides set
  45     request get request-aside
  46     set-aside ;
  47
  48 M: asides call-responder*
  49     [ init-asides ] [ call-next-method ] bi ;
  50
  51 : touch-aside ( aside -- )
  52     asides get touch-state ;
  53
  54 : begin-aside ( url -- )
  55     f <aside>
  56         swap >>url
  57         session get id>> >>session
  58         request get method>> >>method
  59         request get post-data>> >>post-data
  60     [ touch-aside ] [ insert-tuple ] [ set-aside ] tri ;
  61
  62 : end-aside-post ( aside -- response )
  63     request [
  64         clone
  65             over post-data>> >>post-data
  66             over url>> >>url
  67     ] change
  68     [ [ post-data>> params>> params set ] [ url>> url set ] bi ]
  69     [ url>> path>> split-path asides get responder>> call-responder ] bi ;
  70
  71 \ end-aside-post DEBUG add-input-logging
  72
  73 ERROR: end-aside-in-get-error ;
  74
  75 : move-on ( id -- response )
  76     post-request? [ end-aside-in-get-error ] unless
  77     dup method>> {
  78         { "GET" [ url>> <redirect> ] }
  79         { "HEAD" [ url>> <redirect> ] }
  80         { "POST" [ end-aside-post ] }
  81     } case ;
  82
  83 : end-aside ( default -- response )
  84     aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ;
  85
  86 M: asides link-attr
  87     drop
  88     "aside" optional-attr {
  89         { "none" [ aside-id off ] }
  90         { "begin" [ url get begin-aside ] }
  91         { "current" [ ] }
  92         { f [ ] }
  93     } case ;
  94
  95 M: asides modify-query
  96     drop
  97     aside-id get [
  98         aside-id-key associate assoc-union
  99     ] when* ;
 100
 101 M: asides modify-form
 102     drop
 103     aside-id get
 104     aside-id-key
 105     hidden-form-field ;