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

http://github.com/abeaumont/factor · Factor · 79 lines · 65 code · 12 blank · 2 comment · 3 complexity · ff937166fa3c60f79ecb9aae9fc20cbb MD5 · raw file

  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. : building ( builder string -- xml )
  10. swap current-git-id>> git-link
  11. [XML <-> for <-> XML] ;
  12. : status-string ( builder -- string )
  13. dup status>> {
  14. { +idle+ [ drop "Idle" ] }
  15. { +starting+ [ "Starting build" building ] }
  16. { +make-vm+ [ "Compiling VM" building ] }
  17. { +boot+ [ "Bootstrapping" building ] }
  18. { +test+ [ "Testing" building ] }
  19. { +upload+ [ "Uploading package" building ] }
  20. { +finish+ [ "Finishing build" building ] }
  21. { +dirty+ [ drop "Dirty" ] }
  22. { +clean+ [ drop "Clean" ] }
  23. { +error+ [ drop "Error" ] }
  24. [ 2drop "Unknown" ]
  25. } case ;
  26. : current-status ( builder -- xml )
  27. [ status-string ]
  28. [ current-timestamp>> present " (as of " ")" surround ] bi
  29. 2array ;
  30. : build-status ( git-id timestamp -- xml )
  31. over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ;
  32. : packages-url ( builder -- url )
  33. platform download-url ;
  34. : package-link ( builder -- xml )
  35. [ packages-url ] [ last-release>> ] bi [ "/" glue ] keep link ;
  36. : packages-link ( builder -- link )
  37. packages-url dup link ;
  38. : clean-image-url ( builder -- url )
  39. platform "http://downloads.factorcode.org/images/clean/" prepend ;
  40. : clean-image-link ( builder -- link )
  41. clean-image-url dup link ;
  42. : last-build-status ( builder -- xml )
  43. [ last-git-id>> ] [ last-timestamp>> ] bi build-status ;
  44. : clean-build-status ( builder -- xml )
  45. [ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ;
  46. : <download-package-action> ( -- action )
  47. <page-action>
  48. [
  49. [
  50. validate-os/cpu
  51. "os" value "cpu" value (platform) "platform" set-value
  52. current-builder {
  53. [ package-link "package" set-value ]
  54. [ release-git-id>> git-link "git-id" set-value ]
  55. [ requirements "requirements" set-value ]
  56. [ host-name>> "host-name" set-value ]
  57. [ heartbeat-timestamp>> "heartbeat-timestamp" set-value ]
  58. [ current-status "status" set-value ]
  59. [ last-build-status "last-build" set-value ]
  60. [ clean-build-status "last-clean-build" set-value ]
  61. [ current-timestamp>> "current-timestamp" set-value ]
  62. [ packages-link "binaries" set-value ]
  63. [ clean-image-link "clean-images" set-value ]
  64. [ report-link "last-report" set-value ]
  65. } cleave
  66. ] with-mason-db
  67. ] >>init ;