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 http.server.dispatchers kernel mason.platform
   5 mason.notify.server mason.report math.order sequences sorting
   6 splitting xml.syntax xml.writer io.pathnames io.encodings.utf8
   7 io.files present validators html.forms furnace.db assocs urls ;
   8 IN: webapps.mason
   9
  10 TUPLE: mason-app < dispatcher ;
  11
  12 : validate-os/cpu ( -- )
  13     {
  14         { "os" [ v-one-line ] }
  15         { "cpu" [ v-one-line ] }
  16     } validate-params ;
  17
  18 : current-builder ( -- builder )
  19     builder new "os" value >>os "cpu" value >>cpu select-tuple ;
  20
  21 : <build-report-action> ( -- action )
  22     <action>
  23     [ validate-os/cpu ] >>init
  24     [ current-builder last-report>> "text/html" <content> ] >>display ;
  25
  26 : log-file ( -- path ) home "mason.log" append-path ;
  27
  28 : recent-events ( -- xml )
  29     log-file utf8 10 file-tail [XML <pre><-></pre> XML] ;
  30
  31 : git-link ( id -- link )
  32     [ "http://github.com/slavapestov/factor/commit/" prepend ] keep
  33     [XML <a href=<->><-></a> XML] ;
  34
  35 : building ( builder string -- xml )
  36     swap current-git-id>> git-link
  37     [XML <-> for <-> XML] ;
  38
  39 : current-status ( builder -- xml )
  40     [
  41         dup status>> {
  42             { +dirty+ [ drop "Dirty" ] }
  43             { +clean+ [ drop "Clean" ] }
  44             { +error+ [ drop "Error" ] }
  45             { +starting+ [ "Starting build" building ] }
  46             { +make-vm+ [ "Compiling VM" building ] }
  47             { +boot+ [ "Bootstrapping" building ] }
  48             { +test+ [ "Testing" building ] }
  49             [ 2drop "Unknown" ]
  50         } case
  51     ] [ current-timestamp>> present " (as of " ")" surround ] bi 2array ;
  52
  53 : build-status ( git-id timestamp -- xml )
  54     over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ;
  55
  56 : binaries-url ( builder -- url )
  57     [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend ;
  58
  59 : url-link ( url -- xml )
  60     dup [XML <a href=<->><-></a> XML] ;
  61
  62 : latest-binary-link ( builder -- xml )
  63     [ URL" download" ] dip
  64     [ os>> "os" set-query-param ]
  65     [ cpu>> "cpu" set-query-param ] bi
  66     [XML <a href=<->>Latest download</a> XML] ;
  67
  68 : binaries-link ( builder -- link )
  69     binaries-url url-link ;
  70
  71 : clean-image-url ( builder -- url )
  72     [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend ;
  73
  74 : clean-image-link ( builder -- link )
  75     clean-image-url url-link ;
  76
  77 : report-link ( builder -- xml )
  78     [ URL" report" ] dip
  79     [ os>> "os" set-query-param ]
  80     [ cpu>> "cpu" set-query-param ] bi
  81     [XML <a href=<->>Latest build report</a> XML] ;
  82
  83 : machine-table ( builder -- xml )
  84     {
  85         [ os>> ]
  86         [ cpu>> ]
  87         [ host-name>> "." split1 drop ]
  88         [ current-status ]
  89         [ [ last-git-id>> ] [ last-timestamp>> ] bi build-status ]
  90         [ [ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ]
  91         [ binaries-link ]
  92         [ clean-image-link ]
  93         [ report-link ]
  94         [ latest-binary-link ]
  95     } cleave
  96     [XML
  97     <h2><-> / <-></h2>
  98     <table border="1">
  99     <tr><td>Host name:</td><td><-></td></tr>
 100     <tr><td>Current status:</td><td><-></td></tr>
 101     <tr><td>Last build:</td><td><-></td></tr>
 102     <tr><td>Last clean build:</td><td><-></td></tr>
 103     <tr><td>Binaries:</td><td><-></td></tr>
 104     <tr><td>Clean images:</td><td><-></td></tr>
 105     </table>
 106
 107     <-> | <->
 108     XML] ;
 109
 110 : machine-report ( -- xml )
 111     builder new select-tuples
 112     [ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort
 113     [ machine-table ] map ;
 114
 115 : build-farm-summary ( -- xml )
 116     recent-events
 117     machine-report
 118     [XML
 119     <html>
 120     <head><title>Factor build farm</title></head>
 121     <body><h1>Recent events</h1><-> <h1>Machine status</h1><-></body>
 122     </html>
 123     XML] ;
 124
 125 : <summary-action> ( -- action )
 126     <action>
 127     [ build-farm-summary xml>string "text/html" <content> ] >>display ;
 128
 129 TUPLE: builder-link href title ;
 130
 131 C: <builder-link> builder-link
 132
 133 : requirements ( builder -- xml )
 134     [
 135         os>> {
 136             { "winnt" "Windows XP (also tested on Vista)" }
 137             { "macosx" "Mac OS X 10.5 Leopard" }
 138             { "linux" "Linux 2.6.16 with GLIBC 2.4" }
 139             { "freebsd" "FreeBSD 7.0" }
 140             { "netbsd" "NetBSD 4.0" }
 141             { "openbsd" "OpenBSD 4.2" }
 142         } at
 143     ] [
 144         dup cpu>> "x86-32" = [
 145             os>> {
 146                 { [ dup { "winnt" "linux" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] }
 147                 { [ dup { "freebsd" "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
 148                 { [ t ] [ drop f ] }
 149             } cond
 150         ] [ drop f ] if
 151     ] bi
 152     2array sift [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ;
 153
 154 : <download-binary-action> ( -- action )
 155     <page-action>
 156     [
 157         validate-os/cpu
 158         "os" value "cpu" value (platform) "platform" set-value
 159         current-builder
 160         [ latest-binary-link "package" set-value ]
 161         [ release-git-id>> git-link "git-id" set-value ]
 162         [ requirements "requirements" set-value ]
 163         tri
 164     ] >>init
 165     { mason-app "download" } >>template ;
 166
 167 : <mason-app> ( -- dispatcher )
 168     mason-app new-dispatcher
 169     <summary-action> "" add-responder
 170     <build-report-action> "report" add-responder
 171     <download-binary-action> "download" add-responder
 172     mason-db <db-persistence> ;
 173