extra/mason/git/git.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators.short-circuit continuations
   4 debugger io io.directories io.directories.hierarchy
   5 io.encodings.utf8 io.files io.launcher io.sockets
   6 io.streams.string kernel mason.common mason.email sequences
   7 splitting ;
   8 IN: mason.git
   9
  10 : git-id ( -- id )
  11     { "git" "show" } utf8 [ lines ] with-process-reader
  12     first " " split second ;
  13
  14 <PRIVATE
  15
  16 : git-clone-cmd ( -- cmd )
  17     {
  18         "git"
  19         "clone"
  20         "git://factorcode.org/git/factor.git"
  21     } ;
  22
  23 : git-clone ( -- )
  24     #! Must be run from builds-dir
  25     "Cloning initial repository" print-timestamp
  26     git-clone-cmd try-output-process ;
  27
  28 : git-pull-cmd ( -- cmd )
  29     {
  30         "git"
  31         "pull"
  32         "git://factorcode.org/git/factor.git"
  33         "master"
  34     } ;
  35
  36 : repo-corrupted-body ( error -- string )
  37     [
  38         "Corrupted repository on " write host-name write " will be re-cloned." print
  39         "Error while pulling was:" print
  40         nl
  41         error.
  42     ] with-string-writer ;
  43
  44 : git-repo-corrupted ( error -- )
  45     repo-corrupted-body "corrupted repo" email-fatal
  46     "factor" delete-tree
  47     git-clone ;
  48
  49 : git-pull-failed ( error -- )
  50     dup output-process-error? [
  51         dup output>> "not uptodate. Cannot merge." swap subseq?
  52         [ git-repo-corrupted ]
  53         [ rethrow ]
  54         if
  55     ] [ rethrow ] if ;
  56
  57 : with-process-reader* ( desc encoding quot -- )
  58     [ <process-reader*> ] dip swap [ with-input-stream ] dip
  59     dup wait-for-process dup { 0 1 } member?
  60     [ 2drop ] [ process-failed ] if ; inline
  61
  62 : git-status-cmd ( -- cmd )
  63     { "git" "status" } ;
  64
  65 : git-status-failed ( error -- )
  66     #! Exit code 1 means there's nothing to commit.
  67     dup { [ process-failed? ] [ code>> 1 = ] } 1&&
  68     [ drop ] [ rethrow ] if ;
  69
  70 : git-status ( -- seq )
  71     [
  72         git-status-cmd utf8 [ lines ] with-process-reader*
  73         [ "#\t" head? ] filter
  74     ] [ git-status-failed { } ] recover ;
  75
  76 : check-repository ( -- seq )
  77     "factor" [ git-status ] with-directory ;
  78
  79 : repo-dirty-body ( error -- string )
  80     [
  81         "Dirty repository on " write host-name write " will be re-cloned." print
  82         "Modified and untracked files:" print nl
  83         [ print ] each
  84     ] with-string-writer ;
  85
  86 : git-repo-dirty ( files -- )
  87     repo-dirty-body "dirty repo" email-fatal
  88     "factor" delete-tree
  89     git-clone ;
  90
  91 PRIVATE>
  92
  93 : git-pull ( -- id )
  94     #! Must be run from builds-dir.
  95     "factor" exists? [
  96         check-repository [
  97             "factor" [
  98                 [ git-pull-cmd short-running-process ]
  99                 [ git-pull-failed ]
 100                 recover
 101             ] with-directory
 102         ] [ git-repo-dirty ] if-empty
 103     ] [ git-clone ] if
 104     "factor" [ git-id ] with-directory ;