diff vext.sml @ 1746:bf4a7015033e

Update vext

--- a/vext.sml	Wed Oct 04 21:03:24 2017 +0100
+++ b/vext.sml	Fri Oct 06 13:28:35 2017 +0100
@@ -1,12 +1,16 @@
-(* This file is automatically generated from the individual 
-   source files in the Vext repository. *)
+(*
+    DO NOT EDIT THIS FILE.
+    This file is automatically generated from the individual
+    source files in the Vext repository.
+*)
 
 (* 
     Vext
 
     A simple manager for third-party source code dependencies
 
-    Copyright 2017 Chris Cannam.
+    Copyright 2017 Chris Cannam, Particular Programs Ltd,
+    and Queen Mary, University of London
 
     Permission is hereby granted, free of charge, to any person
     obtaining a copy of this software and associated documentation
@@ -27,13 +31,14 @@
     CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
     WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
-    Except as contained in this notice, the names of Chris Cannam and
-    Particular Programs Ltd shall not be used in advertising or
-    otherwise to promote the sale, use or other dealings in this
-    Software without prior written authorization.
+    Except as contained in this notice, the names of Chris Cannam,
+    Particular Programs Ltd, and Queen Mary, University of London
+    shall not be used in advertising or otherwise to promote the sale,
+    use or other dealings in this Software without prior written
+    authorization.
 *)
 
-val vext_version = "0.9.6"
+val vext_version = "0.9.8"
 
 
 datatype vcs =
@@ -131,6 +136,7 @@
     val project_file = "vext-project.json"
     val project_lock_file = "vext-lock.json"
     val user_config_file = ".vext.json"
+    val archive_dir = ".vext-archive"
 end
                    
 signature VCS_CONTROL = sig
@@ -192,6 +198,7 @@
     val mydir : unit -> string
     val homedir : unit -> string
     val mkpath : string -> unit result
+    val rmpath : string -> unit result
     val project_spec_path : string -> string
     val project_lock_path : string -> string
     val verbose : unit -> bool
@@ -376,6 +383,36 @@
                    | OK () => ((OS.FileSys.mkDir path; OK ())
                                handle OS.SysErr (e, _) =>
                                       ERROR ("Directory creation failed: " ^ e))
+
+    fun rmpath path =
+        let open OS
+            fun files_from dirstream =
+                case FileSys.readDir dirstream of
+                    NONE => []
+                  | SOME file =>
+                    (* readDir is supposed to filter these, 
+                       but let's be extra cautious: *)
+                    if file = Path.parentArc orelse file = Path.currentArc
+                    then files_from dirstream
+                    else file :: files_from dirstream
+            fun contents dir =
+                let val stream = FileSys.openDir dir
+                    val files = map (fn f => Path.joinDirFile
+                                                 { dir = dir, file = f })
+                                    (files_from stream)
+                    val _ = FileSys.closeDir stream
+                in files
+                end
+            fun remove path =
+                if FileSys.isLink path (* dangling links bother isDir *)
+                then FileSys.remove path
+                else if FileSys.isDir path
+                then (app remove (contents path); FileSys.rmDir path)
+                else FileSys.remove path
+        in
+            (remove path; OK ())
+            handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e)
+        end
 end
                                          
 functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct
@@ -1398,6 +1435,246 @@
         (fn HG => H.id_of | GIT => G.id_of) vcs context spec
 end
 
