/extra/webapps/mason/package/package.factor

 1! Copyright (C) 2010 Slava Pestov.
 2! See http://factorcode.org/license.txt for BSD license.
 3USING: accessors arrays combinators furnace.actions html.forms
 4kernel xml.syntax mason.platform mason.report present
 5sequences webapps.mason webapps.mason.report
 6webapps.mason.backend webapps.mason.utils ;
 7FROM: webapps.mason.version.files => platform ;
 8IN: 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                [ package-link "package" set-value ]
66                [ release-git-id>> git-link "git-id" set-value ]
67                [ requirements "requirements" set-value ]
68                [ host-name>> "host-name" set-value ]
69                [ heartbeat-timestamp>> "heartbeat-timestamp" set-value ]
70                [ current-status "status" set-value ]
71                [ last-build-status "last-build" set-value ]
72                [ clean-build-status "last-clean-build" set-value ]
73                [ current-timestamp>> "current-timestamp" set-value ]
74                [ packages-link "binaries" set-value ]
75                [ clean-image-link "clean-images" set-value ]
76                [ report-link "last-report" set-value ]
77            } cleave
78        ] with-mason-db
79    ] >>init ;