extra/webapps/mason/package/package.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators furnace.actions html.forms
   4 kernel xml.syntax mason.platform mason.report present
   5 sequences webapps.mason webapps.mason.report
   6 webapps.mason.backend webapps.mason.utils ;
   7 FROM: webapps.mason.version.files => platform ;
   8 IN: webapps.mason.package
   9
  10 : building ( builder string -- xml )
  11     swap current-git-id>> git-link
  12     [XML <-> for <-> XML] ;
  13
  14 : status-string ( builder -- string )
  15     dup status>> {
  16         { +idle+ [ drop "Idle" ] }
  17         { +starting+ [ "Starting build" building ] }
  18         { +make-vm+ [ "Compiling VM" building ] }
  19         { +boot+ [ "Bootstrapping" building ] }
  20         { +test+ [ "Testing" building ] }
  21         { +upload+ [ "Uploading package" building ] }
  22         { +finish+ [ "Finishing build" building ] }
  23         { +dirty+ [ drop "Dirty" ] }
  24         { +clean+ [ drop "Clean" ] }
  25         { +error+ [ drop "Error" ] }
  26         [ 2drop "Unknown" ]
  27     } case ;
  28
  29 : current-status ( builder -- xml )
  30     [ status-string ]
  31     [ current-timestamp>> present " (as of " ")" surround ] bi
  32     2array ;
  33
  34 : build-status ( git-id timestamp -- xml )
  35     over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ;
  36
  37 : packages-url ( builder -- url )
  38     platform download-url ;
  39
  40 : package-link ( builder -- xml )
  41     [ packages-url ] [ last-release>> ] bi [ "/" glue ] keep link ;
  42
  43 : packages-link ( builder -- link )
  44     packages-url dup link ;
  45
  46 : clean-image-url ( builder -- url )
  47     platform "http://downloads.factorcode.org/images/clean/" prepend ;
  48
  49 : clean-image-link ( builder -- link )
  50     clean-image-url dup link ;
  51
  52 : last-build-status ( builder -- xml )
  53     [ last-git-id>> ] [ last-timestamp>> ] bi build-status ;
  54
  55 : clean-build-status ( builder -- xml )
  56     [ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ;
  57
  58 : <download-package-action> ( -- action )
  59     <page-action>
  60     [
  61         [
  62             validate-os/cpu
  63             "os" value "cpu" value (platform) "platform" set-value
  64             current-builder [
  65                 {
  66                     [ package-link "package" set-value ]
  67                     [ release-git-id>> git-link "git-id" set-value ]
  68                     [ requirements "requirements" set-value ]
  69                     [ host-name>> "host-name" set-value ]
  70                     [ heartbeat-timestamp>> "heartbeat-timestamp" set-value ]
  71                     [ current-status "status" set-value ]
  72                     [ last-build-status "last-build" set-value ]
  73                     [ clean-build-status "last-clean-build" set-value ]
  74                     [ current-timestamp>> "current-timestamp" set-value ]
  75                     [ packages-link "binaries" set-value ]
  76                     [ clean-image-link "clean-images" set-value ]
  77                     [ report-link "last-report" set-value ]
  78                 } cleave
  79             ] when*
  80         ] with-mason-db
  81     ] >>init ;