+
+type exclusions = string list
+              
+structure Archive :> sig
+
+    val archive : string * exclusions -> project -> OS.Process.status
+        
+end = struct
+
+    (* The idea of "archive" is to replace hg/git archive, which won't
+       include files, like the Vext-introduced external libraries,
+       that are not under version control with the main repo.
+
+       The process goes like this:
+
+       - Make sure we have a target filename from the user, and take
+         its basename as our archive directory name
+
+       - Make an "archive root" subdir of the project repo, named
+         typically .vext-archive
+       
+       - Identify the VCS used for the project repo. Note that any
+         explicit references to VCS type in this structure are to
+         the VCS used for the project (something Vext doesn't 
+         otherwise care about), not for an individual library
+
+       - Synthesise a Vext project with the archive root as its
+         root path, "." as its extdir, with one library whose
+         name is the user-supplied basename and whose explicit
+         source URL is the original project root; update that
+         project -- thus cloning the original project to a subdir
+         of the archive root
+
+       - Synthesise a Vext project identical to the original one for
+         this project, but with the newly-cloned copy as its root
+         path; update that project -- thus checking out clean copies
+         of the external library dirs
+
+       - Call out to an archive program to archive up the new copy,
+         running e.g.
+         tar cvzf project-release.tar.gz \
+             --exclude=.hg --exclude=.git project-release
+         in the archive root dir
+
+       - (We also omit the vext-project.json file and any trace of
+         Vext. It can't properly be run in a directory where the
+         external project folders already exist but their repo history
+         does not. End users shouldn't get to see Vext)
+
+       - Clean up by deleting the new copy
+    *)
+
+    fun project_vcs_and_id dir =
+        let val context = {
+                rootpath = dir,
+                extdir = ".",
+                providers = [],
+                accounts = []
+            }
+            val vcs_maybe = 
+                case [HgControl.exists context ".",
+                      GitControl.exists context "."] of
+                    [OK true, OK false] => OK HG
+                  | [OK false, OK true] => OK GIT
+                  | _ => ERROR ("Unable to identify VCS for directory " ^ dir)
+        in
+            case vcs_maybe of
+                ERROR e => ERROR e
+              | OK vcs =>
+                case (fn HG => HgControl.id_of | GIT => GitControl.id_of)
+                         vcs context "." of
+                    ERROR e => ERROR ("Unable to obtain id of project repo: "
+                                      ^ e)
+                  | OK id => OK (vcs, id)
+        end
+            
+    fun make_archive_root (context : context) =
+        let val path = OS.Path.joinDirFile {
+                    dir = #rootpath context,
+                    file = VextFilenames.archive_dir
+                }
+        in
+            case FileBits.mkpath path of
+                ERROR e => raise Fail ("Failed to create archive directory \""
+                                       ^ path ^ "\": " ^ e)
+              | OK () => path
+        end
+
+    fun archive_path archive_dir target_name =
+        OS.Path.joinDirFile {
+            dir = archive_dir,
+            file = target_name
+        }
+
+    fun check_nonexistent path =
+        case SOME (OS.FileSys.fileSize path) handle OS.SysErr _ => NONE of
+            NONE => ()
+          | _ => raise Fail ("Path " ^ path ^ " exists, not overwriting")
+            
+    fun file_url path =
+        let val forward_path = 
+                String.translate (fn #"\\" => "/" |
+                                     c => Char.toString c) path
+        in
+            (* Path is expected to be absolute already, but if it
+                starts with a drive letter, we'll need an extra slash *)
+            case explode forward_path of
+                #"/"::rest => "file:///" ^ implode rest
+              | _ => "file:///" ^ forward_path
+        end
+            
+    fun make_archive_copy target_name (vcs, project_id)
+                          ({ context, ... } : project) =
+        let val archive_root = make_archive_root context
+            val synthetic_context = {
+                rootpath = archive_root,
+                extdir = ".",
+                providers = [],
+                accounts = []
+            }
+            val synthetic_library = {
+                libname = target_name,
+                vcs = vcs,
+                source = URL_SOURCE (file_url (#rootpath context)),
+                branch = DEFAULT_BRANCH, (* overridden by pinned id below *)
+                project_pin = PINNED project_id,
+                lock_pin = PINNED project_id
+            }
+            val path = archive_path archive_root target_name
+            val _ = print ("Cloning original project to " ^ path
+                           ^ " at revision " ^ project_id ^ "...\n");
+            val _ = check_nonexistent path
+        in
+            case AnyLibControl.update synthetic_context synthetic_library of
+                ERROR e => ERROR ("Failed to clone original project to "
+                                  ^ path ^ ": " ^ e)
+              | OK _ => OK archive_root
+        end
+
+    fun update_archive archive_root target_name
+                       (project as { context, ... } : project) =
+        let val synthetic_context = {
+                rootpath = archive_path archive_root target_name,
+                extdir = #extdir context,
+                providers = #providers context,
+                accounts = #accounts context
+            }
+        in
+            foldl (fn (lib, acc) =>
+                      case acc of
+                          ERROR e => ERROR e
+                        | OK _ => AnyLibControl.update synthetic_context lib)
+                  (OK "")
+                  (#libs project)
+        end
+
+    datatype packer = TAR
+                    | TAR_GZ
+                    | TAR_BZ2
+                    | TAR_XZ
+    (* could add other packers, e.g. zip, if we knew how to
+       handle the file omissions etc properly in pack_archive *)
+                          
+    fun packer_and_basename path =
+        let val extensions = [ (".tar", TAR),
+                               (".tar.gz", TAR_GZ),
+                               (".tar.bz2", TAR_BZ2),
+                               (".tar.xz", TAR_XZ)]
+            val filename = OS.Path.file path
+        in
+            foldl (fn ((ext, packer), acc) =>
+                      if String.isSuffix ext filename
+                      then SOME (packer,
+                                 String.substring (filename, 0,
+                                                   String.size filename -
+                                                   String.size ext))
+                      else acc)
+                  NONE
+                  extensions
+        end
+            
+    fun pack_archive archive_root target_name target_path packer exclusions =
+        case FileBits.command {
+                rootpath = archive_root,
+                extdir = ".",
+                providers = [],
+                accounts = []
+            } "" ([
+                     "tar",
+                     case packer of
+                         TAR => "cf"
+                       | TAR_GZ => "czf"
+                       | TAR_BZ2 => "cjf"
+                       | TAR_XZ => "cJf",
+                     target_path,
+                     "--exclude=.hg",
+                     "--exclude=.git",
+                     "--exclude=vext",
+                     "--exclude=vext.sml",
+                     "--exclude=vext.ps1",
+                     "--exclude=vext.bat",
+                     "--exclude=vext-project.json",
+                     "--exclude=vext-lock.json"
+                 ] @ (map (fn e => "--exclude=" ^ e) exclusions) @
+                  [ target_name ])
+         of
+            ERROR e => ERROR e
+          | OK _ => FileBits.rmpath (archive_path archive_root target_name)
+            
+    fun archive (target_path, exclusions) (project : project) =
+        let val _ = check_nonexistent target_path
+            val (packer, name) =
+                case packer_and_basename target_path of
+                    NONE => raise Fail ("Unsupported archive file extension in "
+                                        ^ target_path)
+                  | SOME pn => pn
+            val details =
+                case project_vcs_and_id (#rootpath (#context project)) of
+                    ERROR e => raise Fail e
+                  | OK details => details
+            val archive_root =
+                case make_archive_copy name details project of
+                    ERROR e => raise Fail e
+                  | OK archive_root => archive_root
+            val outcome = 
+                case update_archive archive_root name project of
+                    ERROR e => ERROR e
+                  | OK _ =>
+                    case pack_archive archive_root name
+                                      target_path packer exclusions of
+                        ERROR e => ERROR e
+                      | OK _ => OK ()
+        in
+            case outcome of
+                ERROR e => raise Fail e
+              | OK () => OS.Process.success
+        end
+            
+end
+
 val libobjname = "libraries"
                                              
 fun load_libspec spec_json lock_json libname : libspec =
@@ -1660,7 +1937,7 @@
         else ();
         return_code
     end
-        
+    
 fun load_local_project pintype =
     let val userconfig = load_userconfig ()
         val rootpath = OS.FileSys.getDir ()
@@ -1670,10 +1947,8 @@
 
 fun with_local_project pintype f =
     let val return_code = f (load_local_project pintype)
-                          handle e =>
-                                 (print ("Failed with exception: " ^
-                                         (exnMessage e) ^ "\n");
-                                  OS.Process.failure)
+                          handle e => (print ("Error: " ^ exnMessage e);
+                                       OS.Process.failure)
         val _ = print "\n";
     in
         return_code
@@ -1701,9 +1976,19 @@
             ^ "  install  update configured libraries according to project specs and lock file\n"
             ^ "  update   update configured libraries and lock file according to project specs\n"
             ^ "  lock     update lock file to match local library status\n"
+            ^ "  archive  pack up project and all libraries into an archive file\n"
+            ^ "           (invoke as 'vext archive target-file.tar.gz')\n"
             ^ "  version  print the Vext version number and exit\n\n");
     OS.Process.failure)
 
+fun archive target args =
+    case args of
+        [] =>
+        with_local_project USE_LOCKFILE (Archive.archive (target, []))
+      | "--exclude"::xs =>
+        with_local_project USE_LOCKFILE (Archive.archive (target, xs))
+      | _ => usage ()
+
 fun vext args =
     let val return_code = 
             case args of
@@ -1713,6 +1998,7 @@
               | ["update"] => update ()
               | ["lock"] => lock ()
               | ["version"] => version ()
+              | "archive"::target::args => archive target args
               | _ => usage ()
     in
         OS.Process.exit return_code;