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 urls ;
   8 FROM: assocs => at keys values ;
   9 IN: webapps.mason
  10
  11 TUPLE: mason-app < dispatcher ;
  12
  13 : link ( url label -- xml )
  14     [XML <a href=<->><-></a> XML] ;
  15
  16 : download-link ( builder label -- xml )
  17     [
  18         [ URL" http://builds.factorcode.org/download" ] dip
  19         [ os>> "os" set-query-param ]
  20         [ cpu>> "cpu" set-query-param ] bi
  21     ] dip link ;
  22
  23 : download-grid-cell ( cpu os -- xml )
  24     builder new swap >>os swap >>cpu select-tuple [
  25         dup last-release>> dup
  26         [ "." split1 drop 16 tail* 6 head* download-link ] [ 2drop f ] if
  27         [XML <td class="supported"><div class="bigdiv"><-></div></td> XML]
  28     ] [
  29         [XML <td class="doesnotexist" /> XML]
  30     ] if* ;
  31
  32 CONSTANT: oses
  33 {
  34     { "winnt" "Windows" }
  35     { "macosx" "Mac OS X" }
  36     { "linux" "Linux" }
  37     { "freebsd" "FreeBSD" }
  38     { "netbsd" "NetBSD" }
  39     { "openbsd" "OpenBSD" }
  40 }
  41
  42 CONSTANT: cpus
  43 {
  44     { "x86.32" "x86" }
  45     { "x86.64" "x86-64" }
  46     { "ppc" "PowerPC" }
  47 }
  48
  49 : download-grid ( -- xml )
  50     oses
  51     [ values [ [XML <th align='center' scope='col'><-></th> XML] ] map ]
  52     [
  53         keys
  54         cpus [
  55             [ nip second ] [ first ] 2bi [
  56                 swap download-grid-cell
  57             ] curry map
  58             [XML <tr><th align='center' scope='row'><-></th><-></tr> XML]
  59         ] with map
  60     ] bi
  61     [XML
  62         <table id="downloads" cellspacing="0">
  63             <tr><th class="nobg">OS/CPU</th><-></tr>
  64             <->
  65         </table>
  66     XML] ;
  67
  68 : <download-grid-action> ( -- action )
  69     <action>
  70     [ download-grid xml>string "text/html" <content> ] >>display ;
  71
  72 : validate-os/cpu ( -- )
  73     {
  74         { "os" [ v-one-line ] }
  75         { "cpu" [ v-one-line ] }
  76     } validate-params ;
  77
  78 : current-builder ( -- builder )
  79     builder new "os" value >>os "cpu" value >>cpu select-tuple ;
  80
  81 : <build-report-action> ( -- action )
  82     <action>
  83     [ validate-os/cpu ] >>init
  84     [ current-builder last-report>> "text/html" <content> ] >>display ;
  85
  86 : git-link ( id -- link )
  87     [ "http://github.com/slavapestov/factor/commit/" prepend ] keep
  88     [XML <a href=<->><-></a> XML] ;
  89
  90 : building ( builder string -- xml )
  91     swap current-git-id>> git-link
  92     [XML <-> for <-> XML] ;
  93
  94 : status-string ( builder -- string )
  95     dup status>> {
  96         { +dirty+ [ drop "Dirty" ] }
  97         { +clean+ [ drop "Clean" ] }
  98         { +error+ [ drop "Error" ] }
  99         { +starting+ [ "Starting build" building ] }
 100         { +make-vm+ [ "Compiling VM" building ] }
 101         { +boot+ [ "Bootstrapping" building ] }
 102         { +test+ [ "Testing" building ] }
 103         [ 2drop "Unknown" ]
 104     } case ;
 105
 106 : current-status ( builder -- xml )
 107     [ status-string ]
 108     [ current-timestamp>> present " (as of " ")" surround ] bi
 109     2array ;
 110
 111 : build-status ( git-id timestamp -- xml )
 112     over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ;
 113
 114 : binaries-url ( builder -- url )
 115     [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend ;
 116
 117 : latest-binary-link ( builder -- xml )
 118     [ binaries-url ] [ last-release>> ] bi [ "/" glue ] keep link ;
 119
 120 : binaries-link ( builder -- link )
 121     binaries-url dup link ;
 122
 123 : clean-image-url ( builder -- url )
 124     [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend ;
 125
 126 : clean-image-link ( builder -- link )
 127     clean-image-url dup link ;
 128
 129 : report-link ( builder -- xml )
 130     [ URL" report" ] dip
 131     [ os>> "os" set-query-param ]
 132     [ cpu>> "cpu" set-query-param ] bi
 133     [XML <a href=<->>Latest build report</a> XML] ;
 134
 135 : requirements ( builder -- xml )
 136     [
 137         os>> {
 138             { "winnt" "Windows XP, Windows Vista or Windows 7" }
 139             { "macosx" "Mac OS X 10.5 Leopard" }
 140             { "linux" "Ubuntu Linux 9.04 (other distributions may also work)" }
 141             { "freebsd" "FreeBSD 7.1" }
 142             { "netbsd" "NetBSD 5.0" }
 143             { "openbsd" "OpenBSD 4.4" }
 144         } at
 145     ] [
 146         dup cpu>> "x86.32" = [
 147             os>> {
 148                 { [ dup { "winnt" "linux" "freebsd"  "netbsd" } 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." ] }
 149                 { [ dup { "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
 150                 { [ t ] [ drop f ] }
 151             } cond
 152         ] [ drop f ] if
 153     ] bi
 154     2array sift [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ;
 155
 156 : last-build-status ( builder -- xml )
 157     [ last-git-id>> ] [ last-timestamp>> ] bi build-status ;
 158
 159 : clean-build-status ( builder -- xml )
 160     [ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ;
 161
 162 : <download-binary-action> ( -- action )
 163     <page-action>
 164     [
 165         validate-os/cpu
 166         "os" value "cpu" value (platform) "platform" set-value
 167         current-builder {
 168             [ latest-binary-link "package" set-value ]
 169             [ release-git-id>> git-link "git-id" set-value ]
 170             [ requirements "requirements" set-value ]
 171             [ host-name>> "host-name" set-value ]
 172             [ current-status "status" set-value ]
 173             [ last-build-status "last-build" set-value ]
 174             [ clean-build-status "last-clean-build" set-value ]
 175             [ binaries-link "binaries" set-value ]
 176             [ clean-image-link "clean-images" set-value ]
 177             [ report-link "last-report" set-value ]
 178         } cleave
 179     ] >>init
 180     { mason-app "download" } >>template ;
 181
 182 : <mason-app> ( -- dispatcher )
 183     mason-app new-dispatcher
 184     <build-report-action> "report" add-responder
 185     <download-binary-action> "download" add-responder
 186     <download-grid-action> "grid" add-responder
 187     mason-db <db-persistence> ;
 188