basis/tools/deploy/backend/backend.factor

   1 ! Copyright (C) 2007, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces make continuations.private kernel.private init
   4 assocs kernel vocabs words sequences memory io system arrays
   5 continuations math definitions mirrors splitting parser classes
   6 summary layouts vocabs.loader prettyprint.config prettyprint debugger
   7 io.streams.c io.files io.files.temp io.pathnames io.directories
   8 io.directories.hierarchy io.backend quotations io.launcher
   9 tools.deploy.config tools.deploy.config.editor bootstrap.image
  10 io.encodings.utf8 destructors accessors hashtables
  11 tools.deploy.libraries vocabs.metadata.resources
  12 tools.deploy.embed locals ;
  13 IN: tools.deploy.backend
  14
  15 : copy-vm ( executable bundle-name -- vm-path )
  16     prepend-path vm-path over copy-file ;
  17
  18 TUPLE: vocab-manifest vocabs libraries ;
  19
  20 : copy-resources ( manifest name dir -- )
  21     append-path swap vocabs>> [ copy-vocab-resources ] with each ;
  22
  23 ERROR: can't-deploy-library-file library ;
  24
  25 : copy-library ( dir library -- )
  26     dup find-library-file
  27     [ swap over file-name append-path copy-file ]
  28     [ throw-can't-deploy-library-file ] ?if ;
  29
  30 : copy-libraries ( manifest name dir -- )
  31     append-path swap libraries>> [ copy-library ] with each ;
  32
  33 : deployed-image-name ( vocab -- str )
  34     ".image" append temp-file ;
  35
  36 : copy-lines ( -- )
  37     readln [ print flush copy-lines ] when* ;
  38
  39 : run-with-output ( arguments -- )
  40     <process>
  41         swap >>command
  42         +stdout+ >>stderr
  43         +closed+ >>stdin
  44         +low-priority+ >>priority
  45     utf8 [ copy-lines ] with-process-reader ;
  46
  47 : make-boot-image ( -- )
  48     #! If stage1 image doesn't exist, create one.
  49     my-boot-image-name resource-path exists?
  50     [ make-my-image ] unless ;
  51
  52 : bootstrap-profile ( -- profile )
  53     [
  54         deploy-math? get [ "math" , ] when
  55         deploy-threads? get [ "threads" , ] when
  56         "compiler" ,
  57         deploy-help? get [ "help" , ] when
  58         native-io? [ "io" , ] when
  59         deploy-ui? get [ "ui" , ] when
  60         deploy-unicode? get [ "unicode" , ] when
  61
  62     ] { } make ;
  63
  64 : staging-image-name ( profile -- name )
  65     "-" join "." my-arch-name 3append
  66     "staging." ".image" surround cache-file ;
  67
  68 : delete-staging-images ( -- )
  69     cache-directory [
  70         [ "staging." head? ] filter
  71         "." my-arch-name ".image" 3append [ tail? ] curry filter
  72         [ delete-file ] each
  73     ] with-directory-files ;
  74
  75 : staging-command-line ( profile -- flags )
  76     [
  77         [
  78             "-staging" , "-no-user-init" , "-pic=0" ,
  79             [ staging-image-name "-output-image=" prepend , ]
  80             [ " " join "-include=" prepend , ] bi
  81         ] [
  82             [ "-i=" my-boot-image-name append , ] [
  83                 but-last staging-image-name "-i=" prepend ,
  84                 "-resource-path=" "" resource-path append ,
  85                 "-run=tools.deploy.restage" ,
  86             ] if-empty
  87         ] bi
  88     ] { } make ;
  89
  90 : run-factor ( vm-path flags -- )
  91     swap prefix dup . run-with-output ; inline
  92
  93 DEFER: ?make-staging-image
  94
  95 : make-staging-image ( profile -- )
  96     dup [ but-last ?make-staging-image ] unless-empty
  97     vm-path swap staging-command-line run-factor ;
  98
  99 : ?make-staging-image ( profile -- )
 100     dup staging-image-name exists?
 101     [ drop ] [ make-staging-image ] if ;
 102
 103 : make-deploy-config ( vocab -- file )
 104     [ deploy-config vocab-roots get vocab-roots associate assoc-union unparse-use ]
 105     [ "deploy-config-" prepend temp-file ] bi
 106     [ utf8 set-file-contents ] keep ;
 107
 108 : deploy-command-line ( image vocab manifest-file profile -- flags )
 109     [
 110         "-pic=0" ,
 111         staging-image-name "-i=" prepend ,
 112         "-vocab-manifest-out=" prepend ,
 113         [ "-deploy-vocab=" prepend , ]
 114         [ make-deploy-config "-deploy-config=" prepend , ] bi
 115         "-output-image=" prepend ,
 116         "-resource-path=" "" resource-path append ,
 117         "-run=tools.deploy.shaker" ,
 118     ] { } make ;
 119
 120 : parse-vocab-manifest-file ( path -- vocab-manifest )
 121     utf8 file-lines [ "empty vocab manifest!" throw ] [
 122         unclip-slice "VOCABS:" =
 123         [ { "LIBRARIES:" } split1 vocab-manifest boa ]
 124         [ "invalid vocab manifest!" throw ] if
 125     ] if-empty ;
 126
 127 :: make-deploy-image ( vm image vocab config -- manifest )
 128     make-boot-image
 129     config [
 130         bootstrap-profile :> profile
 131         vocab "vocab-manifest-" prepend temp-file :> manifest-file
 132         image vocab manifest-file profile deploy-command-line :> flags
 133         profile ?make-staging-image
 134         vm flags run-factor
 135         manifest-file parse-vocab-manifest-file
 136     ] with-variables ;
 137
 138 :: make-deploy-image-executable ( vm image vocab config -- manifest )
 139     vm image vocab config make-deploy-image
 140     image vm embed-image ;
 141
 142 SYMBOL: open-directory-after-deploy?
 143 t open-directory-after-deploy? set-global
 144
 145 HOOK: deploy* os ( vocab -- )
 146
 147 HOOK: deploy-path os ( vocab -- path )