unmaintained/tangle/tangle.factor

   1 ! Copyright (C) 2008 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs db db.sqlite db.postgresql
   4 http http.server http.server.dispatchers http.server.responses
   5 http.server.static furnace.actions furnace.json
   6 io io.files json.writer kernel math.parser namespaces
   7 semantic-db sequences strings tangle.path ;
   8 IN: tangle
   9
  10 GENERIC: render* ( content templater -- output )
  11 GENERIC: render ( content templater -- )
  12
  13 TUPLE: echo-template ;
  14 C: <echo-template> echo-template
  15
  16 M: echo-template render* drop ;
  17 ! METHOD: render* { string echo-template } drop ;
  18 M: object render render* write ;
  19
  20 TUPLE: tangle db seq templater ;
  21 C: <tangle> tangle
  22
  23 : with-tangle ( tangle quot -- )
  24     [ [ db>> ] [ seq>> ] bi ] dip with-db ;
  25
  26 : node-response ( id -- response )
  27     load-node [ node-content "text/plain" <content> ] [ <404> ] if* ;
  28
  29 : display-node ( params -- response )
  30     [
  31         "node_id" swap at* [
  32             string>number node-response
  33         ] [
  34             drop <400>
  35         ] if
  36     ] [
  37         <400>
  38     ] if* ;
  39
  40 : submit-node ( params -- response )
  41     [
  42         "node_content" swap at* [
  43             create-node id>> number>string "text/plain" <content>
  44         ] [
  45             drop <400>
  46         ] if
  47     ] [
  48         <400>
  49     ] if* ;
  50
  51 : <node-responder> ( -- responder )
  52     <action> [ params get display-node ] >>display
  53     [ params get submit-node ] >>submit ;
  54
  55 TUPLE: path-responder ;
  56 C: <path-responder> path-responder
  57
  58 M: path-responder call-responder* ( path responder -- response )
  59     drop path>file [ node-content "text/plain" <content> ] [ <404> ] if* ;
  60
  61 TUPLE: tangle-dispatcher < dispatcher tangle ;
  62
  63 : <tangle-dispatcher> ( tangle -- dispatcher )
  64     tangle-dispatcher new-dispatcher swap >>tangle
  65     <path-responder> >>default
  66     "resource:extra/tangle/resources" <static> "resources" add-responder
  67     <node-responder> "node" add-responder
  68     <action> [ all-node-ids <json-content> ] >>display "all" add-responder ;
  69
  70 M: tangle-dispatcher call-responder* ( path dispatcher -- response )
  71     dup tangle>> [
  72         find-responder call-responder
  73     ] with-tangle ;