| 38 |
38 |
authorization.
|
| 39 |
39 |
*)
|
| 40 |
40 |
|
| 41 |
|
val vext_version = "0.9.6"
|
|
41 |
val vext_version = "0.9.8"
|
| 42 |
42 |
|
| 43 |
43 |
|
| 44 |
44 |
datatype vcs =
|
| ... | ... | |
| 136 |
136 |
val project_file = "vext-project.json"
|
| 137 |
137 |
val project_lock_file = "vext-lock.json"
|
| 138 |
138 |
val user_config_file = ".vext.json"
|
|
139 |
val archive_dir = ".vext-archive"
|
| 139 |
140 |
end
|
| 140 |
141 |
|
| 141 |
142 |
signature VCS_CONTROL = sig
|
| ... | ... | |
| 197 |
198 |
val mydir : unit -> string
|
| 198 |
199 |
val homedir : unit -> string
|
| 199 |
200 |
val mkpath : string -> unit result
|
|
201 |
val rmpath : string -> unit result
|
| 200 |
202 |
val project_spec_path : string -> string
|
| 201 |
203 |
val project_lock_path : string -> string
|
| 202 |
204 |
val verbose : unit -> bool
|
| ... | ... | |
| 381 |
383 |
| OK () => ((OS.FileSys.mkDir path; OK ())
|
| 382 |
384 |
handle OS.SysErr (e, _) =>
|
| 383 |
385 |
ERROR ("Directory creation failed: " ^ e))
|
|
386 |
|
|
387 |
fun rmpath path =
|
|
388 |
let open OS
|
|
389 |
fun files_from dirstream =
|
|
390 |
case FileSys.readDir dirstream of
|
|
391 |
NONE => []
|
|
392 |
| SOME file =>
|
|
393 |
(* readDir is supposed to filter these,
|
|
394 |
but let's be extra cautious: *)
|
|
395 |
if file = Path.parentArc orelse file = Path.currentArc
|
|
396 |
then files_from dirstream
|
|
397 |
else file :: files_from dirstream
|
|
398 |
fun contents dir =
|
|
399 |
let val stream = FileSys.openDir dir
|
|
400 |
val files = map (fn f => Path.joinDirFile
|
|
401 |
{ dir = dir, file = f })
|
|
402 |
(files_from stream)
|
|
403 |
val _ = FileSys.closeDir stream
|
|
404 |
in files
|
|
405 |
end
|
|
406 |
fun remove path =
|
|
407 |
if FileSys.isLink path (* dangling links bother isDir *)
|
|
408 |
then FileSys.remove path
|
|
409 |
else if FileSys.isDir path
|
|
410 |
then (app remove (contents path); FileSys.rmDir path)
|
|
411 |
else FileSys.remove path
|
|
412 |
in
|
|
413 |
(remove path; OK ())
|
|
414 |
handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e)
|
|
415 |
end
|
| 384 |
416 |
end
|
| 385 |
417 |
|
| 386 |
418 |
functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct
|
| ... | ... | |
| 1403 |
1435 |
(fn HG => H.id_of | GIT => G.id_of) vcs context spec
|
| 1404 |
1436 |
end
|
| 1405 |
1437 |
|
|
1438 |
|
|
1439 |
type exclusions = string list
|
|
1440 |
|
|
1441 |
structure Archive :> sig
|
|
1442 |
|
|
1443 |
val archive : string * exclusions -> project -> OS.Process.status
|
|
1444 |
|
|
1445 |
end = struct
|
|
1446 |
|
|
1447 |
(* The idea of "archive" is to replace hg/git archive, which won't
|
|
1448 |
include files, like the Vext-introduced external libraries,
|
|
1449 |
that are not under version control with the main repo.
|
|
1450 |
|
|
1451 |
The process goes like this:
|
|
1452 |
|
|
1453 |
- Make sure we have a target filename from the user, and take
|
|
1454 |
its basename as our archive directory name
|
|
1455 |
|
|
1456 |
- Make an "archive root" subdir of the project repo, named
|
|
1457 |
typically .vext-archive
|
|
1458 |
|
|
1459 |
- Identify the VCS used for the project repo. Note that any
|
|
1460 |
explicit references to VCS type in this structure are to
|
|
1461 |
the VCS used for the project (something Vext doesn't
|
|
1462 |
otherwise care about), not for an individual library
|
|
1463 |
|
|
1464 |
- Synthesise a Vext project with the archive root as its
|
|
1465 |
root path, "." as its extdir, with one library whose
|
|
1466 |
name is the user-supplied basename and whose explicit
|
|
1467 |
source URL is the original project root; update that
|
|
1468 |
project -- thus cloning the original project to a subdir
|
|
1469 |
of the archive root
|
|
1470 |
|
|
1471 |
- Synthesise a Vext project identical to the original one for
|
|
1472 |
this project, but with the newly-cloned copy as its root
|
|
1473 |
path; update that project -- thus checking out clean copies
|
|
1474 |
of the external library dirs
|
|
1475 |
|
|
1476 |
- Call out to an archive program to archive up the new copy,
|
|
1477 |
running e.g.
|
|
1478 |
tar cvzf project-release.tar.gz \
|
|
1479 |
--exclude=.hg --exclude=.git project-release
|
|
1480 |
in the archive root dir
|
|
1481 |
|
|
1482 |
- (We also omit the vext-project.json file and any trace of
|
|
1483 |
Vext. It can't properly be run in a directory where the
|
|
1484 |
external project folders already exist but their repo history
|
|
1485 |
does not. End users shouldn't get to see Vext)
|
|
1486 |
|
|
1487 |
- Clean up by deleting the new copy
|
|
1488 |
*)
|
|
1489 |
|
|
1490 |
fun project_vcs_and_id dir =
|
|
1491 |
let val context = {
|
|
1492 |
rootpath = dir,
|
|
1493 |
extdir = ".",
|
|
1494 |
providers = [],
|
|
1495 |
accounts = []
|
|
1496 |
}
|
|
1497 |
val vcs_maybe =
|
|
1498 |
case [HgControl.exists context ".",
|
|
1499 |
GitControl.exists context "."] of
|
|
1500 |
[OK true, OK false] => OK HG
|
|
1501 |
| [OK false, OK true] => OK GIT
|
|
1502 |
| _ => ERROR ("Unable to identify VCS for directory " ^ dir)
|
|
1503 |
in
|
|
1504 |
case vcs_maybe of
|
|
1505 |
ERROR e => ERROR e
|
|
1506 |
| OK vcs =>
|
|
1507 |
case (fn HG => HgControl.id_of | GIT => GitControl.id_of)
|
|
1508 |
vcs context "." of
|
|
1509 |
ERROR e => ERROR ("Unable to obtain id of project repo: "
|
|
1510 |
^ e)
|
|
1511 |
| OK id => OK (vcs, id)
|
|
1512 |
end
|
|
1513 |
|
|
1514 |
fun make_archive_root (context : context) =
|
|
1515 |
let val path = OS.Path.joinDirFile {
|
|
1516 |
dir = #rootpath context,
|
|
1517 |
file = VextFilenames.archive_dir
|
|
1518 |
}
|
|
1519 |
in
|
|
1520 |
case FileBits.mkpath path of
|
|
1521 |
ERROR e => raise Fail ("Failed to create archive directory \""
|
|
1522 |
^ path ^ "\": " ^ e)
|
|
1523 |
| OK () => path
|
|
1524 |
end
|
|
1525 |
|
|
1526 |
fun archive_path archive_dir target_name =
|
|
1527 |
OS.Path.joinDirFile {
|
|
1528 |
dir = archive_dir,
|
|
1529 |
file = target_name
|
|
1530 |
}
|
|
1531 |
|
|
1532 |
fun check_nonexistent path =
|
|
1533 |
case SOME (OS.FileSys.fileSize path) handle OS.SysErr _ => NONE of
|
|
1534 |
NONE => ()
|
|
1535 |
| _ => raise Fail ("Path " ^ path ^ " exists, not overwriting")
|
|
1536 |
|
|
1537 |
fun file_url path =
|
|
1538 |
let val forward_path =
|
|
1539 |
String.translate (fn #"\\" => "/" |
|
|
1540 |
c => Char.toString c) path
|
|
1541 |
in
|
|
1542 |
(* Path is expected to be absolute already, but if it
|
|
1543 |
starts with a drive letter, we'll need an extra slash *)
|
|
1544 |
case explode forward_path of
|
|
1545 |
#"/"::rest => "file:///" ^ implode rest
|
|
1546 |
| _ => "file:///" ^ forward_path
|
|
1547 |
end
|
|
1548 |
|
|
1549 |
fun make_archive_copy target_name (vcs, project_id)
|
|
1550 |
({ context, ... } : project) =
|
|
1551 |
let val archive_root = make_archive_root context
|
|
1552 |
val synthetic_context = {
|
|
1553 |
rootpath = archive_root,
|
|
1554 |
extdir = ".",
|
|
1555 |
providers = [],
|
|
1556 |
accounts = []
|
|
1557 |
}
|
|
1558 |
val synthetic_library = {
|
|
1559 |
libname = target_name,
|
|
1560 |
vcs = vcs,
|
|
1561 |
source = URL_SOURCE (file_url (#rootpath context)),
|
|
1562 |
branch = DEFAULT_BRANCH, (* overridden by pinned id below *)
|
|
1563 |
project_pin = PINNED project_id,
|
|
1564 |
lock_pin = PINNED project_id
|
|
1565 |
}
|
|
1566 |
val path = archive_path archive_root target_name
|
|
1567 |
val _ = print ("Cloning original project to " ^ path
|
|
1568 |
^ " at revision " ^ project_id ^ "...\n");
|
|
1569 |
val _ = check_nonexistent path
|
|
1570 |
in
|
|
1571 |
case AnyLibControl.update synthetic_context synthetic_library of
|
|
1572 |
ERROR e => ERROR ("Failed to clone original project to "
|
|
1573 |
^ path ^ ": " ^ e)
|
|
1574 |
| OK _ => OK archive_root
|
|
1575 |
end
|
|
1576 |
|
|
1577 |
fun update_archive archive_root target_name
|
|
1578 |
(project as { context, ... } : project) =
|
|
1579 |
let val synthetic_context = {
|
|
1580 |
rootpath = archive_path archive_root target_name,
|
|
1581 |
extdir = #extdir context,
|
|
1582 |
providers = #providers context,
|
|
1583 |
accounts = #accounts context
|
|
1584 |
}
|
|
1585 |
in
|
|
1586 |
foldl (fn (lib, acc) =>
|
|
1587 |
case acc of
|
|
1588 |
ERROR e => ERROR e
|
|
1589 |
| OK _ => AnyLibControl.update synthetic_context lib)
|
|
1590 |
(OK "")
|
|
1591 |
(#libs project)
|
|
1592 |
end
|
|
1593 |
|
|
1594 |
datatype packer = TAR
|
|
1595 |
| TAR_GZ
|
|
1596 |
| TAR_BZ2
|
|
1597 |
| TAR_XZ
|
|
1598 |
(* could add other packers, e.g. zip, if we knew how to
|
|
1599 |
handle the file omissions etc properly in pack_archive *)
|
|
1600 |
|
|
1601 |
fun packer_and_basename path =
|
|
1602 |
let val extensions = [ (".tar", TAR),
|
|
1603 |
(".tar.gz", TAR_GZ),
|
|
1604 |
(".tar.bz2", TAR_BZ2),
|
|
1605 |
(".tar.xz", TAR_XZ)]
|
|
1606 |
val filename = OS.Path.file path
|
|
1607 |
in
|
|
1608 |
foldl (fn ((ext, packer), acc) =>
|
|
1609 |
if String.isSuffix ext filename
|
|
1610 |
then SOME (packer,
|
|
1611 |
String.substring (filename, 0,
|
|
1612 |
String.size filename -
|
|
1613 |
String.size ext))
|
|
1614 |
else acc)
|
|
1615 |
NONE
|
|
1616 |
extensions
|
|
1617 |
end
|
|
1618 |
|
|
1619 |
fun pack_archive archive_root target_name target_path packer exclusions =
|
|
1620 |
case FileBits.command {
|
|
1621 |
rootpath = archive_root,
|
|
1622 |
extdir = ".",
|
|
1623 |
providers = [],
|
|
1624 |
accounts = []
|
|
1625 |
} "" ([
|
|
1626 |
"tar",
|
|
1627 |
case packer of
|
|
1628 |
TAR => "cf"
|
|
1629 |
| TAR_GZ => "czf"
|
|
1630 |
| TAR_BZ2 => "cjf"
|
|
1631 |
| TAR_XZ => "cJf",
|
|
1632 |
target_path,
|
|
1633 |
"--exclude=.hg",
|
|
1634 |
"--exclude=.git",
|
|
1635 |
"--exclude=vext",
|
|
1636 |
"--exclude=vext.sml",
|
|
1637 |
"--exclude=vext.ps1",
|
|
1638 |
"--exclude=vext.bat",
|
|
1639 |
"--exclude=vext-project.json",
|
|
1640 |
"--exclude=vext-lock.json"
|
|
1641 |
] @ (map (fn e => "--exclude=" ^ e) exclusions) @
|
|
1642 |
[ target_name ])
|
|
1643 |
of
|
|
1644 |
ERROR e => ERROR e
|
|
1645 |
| OK _ => FileBits.rmpath (archive_path archive_root target_name)
|
|
1646 |
|
|
1647 |
fun archive (target_path, exclusions) (project : project) =
|
|
1648 |
let val _ = check_nonexistent target_path
|
|
1649 |
val (packer, name) =
|
|
1650 |
case packer_and_basename target_path of
|
|
1651 |
NONE => raise Fail ("Unsupported archive file extension in "
|
|
1652 |
^ target_path)
|
|
1653 |
| SOME pn => pn
|
|
1654 |
val details =
|
|
1655 |
case project_vcs_and_id (#rootpath (#context project)) of
|
|
1656 |
ERROR e => raise Fail e
|
|
1657 |
| OK details => details
|
|
1658 |
val archive_root =
|
|
1659 |
case make_archive_copy name details project of
|
|
1660 |
ERROR e => raise Fail e
|
|
1661 |
| OK archive_root => archive_root
|
|
1662 |
val outcome =
|
|
1663 |
case update_archive archive_root name project of
|
|
1664 |
ERROR e => ERROR e
|
|
1665 |
| OK _ =>
|
|
1666 |
case pack_archive archive_root name
|
|
1667 |
target_path packer exclusions of
|
|
1668 |
ERROR e => ERROR e
|
|
1669 |
| OK _ => OK ()
|
|
1670 |
in
|
|
1671 |
case outcome of
|
|
1672 |
ERROR e => raise Fail e
|
|
1673 |
| OK () => OS.Process.success
|
|
1674 |
end
|
|
1675 |
|
|
1676 |
end
|
|
1677 |
|
| 1406 |
1678 |
val libobjname = "libraries"
|
| 1407 |
1679 |
|
| 1408 |
1680 |
fun load_libspec spec_json lock_json libname : libspec =
|
| ... | ... | |
| 1665 |
1937 |
else ();
|
| 1666 |
1938 |
return_code
|
| 1667 |
1939 |
end
|
| 1668 |
|
|
|
1940 |
|
| 1669 |
1941 |
fun load_local_project pintype =
|
| 1670 |
1942 |
let val userconfig = load_userconfig ()
|
| 1671 |
1943 |
val rootpath = OS.FileSys.getDir ()
|
| ... | ... | |
| 1675 |
1947 |
|
| 1676 |
1948 |
fun with_local_project pintype f =
|
| 1677 |
1949 |
let val return_code = f (load_local_project pintype)
|
| 1678 |
|
handle e =>
|
| 1679 |
|
(print ("Failed with exception: " ^
|
| 1680 |
|
(exnMessage e) ^ "\n");
|
| 1681 |
|
OS.Process.failure)
|
|
1950 |
handle e => (print ("Error: " ^ exnMessage e);
|
|
1951 |
OS.Process.failure)
|
| 1682 |
1952 |
val _ = print "\n";
|
| 1683 |
1953 |
in
|
| 1684 |
1954 |
return_code
|
| ... | ... | |
| 1706 |
1976 |
^ " install update configured libraries according to project specs and lock file\n"
|
| 1707 |
1977 |
^ " update update configured libraries and lock file according to project specs\n"
|
| 1708 |
1978 |
^ " lock update lock file to match local library status\n"
|
|
1979 |
^ " archive pack up project and all libraries into an archive file\n"
|
|
1980 |
^ " (invoke as 'vext archive target-file.tar.gz')\n"
|
| 1709 |
1981 |
^ " version print the Vext version number and exit\n\n");
|
| 1710 |
1982 |
OS.Process.failure)
|
| 1711 |
1983 |
|
|
1984 |
fun archive target args =
|
|
1985 |
case args of
|
|
1986 |
[] =>
|
|
1987 |
with_local_project USE_LOCKFILE (Archive.archive (target, []))
|
|
1988 |
| "--exclude"::xs =>
|
|
1989 |
with_local_project USE_LOCKFILE (Archive.archive (target, xs))
|
|
1990 |
| _ => usage ()
|
|
1991 |
|
| 1712 |
1992 |
fun vext args =
|
| 1713 |
1993 |
let val return_code =
|
| 1714 |
1994 |
case args of
|
| ... | ... | |
| 1718 |
1998 |
| ["update"] => update ()
|
| 1719 |
1999 |
| ["lock"] => lock ()
|
| 1720 |
2000 |
| ["version"] => version ()
|
|
2001 |
| "archive"::target::args => archive target args
|
| 1721 |
2002 |
| _ => usage ()
|
| 1722 |
2003 |
in
|
| 1723 |
2004 |
OS.Process.exit return_code;
|