extra/mason/common/common.factor

   1 ! Copyright (C) 2008, 2011 Eduardo Cavazos, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays calendar calendar.format combinators
   4 continuations fry io io.encodings.utf8 io.files io.launcher
   5 io.pathnames io.sockets kernel locals make mason.config math
   6 namespaces parser prettyprint prettyprint.config sequences
   7 splitting ;
   8 IN: mason.common
   9
  10 : print-timestamp ( string -- )
  11     now timestamp>string write bl print flush ;
  12
  13 ERROR: no-host-name ;
  14
  15 : short-host-name ( -- string )
  16     host-name "." split1 drop [ no-host-name ] unless* ;
  17
  18 SYMBOL: current-git-id
  19
  20 : short-running-process ( command -- )
  21     ! Give network operations and shell commands at most
  22     ! 30 minutes to complete, to catch hangs.
  23     >process
  24         30 minutes >>timeout
  25         +new-group+ >>group
  26     try-output-process ;
  27
  28 : retry ( n quot -- )
  29     [ iota ] dip
  30     '[ drop @ f ] attempt-all drop ; inline
  31
  32 : upload-process ( process -- )
  33     ! Give network operations and shell commands at most
  34     ! 30 minutes to complete, to catch hangs.
  35     >process
  36         upload-timeout get >>timeout
  37         +new-group+ >>group
  38     try-output-process ;
  39
  40 :: upload-safely ( local username host remote -- )
  41     remote ".incomplete" append :> temp
  42     { username "@" host ":" temp } concat :> scp-remote
  43     scp-command get :> scp
  44     ssh-command get :> ssh
  45     5 [ { scp local scp-remote } upload-process ] retry
  46     5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry ;
  47
  48 : eval-file ( file -- obj )
  49     dup utf8 file-lines parse-fresh
  50     [ "Empty file: " swap append throw ] [ nip first ] if-empty ;
  51
  52 : to-file ( object file -- ) utf8 [ [ . ] without-limits ] with-file-writer ;
  53
  54 : datestamp ( timestamp -- string )
  55     [
  56         {
  57             [ year>> , ]
  58             [ month>> , ]
  59             [ day>> , ]
  60             [ hour>> , ]
  61             [ minute>> , ]
  62         } cleave
  63     ] { } make [ pad-00 ] map "-" join ;
  64
  65 : nanos>time ( n -- string )
  66     1,000,000,000 /i 60 /mod [ 60 /mod ] dip 3array [ pad-00 ] map ":" join ;
  67
  68 SYMBOL: stamp
  69
  70 : build-dir ( -- path ) builds-dir get stamp get append-path ;
  71
  72 CONSTANT: load-all-vocabs-file "load-everything-vocabs"
  73 CONSTANT: load-all-errors-file "load-everything-errors"
  74
  75 CONSTANT: test-all-vocabs-file "test-all-vocabs"
  76 CONSTANT: test-all-errors-file "test-all-errors"
  77
  78 CONSTANT: help-lint-vocabs-file "help-lint-vocabs"
  79 CONSTANT: help-lint-errors-file "help-lint-errors"
  80
  81 CONSTANT: compiler-errors-file "compiler-errors"
  82 CONSTANT: compiler-error-messages-file "compiler-error-messages"
  83
  84 CONSTANT: boot-time-file "boot-time"
  85 CONSTANT: load-time-file "load-time"
  86 CONSTANT: test-time-file "test-time"
  87 CONSTANT: help-lint-time-file "help-lint-time"
  88 CONSTANT: benchmark-time-file "benchmark-time"
  89 CONSTANT: html-help-time-file "html-help-time"
  90
  91 CONSTANT: benchmarks-file "benchmarks"
  92 CONSTANT: benchmark-error-messages-file "benchmark-error-messages"
  93 CONSTANT: benchmark-error-vocabs-file "benchmark-error-vocabs"
  94
  95 SYMBOL: status-error ! didn't bootstrap, or crashed
  96 SYMBOL: status-dirty ! bootstrapped but not all tests passed
  97 SYMBOL: status-clean ! everything good