extra/mason/git/git.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors continuations debugger io io.directories
   4 io.encodings.utf8 io.files io.launcher io.sockets
   5 io.streams.string kernel mason.common mason.email sequences
   6 splitting ;
   7 IN: mason.git
   8
   9 : git-id ( -- id )
  10     { "git" "show" } utf8 [ read-lines ] with-process-reader
  11     first split-words second ;
  12
  13 <PRIVATE
  14
  15 : git-clone-cmd ( -- cmd )
  16     {
  17         "git"
  18         "clone"
  19         "https://github.com/factor/factor.git"
  20     } ;
  21
  22 : git-clone ( -- )
  23     ! Must be run from builds-dir
  24     "Cloning initial repository" print-timestamp
  25     git-clone-cmd try-output-process ;
  26
  27 : git-pull-cmd ( -- cmd )
  28     {
  29         "git"
  30         "pull"
  31         "https://github.com/factor/factor.git"
  32         "master"
  33     } ;
  34
  35 : repo-corrupted-body ( error -- string )
  36     [
  37         "Corrupted repository on " write host-name write " will be re-cloned." print
  38         "Error while pulling was:" print
  39         nl
  40         error.
  41     ] with-string-writer ;
  42
  43 : git-repo-corrupted ( error -- )
  44     repo-corrupted-body "corrupted repo" email-fatal
  45     "factor" delete-tree
  46     git-clone ;
  47
  48 : git-pull-failed ( error -- )
  49     dup output-process-error? [
  50         dup output>> "not uptodate. Cannot merge." subseq-of?
  51         [ git-repo-corrupted ]
  52         [ rethrow ]
  53         if
  54     ] [ rethrow ] if ;
  55
  56 : git-status-cmd ( -- cmd )
  57     { "git" "status" "--porcelain" } ;
  58
  59 : git-status ( -- seq )
  60     git-status-cmd utf8 [ read-lines ] with-process-reader ;
  61
  62 : check-repository ( -- seq )
  63     "factor" [ git-status ] with-directory ;
  64
  65 : repo-dirty-body ( error -- string )
  66     [
  67         "Dirty repository on " write host-name write " will be re-cloned." print
  68         "Modified and untracked files:" print nl
  69         [ print ] each
  70     ] with-string-writer ;
  71
  72 : git-repo-dirty ( files -- )
  73     repo-dirty-body "dirty repo" email-fatal
  74     "factor" delete-tree
  75     git-clone ;
  76
  77 PRIVATE>
  78
  79 : git-clone-or-pull ( -- id )
  80     ! Must be run from builds-dir.
  81     "factor" file-exists? [
  82         check-repository [
  83             "factor" [
  84                 [ git-pull-cmd short-running-process ]
  85                 [ git-pull-failed ]
  86                 recover
  87             ] with-directory
  88         ] [ git-repo-dirty ] if-empty
  89     ] [ git-clone ] if
  90     "factor" [ git-id ] with-directory ;