sonic-visualiser: vext.sml comparison

comparison vext.sml @ 1746:bf4a7015033e

Update vext

author	Chris Cannam
date	Fri, 06 Oct 2017 13:28:35 +0100
parents	669bd699082d
children	ffe59b457557

comparison

equal deleted inserted replaced

-:3587df7758e7
+:bf4a7015033e
-(* 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
 files (the "Software"), to deal in the Software without
 restriction, including without limitation the rights to use, copy,
 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR
 ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
 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
+Except as contained in this notice, the names of Chris Cannam,
-Particular Programs Ltd shall not be used in advertising or
+Particular Programs Ltd, and Queen Mary, University of London
-otherwise to promote the sale, use or other dealings in this
+shall not be used in advertising or otherwise to promote the sale,
-Software without prior written authorization.
+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 =
 HG |
 GIT
 structure VextFilenames = struct
 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
 (** Test whether the library is present locally at all *)
 val command : context -> libname -> string list -> unit result
 val file_contents : string -> string
 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
 end = struct
 arcs = rev (tl (rev arcs)) }) of
 ERROR e => ERROR e
 | 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
 (* Valid states for unpinned libraries:
 fun id_of context (spec as { vcs, ... } : libspec) =
 (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 =
 let open JsonBits
 val libobj   = lookup_mandatory spec_json [libobjname, libname]
 if OS.Process.isSuccess return_code
 then save_lock_file (#rootpath context) locks
 else ();
 return_code
 end
 fun load_local_project pintype =
 let val userconfig = load_userconfig ()
 val rootpath = OS.FileSys.getDir ()
 in
 load_project userconfig rootpath pintype
 end
 fun with_local_project pintype f =
 let val return_code = f (load_local_project pintype)
-handle e =>
+handle e => (print ("Error: " ^ exnMessage e);
-(print ("Failed with exception: " ^
+OS.Process.failure)
-(exnMessage e) ^ "\n");
-OS.Process.failure)
 val _ = print "\n";
 in
 return_code
 end
 ^ "  status   print quick report on local status only, without using network\n"
 ^ "  review   check configured libraries against their providers, and report\n"
 ^ "  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
 ["review"] => review ()
 | ["status"] => status ()
 | ["install"] => install ()
 | ["update"] => update ()
 | ["lock"] => lock ()
 | ["version"] => version ()
+| "archive"::target::args => archive target args
 | _ => usage ()
 in
 OS.Process.exit return_code;
 ()
 end

Mercurial > hg > sonic-visualiser

comparison vext.sml @ 1746:bf4a7015033e