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: accessors alien.libraries.finder assocs bootstrap.image
   4 hashtables io io.directories io.encodings.utf8 io.files
   5 io.files.temp io.launcher io.pathnames kernel locals make
   6 namespaces prettyprint sequences splitting system
   7 tools.deploy.config tools.deploy.config.editor
   8 tools.deploy.embed vocabs.loader vocabs.metadata.resources
   9 webbrowser ;
  10 IN: tools.deploy.backend
  11
  12 : copy-vm ( executable bundle-name -- vm-path )
  13     prepend-path vm-path over copy-file ;
  14
  15 TUPLE: vocab-manifest vocabs libraries ;
  16
  17 : copy-resources ( manifest name dir -- )
  18     append-path swap vocabs>> [ copy-vocab-resources ] with each ;
  19
  20 ERROR: can't-deploy-library-file library ;
  21
  22 : copy-library ( dir library -- )
  23     dup find-library*
  24     [ tuck file-name append-path copy-file ]
  25     [ can't-deploy-library-file ] ?if ;
  26
  27 : copy-libraries ( manifest name dir -- )
  28     append-path swap libraries>> [ copy-library ] with each ;
  29
  30 : deployed-image-name ( vocab -- str )
  31     ".image" append temp-file ;
  32
  33 : copy-lines ( -- )
  34     readln [ print flush copy-lines ] when* ;
  35
  36 : run-with-output ( arguments -- )
  37     <process>
  38         swap >>command
  39         +stdout+ >>stderr
  40         +closed+ >>stdin
  41         +low-priority+ >>priority
  42     utf8 [ copy-lines ] with-process-reader ;
  43
  44 : make-boot-image ( -- )
  45     ! If stage1 image doesn't exist, create one.
  46     my-boot-image-name resource-path file-exists?
  47     [ make-my-image ] unless ;
  48
  49 : staging-image-name ( profile -- name )
  50     "-" join "." my-arch-name 3append
  51     "staging." ".image" surround cache-file ;
  52
  53 : delete-staging-images ( -- )
  54     cache-directory [
  55         [ "staging." head? ] filter
  56         "." my-arch-name ".image" 3append [ tail? ] curry filter
  57         [ delete-file ] each
  58     ] with-directory-files ;
  59
  60 : input-image-name ( profile -- name )
  61     but-last [ my-boot-image-name ] [ staging-image-name ] if-empty ;
  62
  63 : run-factor ( vm-path flags -- )
  64     swap prefix dup . run-with-output ; inline
  65
  66 : staging-command-line ( profile -- flags )
  67     [
  68         [
  69             "-staging" , "-no-user-init" , "-pic=0" ,
  70             [ staging-image-name "-output-image=" prepend , ]
  71             [ unwords "-include=" prepend , ] bi
  72         ] [
  73             input-image-name "-i=" prepend ,
  74             "-resource-path=" "" resource-path append ,
  75             "-run=tools.deploy.restage" ,
  76         ] bi
  77     ] { } make ;
  78
  79 : make-staging-image ( profile -- )
  80     { } [ suffix ] accumulate* [ staging-image-name file-exists? ] reject
  81     [ staging-command-line ] map
  82     [ vm-path swap run-factor ] each ;
  83
  84 : make-deploy-config ( vocab -- file )
  85     [ deploy-config vocab-roots get vocab-roots associate assoc-union unparse-use ]
  86     [ "deploy-config-" prepend temp-file ] bi
  87     [ utf8 set-file-contents ] keep ;
  88
  89 : deploy-command-line ( image vocab manifest-file profile -- flags )
  90     [
  91         "-pic=0" ,
  92         staging-image-name "-i=" prepend ,
  93         "-vocab-manifest-out=" prepend ,
  94         [ "-deploy-vocab=" prepend , ]
  95         [ make-deploy-config "-deploy-config=" prepend , ] bi
  96         "-output-image=" prepend ,
  97         "-resource-path=" "" resource-path append ,
  98         "-run=tools.deploy.shaker" ,
  99     ] { } make ;
 100
 101 : parse-vocab-manifest-file ( path -- vocab-manifest )
 102     utf8 file-lines [ "empty vocab manifest!" throw ] [
 103         unclip-slice "VOCABS:" =
 104         [ { "LIBRARIES:" } split1 vocab-manifest boa ]
 105         [ "invalid vocab manifest!" throw ] if
 106     ] if-empty ;
 107
 108 :: make-deploy-image ( vm image vocab config -- manifest )
 109     make-boot-image
 110
 111     config config>profile :> profile
 112     vocab "vocab-manifest-" prepend temp-file :> manifest-file
 113     image vocab manifest-file profile deploy-command-line :> flags
 114
 115     profile make-staging-image
 116     vm flags run-factor
 117     manifest-file parse-vocab-manifest-file ;
 118
 119 :: make-deploy-image-executable ( vm image vocab config -- manifest )
 120     vm image vocab config make-deploy-image
 121     image vm embed-image ;
 122
 123 SYMBOL: open-directory-after-deploy?
 124 t open-directory-after-deploy? set-global
 125
 126 : maybe-open-deploy-directory ( directory -- )
 127     absolute-path open-directory-after-deploy? get
 128     [ open-item ] [ drop ] if ;
 129
 130 HOOK: deploy* os ( vocab -- )
 131
 132 HOOK: deploy-path os ( vocab -- path )