extra/webapps/imagebin/imagebin.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors furnace.actions furnace.redirection http.server
   4 http.server.dispatchers io.directories io.encodings.utf8 io.files
   5 io.pathnames kernel math math.parser namespaces sequences
   6 webapps.utils ;
   7 IN: webapps.imagebin
   8
   9 TUPLE: imagebin < dispatcher path n ;
  10
  11 : <uploaded-image-action> ( -- action )
  12     <page-action>
  13         { imagebin "uploaded-image" } >>template ;
  14
  15 : next-image-path ( -- path )
  16     imagebin get
  17     [ path>> ] [ [ 1 + ] change-n n>> number>string ] bi append-path ;
  18
  19 M: imagebin call-responder*
  20     [ imagebin set ] [ call-next-method ] bi ;
  21
  22 : move-image ( mime-file -- )
  23     [ next-image-path dup file-exists? ] [ drop ] while
  24     [ [ temporary-path>> ] dip move-file ]
  25     [ [ filename>> ] dip ".txt" append utf8 set-file-contents ] 2bi ;
  26
  27 : <upload-image-action> ( -- action )
  28     <page-action>
  29         { imagebin "upload-image" } >>template
  30         [
  31             "file1" param [ move-image ] when*
  32             "file2" param [ move-image ] when*
  33             "file3" param [ move-image ] when*
  34             "uploaded-image" <redirect>
  35         ] >>submit ;
  36
  37 : <imagebin> ( image-directory -- responder )
  38     imagebin new-dispatcher
  39         swap [ make-directories ] [ >>path ] bi
  40         0 >>n
  41         <upload-image-action> "" add-responder
  42         <upload-image-action> "upload-image" add-responder
  43         <uploaded-image-action> "uploaded-image" add-responder ;
  44
  45 : start-imagebin ( -- )
  46     "resource:images" <imagebin> main-responder set-global
  47     run-test-httpd ;