extra/webapps/fjsc/fjsc.factor

   1 ! Copyright (C) 2008 Chris Double. All Rights Reserved.
   2 USING:
   3     accessors
   4     fjsc
   5     furnace
   6     furnace.actions
   7     furnace.boilerplate
   8     furnace.redirection
   9     furnace.utilities
  10     html.forms
  11     http
  12     http.client
  13     http.server
  14     http.server.dispatchers
  15     http.server.responses
  16     http.server.static
  17     io
  18     io.pathnames
  19     io.streams.string
  20     kernel
  21     namespaces
  22     peg
  23     sequences
  24     urls
  25     validators
  26 ;
  27 IN: webapps.fjsc
  28
  29 TUPLE: fjsc < dispatcher ;
  30
  31 : absolute-url ( url -- url )
  32     "http://" request get "host" header append
  33     over "/" head? [ "/" append ] unless
  34     swap append  ;
  35
  36 : <javascript-content> ( body -- content )
  37     "application/javascript" <content> ;
  38
  39 : do-compile-url ( url -- response )
  40     [
  41         absolute-url http-get nip 'expression' parse
  42         fjsc-compile write "();" write
  43     ] with-string-writer
  44     <javascript-content> ;
  45
  46 : v-local ( string -- string )
  47     dup "http:" head? [ "Unable to compile code from remote sites" throw ] when ;
  48
  49 : validate-compile-url ( -- )
  50     {
  51         { "url" [ v-required v-local ] }
  52     } validate-params ;
  53
  54 : <compile-url-action> ( -- action )
  55     <action>
  56         [ validate-compile-url ] >>validate
  57         [ "url" value do-compile-url ] >>submit
  58         [ validate-compile-url "url" value do-compile-url ] >>display ;
  59
  60 : do-compile ( code -- response )
  61     [
  62         'expression' parse fjsc-compile write
  63     ] with-string-writer
  64     <javascript-content> ;
  65
  66 : validate-compile ( -- )
  67     {
  68         { "code" [ v-required ] }
  69     } validate-params ;
  70
  71 : <compile-action> ( -- action )
  72     <action>
  73         [ validate-compile ] >>validate
  74         [ "code" value do-compile ] >>submit
  75         [ validate-compile "code" value do-compile ] >>display ;
  76
  77 : <main-action> ( -- action )
  78     <page-action>
  79         { fjsc "main" } >>template ;
  80
  81 : <fjsc> ( -- fjsc )
  82     dispatcher new-dispatcher
  83         "extra/webapps/fjsc/www" resource-path <static> "static" add-responder
  84         "extra/fjsc/resources" resource-path <static> "fjsc" add-responder
  85         fjsc new-dispatcher
  86             <main-action> "" add-responder
  87             <compile-action> "compile" add-responder
  88             <compile-url-action> "compile-url" add-responder
  89             <boilerplate>
  90                 { fjsc "fjsc" } >>template
  91          >>default ;
  92
  93 : activate-fjsc ( -- )
  94     <fjsc> main-responder set-global ;