basis/tools/deploy/deploy-tests.factor

   1 IN: tools.deploy.tests\r
   2 USING: tools.test system io.pathnames io.files io.files.info\r
   3 io.files.temp kernel tools.deploy.config\r
   4 tools.deploy.config.editor tools.deploy.backend math sequences\r
   5 io.launcher arrays namespaces continuations layouts accessors\r
   6 io.encodings.ascii urls math.parser io.directories ;\r
   7 \r
   8 : shake-and-bake ( vocab -- )\r
   9     [ "test.image" temp-file delete-file ] ignore-errors\r
  10     "resource:" [\r
  11         [ vm "test.image" temp-file ] dip\r
  12         dup deploy-config make-deploy-image\r
  13     ] with-directory ;\r
  14 \r
  15 : small-enough? ( n -- ? )\r
  16     [ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;\r
  17 \r
  18 [ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test\r
  19 \r
  20 [ t ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test\r
  21 \r
  22 [ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test\r
  23 \r
  24 [ "staging.math-compiler-threads-ui-strip.image" ] [\r
  25     "hello-ui" deploy-config\r
  26     [ bootstrap-profile staging-image-name file-name ] bind\r
  27 ] unit-test\r
  28 \r
  29 [ t ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test\r
  30 \r
  31 [ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test\r
  32 \r
  33 [ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test\r
  34 \r
  35 os macosx? [\r
  36     [ t ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test\r
  37 ] when\r
  38 \r
  39 : run-temp-image ( -- )\r
  40     vm\r
  41     "-i=" "test.image" temp-file append\r
  42     2array try-process ;\r
  43 \r
  44 {\r
  45     "tools.deploy.test.1"\r
  46     "tools.deploy.test.2"\r
  47     "tools.deploy.test.3"\r
  48     "tools.deploy.test.4"\r
  49 } [\r
  50     [ ] swap [\r
  51         shake-and-bake\r
  52         run-temp-image\r
  53     ] curry unit-test\r
  54 ] each\r
  55 \r
  56 USING: http.client http.server http.server.dispatchers\r
  57 http.server.responses http.server.static io.servers.connection ;\r
  58 \r
  59 SINGLETON: quit-responder\r
  60 \r
  61 M: quit-responder call-responder*\r
  62     2drop stop-this-server "Goodbye" "text/html" <content> ;\r
  63 \r
  64 : add-quot-responder ( responder -- responder )\r
  65     quit-responder "quit" add-responder ;\r
  66 \r
  67 : test-httpd ( responder -- )\r
  68     [\r
  69         main-responder set\r
  70         <http-server>\r
  71             0 >>insecure\r
  72             f >>secure\r
  73         dup start-server*\r
  74         sockets>> first addr>> port>>\r
  75         dup number>string "resource:temp/port-number" ascii set-file-contents\r
  76     ] with-scope\r
  77     "port" set ;\r
  78 \r
  79 [ ] [\r
  80     <dispatcher>\r
  81         add-quot-responder\r
  82         "resource:basis/http/test" <static> >>default\r
  83 \r
  84     test-httpd\r
  85 ] unit-test\r
  86 \r
  87 [ ] [\r
  88     "tools.deploy.test.5" shake-and-bake\r
  89     run-temp-image\r
  90 ] unit-test\r
  91 \r
  92 : add-port ( url -- url' )\r
  93     >url clone "port" get >>port ;\r
  94 \r
  95 [ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test\r
  96 \r
  97 [ ] [\r
  98     "tools.deploy.test.6" shake-and-bake\r
  99     run-temp-image\r
 100 ] unit-test\r
 101 \r
 102 [ ] [\r
 103     "tools.deploy.test.7" shake-and-bake\r
 104     run-temp-image\r
 105 ] unit-test\r
 106 \r
 107 [ ] [\r
 108     "tools.deploy.test.8" shake-and-bake\r
 109     run-temp-image\r
 110 ] unit-test\r
 111 \r
 112 [ ] [\r
 113     "tools.deploy.test.9" shake-and-bake\r
 114     run-temp-image\r
 115 ] unit-test\r