extra/webapps/mason/mason.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators db db.tuples furnace.actions
   4 http.server.responses kernel mason.platform mason.notify.server
   5 math.order sequences sorting splitting xml.syntax xml.writer
   6 io.pathnames io.encodings.utf8 io.files ;
   7 IN: webapps.mason
   8
   9 : log-file ( -- path ) home "mason.log" append-path ;
  10
  11 : recent-events ( -- xml )
  12     log-file utf8 file-lines 10 short tail* "\n" join [XML <pre><-></pre> XML] ;
  13
  14 : git-link ( id -- link )
  15     [ "http://github.com/slavapestov/factor/commit/" prepend ] keep
  16     [XML <a href=<->><-></a> XML] ;
  17
  18 : building ( builder string -- xml )
  19     swap current-git-id>> git-link
  20     [XML <-> for <-> XML] ;
  21
  22 : current-status ( builder -- xml )
  23     dup status>> {
  24         { "dirty" [ drop "Dirty" ] }
  25         { "clean" [ drop "Clean" ] }
  26         { "starting" [ "Starting" building ] }
  27         { "make-vm" [ "Compiling VM" building ] }
  28         { "boot" [ "Bootstrapping" building ] }
  29         { "test" [ "Testing" building ] }
  30         [ 2drop "Unknown" ]
  31     } case ;
  32
  33 : binaries-link ( builder -- link )
  34     [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend
  35     dup [XML <a href=<->><-></a> XML] ;
  36
  37 : clean-image-link ( builder -- link )
  38     [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend
  39     dup [XML <a href=<->><-></a> XML] ;
  40
  41 : machine-table ( builder -- xml )
  42     {
  43         [ os>> ]
  44         [ cpu>> ]
  45         [ host-name>> "." split1 drop ]
  46         [ current-status ]
  47         [ last-git-id>> dup [ git-link ] when ]
  48         [ clean-git-id>> dup [ git-link ] when ]
  49         [ binaries-link ]
  50         [ clean-image-link ]
  51     } cleave
  52     [XML
  53     <h2><-> / <-></h2>
  54     <table border="1">
  55     <tr><td>Host name:</td><td><-></td></tr>
  56     <tr><td>Current status:</td><td><-></td></tr>
  57     <tr><td>Last build:</td><td><-></td></tr>
  58     <tr><td>Last clean build:</td><td><-></td></tr>
  59     <tr><td>Binaries:</td><td><-></td></tr>
  60     <tr><td>Clean images:</td><td><-></td></tr>
  61     </table>
  62     XML] ;
  63
  64 : machine-report ( -- xml )
  65     builder new select-tuples
  66     [ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort
  67     [ machine-table ] map ;
  68
  69 : build-farm-report ( -- xml )
  70     recent-events
  71     machine-report
  72     [XML
  73     <html>
  74     <head><title>Factor build farm</title></head>
  75     <body><h1>Recent events</h1><-> <h1>Machine status</h1><-></body>
  76     </html>
  77     XML] ;
  78
  79 : <build-farm-report-action> ( -- action )
  80     <action>
  81         [
  82             mason-db [ build-farm-report xml>string ] with-db
  83             "text/html" <content>
  84         ] >>display ;