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