# HG changeset patch # User Chris Cannam # Date 1525868935 -3600 # Node ID adc8a48f4e4c6bfd71782281dc9977030f127396 # Parent dc4e6eb475ed79f031cd099ebb6741689490bdf6 Vext -> Repoint. Let's see how this goes. diff -r dc4e6eb475ed -r adc8a48f4e4c .appveyor.yml --- a/.appveyor.yml Tue May 08 14:28:58 2018 +0100 +++ b/.appveyor.yml Wed May 09 13:28:55 2018 +0100 @@ -12,7 +12,7 @@ before_build: - set QTDIR=C:\Qt\5.8\msvc2015_64 - set PATH=%PATH%;%QTDIR%\bin;C:\Program Files (x86)\SMLNJ\bin - - vext install + - repoint install - qmake -r -tp vc sonic-visualiser.pro - sv-dependency-builds\win64-msvc\bin\capnp -Isv-dependency-builds/win64-msvc/include compile --src-prefix=piper/capnp -osv-dependency-builds/win64-msvc/bin/capnpc-c++:piper-cpp/vamp-capnp piper/capnp/piper.capnp diff -r dc4e6eb475ed -r adc8a48f4e4c .hgignore --- a/.hgignore Tue May 08 14:28:58 2018 +0100 +++ b/.hgignore Wed May 09 13:28:55 2018 +0100 @@ -47,7 +47,6 @@ vamp-plugin-load-checker piper-vamp-simple-server piper-convert -.vext* -glob:.vext-*.bin *.msi *.user +glob:.repoint-*.bin diff -r dc4e6eb475ed -r adc8a48f4e4c .travis.yml --- a/.travis.yml Tue May 08 14:28:58 2018 +0100 +++ b/.travis.yml Wed May 09 13:28:55 2018 +0100 @@ -24,7 +24,7 @@ - ( cd ../capnproto/c++ ; ./configure && make && sudo make install ) before_script: - - if [[ "$TRAVIS_OS_NAME" = "linux" ]] ; then ./configure ; else ./vext install && qmake -r sonic-visualiser.pro ; fi + - if [[ "$TRAVIS_OS_NAME" = "linux" ]] ; then ./configure ; else ./repoint install && qmake -r sonic-visualiser.pro ; fi script: - make -j3 diff -r dc4e6eb475ed -r adc8a48f4e4c INSTALL.txt --- a/INSTALL.txt Tue May 08 14:28:58 2018 +0100 +++ b/INSTALL.txt Wed May 09 13:28:55 2018 +0100 @@ -19,7 +19,7 @@ Build from the command line, but don't use the configure script. Instead install Qt v5.x and run -$ ./vext install +$ ./repoint install $ qmake -r # you may need to use the full path to your Qt qmake here $ make diff -r dc4e6eb475ed -r adc8a48f4e4c configure --- a/configure Tue May 08 14:28:58 2018 +0100 +++ b/configure Wed May 09 13:28:55 2018 +0100 @@ -8525,22 +8525,22 @@ fi -if test -x vext ; then +if test -x repoint ; then if test -d .hg -o -d .git ; then - if ! ./vext install; then - as_fn_error $? "Vext failed; please fix any reported errors and try again" "$LINENO" 5 + if ! ./repoint install; then + as_fn_error $? "Repoint failed; please fix any reported errors and try again" "$LINENO" 5 fi else - { $as_echo "$as_me:${as_lineno-$LINENO}: Vext executable found but not in an Hg or Git working-copy: not running it" >&5 -$as_echo "$as_me: Vext executable found but not in an Hg or Git working-copy: not running it" >&6;} + { $as_echo "$as_me:${as_lineno-$LINENO}: Repoint executable found but not in an Hg or Git working-copy: not running it" >&5 +$as_echo "$as_me: Repoint executable found but not in an Hg or Git working-copy: not running it" >&6;} if ! test -d vamp-plugin-sdk ; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: No vamp-plugin-sdk directory present, so external libraries might not have been updated" >&5 $as_echo "$as_me: WARNING: No vamp-plugin-sdk directory present, so external libraries might not have been updated" >&2;} fi fi else - { $as_echo "$as_me:${as_lineno-$LINENO}: No Vext executable found: assuming external libraries are already here" >&5 -$as_echo "$as_me: No Vext executable found: assuming external libraries are already here" >&6;} + { $as_echo "$as_me:${as_lineno-$LINENO}: No Repoint executable found: assuming external libraries are already here" >&5 +$as_echo "$as_me: No Repoint executable found: assuming external libraries are already here" >&6;} if ! test -d vamp-plugin-sdk ; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: No vamp-plugin-sdk directory present, so external libraries might not have been updated" >&5 $as_echo "$as_me: WARNING: No vamp-plugin-sdk directory present, so external libraries might not have been updated" >&2;} diff -r dc4e6eb475ed -r adc8a48f4e4c configure.ac --- a/configure.ac Tue May 08 14:28:58 2018 +0100 +++ b/configure.ac Wed May 09 13:28:55 2018 +0100 @@ -143,19 +143,19 @@ AC_OUTPUT -if test -x vext ; then +if test -x repoint ; then if test -d .hg -o -d .git ; then - if ! ./vext install; then - AC_MSG_ERROR([Vext failed; please fix any reported errors and try again]) + if ! ./repoint install; then + AC_MSG_ERROR([Repoint failed; please fix any reported errors and try again]) fi else - AC_MSG_NOTICE([Vext executable found but not in an Hg or Git working-copy: not running it]) + AC_MSG_NOTICE([Repoint executable found but not in an Hg or Git working-copy: not running it]) if ! test -d vamp-plugin-sdk ; then AC_MSG_WARN([No vamp-plugin-sdk directory present, so external libraries might not have been updated]) fi fi else - AC_MSG_NOTICE([No Vext executable found: assuming external libraries are already here]) + AC_MSG_NOTICE([No Repoint executable found: assuming external libraries are already here]) if ! test -d vamp-plugin-sdk ; then AC_MSG_WARN([No vamp-plugin-sdk directory present, so external libraries might not have been updated]) fi diff -r dc4e6eb475ed -r adc8a48f4e4c repoint --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/repoint Wed May 09 13:28:55 2018 +0100 @@ -0,0 +1,166 @@ +#!/bin/bash + +# Disable shellcheck warnings for useless-use-of-cat. UUOC is good +# practice, not bad: clearer, safer, less error-prone. +# shellcheck disable=SC2002 + +sml="$REPOINT_SML" + +set -eu + +# avoid gussying up output +export HGPLAIN=true + +mydir=$(dirname "$0") +program="$mydir/repoint.sml" + +hasher= +local_install= +if [ -w "$mydir" ]; then + if echo | sha256sum >/dev/null 2>&1 ; then + hasher=sha256sum + local_install=true + elif echo | shasum >/dev/null 2>&1 ; then + hasher=shasum + local_install=true + else + echo "WARNING: sha256sum or shasum program not found" 1>&2 + fi +fi + +if [ -n "$local_install" ]; then + hash=$(echo "$sml" | cat "$program" - | $hasher | cut -c1-16) + gen_sml=$mydir/.repoint-$hash.sml + gen_out=$mydir/.repoint-$hash.bin + trap 'rm -f $gen_sml' 0 +else + gen_sml=$(mktemp /tmp/repoint-XXXXXXXX.sml) + gen_out=$(mktemp /tmp/repoint-XXXXXXXX.bin) + trap 'rm -f $gen_sml $gen_out' 0 +fi + +if [ -x "$gen_out" ]; then + exec "$gen_out" "$@" +fi + +# We need one of Poly/ML, SML/NJ, MLton, or MLKit. Since we're running +# a single-file SML program as if it were a script, our order of +# preference is usually based on startup speed. An exception is the +# local_install case, where we retain a persistent binary + +if [ -z "$sml" ]; then + if [ -n "$local_install" ] && mlton 2>&1 | grep -q 'MLton'; then + sml="mlton" + elif sml -h 2>&1 | grep -q 'Standard ML of New Jersey'; then + sml="smlnj" + # We would prefer Poly/ML to SML/NJ, except that Poly v5.7 has a + # nasty bug that occasionally causes it to deadlock on startup. + # That is fixed in v5.7.1, so we could promote it up the order + # again at some point in future + elif echo | poly -v 2>/dev/null | grep -q 'Poly/ML'; then + sml="poly" + elif mlton 2>&1 | grep -q 'MLton'; then + sml="mlton" + # MLKit is at the bottom because it leaves compiled files around + # in an MLB subdir in the current directory + elif mlkit 2>&1 | grep -q 'MLKit'; then + sml="mlkit" + else cat 1>&2 <&2 </dev/null 2>&1 ; then + if [ ! -x "$gen_out" ]; then + polyc -o "$gen_out" "$program" + fi + "$gen_out" "$@" + else + echo 'use "'"$program"'"; repoint ['"$arglist"'];' | + poly -q --error-exit + fi ;; + mlton) + if [ ! -x "$gen_out" ]; then + echo "[Precompiling Repoint binary...]" 1>&2 + echo "val _ = main ()" | cat "$program" - > "$gen_sml" + mlton -output "$gen_out" "$gen_sml" + fi + "$gen_out" "$@" ;; + mlkit) + if [ ! -x "$gen_out" ]; then + echo "[Precompiling Repoint binary...]" 1>&2 + echo "val _ = main ()" | cat "$program" - > "$gen_sml" + mlkit -output "$gen_out" "$gen_sml" + fi + "$gen_out" "$@" ;; + smlnj) + cat "$program" | ( + cat < (), flush = fn () => () }; + x + end; +val smlrun__prev = ref ""; +Control.Print.out := { + say = fn s => + (if String.isSubstring " Error" s + then (Control.Print.out := smlrun__cp; + (#say smlrun__cp) (!smlrun__prev); + (#say smlrun__cp) s) + else (smlrun__prev := s; ())), + flush = fn s => () +}; +EOF + cat - + cat < "$gen_sml" + CM_VERBOSE=false sml "$gen_sml" ;; + *) + echo "ERROR: Unknown SML implementation name: $sml" 1>&2; + exit 2 ;; +esac + diff -r dc4e6eb475ed -r adc8a48f4e4c repoint-lock.json --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/repoint-lock.json Wed May 09 13:28:55 2018 +0100 @@ -0,0 +1,46 @@ +{ + "libraries": { + "vamp-plugin-sdk": { + "pin": "8742125177ae" + }, + "svcore": { + "pin": "aab2d7177d3d" + }, + "svgui": { + "pin": "51e6125627fa" + }, + "svapp": { + "pin": "f03bc1d38cac" + }, + "checker": { + "pin": "cf18645ff411" + }, + "piper": { + "pin": "dde809643316e7bb606fc14d66e55f07059bcf36" + }, + "piper-cpp": { + "pin": "d81b56f1c7372ccf9d21f726d0fc122c2bf93484" + }, + "dataquay": { + "pin": "807b55408d9e" + }, + "bqvec": { + "pin": "3c9de9e7f6e8" + }, + "bqfft": { + "pin": "a766fe47501b" + }, + "bqresample": { + "pin": "a9a5555d9b6d" + }, + "bqaudioio": { + "pin": "d90244c003be" + }, + "sv-dependency-builds": { + "pin": "a69c1527268d" + }, + "icons/scalable": { + "pin": "a0a78163e88e" + } + } +} diff -r dc4e6eb475ed -r adc8a48f4e4c repoint-project.json --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/repoint-project.json Wed May 09 13:28:55 2018 +0100 @@ -0,0 +1,81 @@ +{ + "config": { + "extdir": "." + }, + "services": { + "soundsoftware": { + "vcs": ["hg", "git"], + "anonymous": "https://code.soundsoftware.ac.uk/{vcs}/{repository}", + "authenticated": "https://{account}@code.soundsoftware.ac.uk/{vcs}/{repository}" + } + }, + "libraries": { + "vamp-plugin-sdk": { + "vcs": "hg", + "service": "soundsoftware" + }, + "svcore": { + "vcs": "hg", + "service": "soundsoftware" + }, + "svgui": { + "vcs": "hg", + "service": "soundsoftware" + }, + "svapp": { + "vcs": "hg", + "service": "soundsoftware" + }, + "checker": { + "vcs": "hg", + "service": "soundsoftware", + "repository": "vamp-plugin-load-checker" + }, + "piper": { + "vcs": "git", + "service": "github", + "owner": "piper-audio" + }, + "piper-cpp": { + "vcs": "git", + "service": "github", + "owner": "piper-audio", + "repository": "piper-vamp-cpp" + }, + "dataquay": { + "vcs": "hg", + "service": "bitbucket", + "owner": "breakfastquay" + }, + "bqvec": { + "vcs": "hg", + "service": "bitbucket", + "owner": "breakfastquay" + }, + "bqfft": { + "vcs": "hg", + "service": "bitbucket", + "owner": "breakfastquay" + }, + "bqresample": { + "vcs": "hg", + "service": "bitbucket", + "owner": "breakfastquay" + }, + "bqaudioio": { + "vcs": "hg", + "service": "bitbucket", + "owner": "breakfastquay" + }, + "sv-dependency-builds": { + "vcs": "hg", + "service": "soundsoftware" + }, + "icons/scalable": { + "vcs": "hg", + "service": "soundsoftware", + "repository": "sv-iconset" + } + } +} + diff -r dc4e6eb475ed -r adc8a48f4e4c repoint.bat --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/repoint.bat Wed May 09 13:28:55 2018 +0100 @@ -0,0 +1,3 @@ +@echo off +PowerShell -NoProfile -ExecutionPolicy Bypass -Command "& '%~dpn0.ps1' %*"; + diff -r dc4e6eb475ed -r adc8a48f4e4c repoint.ps1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/repoint.ps1 Wed May 09 13:28:55 2018 +0100 @@ -0,0 +1,117 @@ +<# + +.SYNOPSIS +A simple manager for third-party source code dependencies. +Run "repoint help" for more documentation. + +#> + +Set-StrictMode -Version 2.0 +$ErrorActionPreference = "Stop" +$env:HGPLAIN = "true" + +$sml = $env:REPOINT_SML + +$mydir = Split-Path $MyInvocation.MyCommand.Path -Parent +$program = "$mydir/repoint.sml" + +# We need either Poly/ML or SML/NJ. No great preference as to which. + +# Typical locations +$env:PATH = "$env:PATH;C:\Program Files (x86)\SMLNJ\bin;C:\Program Files\Poly ML;C:\Program Files (x86)\Poly ML" + +if (!$sml) { + if (Get-Command "sml" -ErrorAction SilentlyContinue) { + $sml = "smlnj" + } elseif (Get-Command "polyml" -ErrorAction SilentlyContinue) { + $sml = "poly" + } else { + echo @" + +ERROR: No supported SML compiler or interpreter found + + The Repoint external source code manager needs a Standard ML (SML) + compiler or interpreter to run. + + Please ensure you have one of the following SML implementations + installed and present in your PATH, and try again. + + 1. Standard ML of New Jersey + - executable name: sml + + 2. Poly/ML + - executable name: polyml + +"@ + exit 1 + } +} + +if ($args -match "'""") { + $arglist = '["usage"]' +} else { + $arglist = '["' + ($args -join '","') + '"]' +} + +if ($sml -eq "poly") { + + $program = $program -replace "\\","\\\\" + echo "use ""$program""; repoint $arglist" | polyml -q --error-exit | Out-Host + + if (-not $?) { + exit $LastExitCode + } + +} elseif ($sml -eq "smlnj") { + + $lines = @(Get-Content $program) + $lines = $lines -notmatch "val _ = main ()" + + $intro = @" +val smlrun__cp = + let val x = !Control.Print.out in + Control.Print.out := { say = fn _ => (), flush = fn () => () }; + x + end; +val smlrun__prev = ref ""; +Control.Print.out := { + say = fn s => + (if String.isSubstring "Error" s orelse String.isSubstring "Fail" s + then (Control.Print.out := smlrun__cp; + (#say smlrun__cp) (!smlrun__prev); + (#say smlrun__cp) s) + else (smlrun__prev := s; ())), + flush = fn s => () +}; +"@ -split "[\r\n]+" + + $outro = @" +val _ = repoint $arglist; +val _ = OS.Process.exit (OS.Process.success); +"@ -split "[\r\n]+" + + $script = @() + $script += $intro + $script += $lines + $script += $outro + + $tmpfile = ([System.IO.Path]::GetTempFileName()) -replace "[.]tmp",".sml" + + $script | Out-File -Encoding "ASCII" $tmpfile + + $env:CM_VERBOSE="false" + + sml $tmpfile + + if (-not $?) { + del $tmpfile + exit $LastExitCode + } + + del $tmpfile + +} else { + + "Unknown SML implementation name: $sml" + exit 2 +} diff -r dc4e6eb475ed -r adc8a48f4e4c repoint.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/repoint.sml Wed May 09 13:28:55 2018 +0100 @@ -0,0 +1,2669 @@ +(* + DO NOT EDIT THIS FILE. + This file is automatically generated from the individual + source files in the Repoint repository. +*) + +(* + Repoint + + A simple manager for third-party source code dependencies + + Copyright 2018 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, + modify, merge, publish, distribute, sublicense, and/or sell copies + of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + 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, + 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 repoint_version = "0.9.98" + + +datatype vcs = + HG | + GIT | + SVN + +datatype source = + URL_SOURCE of string | + SERVICE_SOURCE of { + service : string, + owner : string option, + repo : string option + } + +type id_or_tag = string + +datatype pin = + UNPINNED | + PINNED of id_or_tag + +datatype libstate = + ABSENT | + CORRECT | + SUPERSEDED | + WRONG + +datatype localstate = + MODIFIED | + LOCK_MISMATCHED | + CLEAN + +datatype branch = + BRANCH of string | + DEFAULT_BRANCH + +(* If we can recover from an error, for example by reporting failure + for this one thing and going on to the next thing, then the error + should usually be returned through a result type rather than an + exception. *) + +datatype 'a result = + OK of 'a | + ERROR of string + +type libname = string + +type libspec = { + libname : libname, + vcs : vcs, + source : source, + branch : branch, + project_pin : pin, + lock_pin : pin +} + +type lock = { + libname : libname, + id_or_tag : id_or_tag +} + +type remote_spec = { + anon : string option, + auth : string option +} + +type provider = { + service : string, + supports : vcs list, + remote_spec : remote_spec +} + +type account = { + service : string, + login : string +} + +type context = { + rootpath : string, + extdir : string, + providers : provider list, + accounts : account list +} + +type userconfig = { + providers : provider list, + accounts : account list +} + +type project = { + context : context, + libs : libspec list +} + +structure RepointFilenames = struct + val project_file = "repoint-project.json" + val project_lock_file = "repoint-lock.json" + val user_config_file = ".repoint.json" + val archive_dir = ".repoint-archive" +end + +signature VCS_CONTROL = sig + + (** Check whether the given VCS is installed and working *) + val is_working : context -> bool result + + (** Test whether the library is present locally at all *) + val exists : context -> libname -> bool result + + (** Return the id (hash) of the current revision for the library *) + val id_of : context -> libname -> id_or_tag result + + (** Test whether the library is at the given id *) + val is_at : context -> libname * id_or_tag -> bool result + + (** Test whether the library is on the given branch, i.e. is at + the branch tip or an ancestor of it *) + val is_on_branch : context -> libname * branch -> bool result + + (** Test whether the library is at the newest revision for the + given branch. False may indicate that the branch has advanced + or that the library is not on the branch at all. This function + may use the network to check for new revisions *) + val is_newest : context -> libname * source * branch -> bool result + + (** Test whether the library is at the newest revision available + locally for the given branch. False may indicate that the + branch has advanced or that the library is not on the branch + at all. This function must not use the network *) + val is_newest_locally : context -> libname * branch -> bool result + + (** Test whether the library has been modified in the local + working copy *) + val is_modified_locally : context -> libname -> bool result + + (** Check out, i.e. clone a fresh copy of, the repo for the given + library on the given branch *) + val checkout : context -> libname * source * branch -> unit result + + (** Update the library to the given branch tip. Assumes that a + local copy of the library already exists *) + val update : context -> libname * source * branch -> unit result + + (** Update the library to the given specific id or tag *) + val update_to : context -> libname * source * id_or_tag -> unit result + + (** Return a URL from which the library can be cloned, given that + the local copy already exists. For a DVCS this can be the + local copy, but for a centralised VCS it will have to be the + remote repository URL. Used for archiving *) + val copy_url_for : context -> libname -> string result +end + +signature LIB_CONTROL = sig + val review : context -> libspec -> (libstate * localstate) result + val status : context -> libspec -> (libstate * localstate) result + val update : context -> libspec -> unit result + val id_of : context -> libspec -> id_or_tag result + val is_working : context -> vcs -> bool result +end + +structure FileBits :> sig + val extpath : context -> string + val libpath : context -> libname -> string + val subpath : context -> libname -> string -> string + val command_output : context -> libname -> string list -> string result + val command : context -> libname -> string list -> unit result + val file_url : string -> string + val file_contents : string -> string + val mydir : unit -> string + val homedir : unit -> string + val mkpath : string -> unit result + val rmpath : string -> unit result + val nonempty_dir_exists : string -> bool + val project_spec_path : string -> string + val project_lock_path : string -> string + val verbose : unit -> bool +end = struct + + fun verbose () = + case OS.Process.getEnv "REPOINT_VERBOSE" of + SOME "0" => false + | SOME _ => true + | NONE => false + + fun split_relative path desc = + case OS.Path.fromString path of + { isAbs = true, ... } => raise Fail (desc ^ " may not be absolute") + | { arcs, ... } => arcs + + fun extpath ({ rootpath, extdir, ... } : context) = + let val { isAbs, vol, arcs } = OS.Path.fromString rootpath + in OS.Path.toString { + isAbs = isAbs, + vol = vol, + arcs = arcs @ + split_relative extdir "extdir" + } + end + + fun subpath ({ rootpath, extdir, ... } : context) libname remainder = + (* NB libname is allowed to be a path fragment, e.g. foo/bar *) + let val { isAbs, vol, arcs } = OS.Path.fromString rootpath + in OS.Path.toString { + isAbs = isAbs, + vol = vol, + arcs = arcs @ + split_relative extdir "extdir" @ + split_relative libname "library path" @ + split_relative remainder "subpath" + } + end + + fun libpath context "" = + extpath context + | libpath context libname = + subpath context libname "" + + fun project_file_path rootpath filename = + let val { isAbs, vol, arcs } = OS.Path.fromString rootpath + in OS.Path.toString { + isAbs = isAbs, + vol = vol, + arcs = arcs @ [ filename ] + } + end + + fun project_spec_path rootpath = + project_file_path rootpath (RepointFilenames.project_file) + + fun project_lock_path rootpath = + project_file_path rootpath (RepointFilenames.project_lock_file) + + fun trim str = + hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str) + + fun file_url path = + let val forward_path = + String.translate (fn #"\\" => "/" | + c => Char.toString c) + (OS.Path.mkCanonical 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 file_contents filename = + let val stream = TextIO.openIn filename + fun read_all str acc = + case TextIO.inputLine str of + SOME line => read_all str (trim line :: acc) + | NONE => rev acc + val contents = read_all stream [] + val _ = TextIO.closeIn stream + in + String.concatWith "\n" contents + end + + fun expand_commandline cmdlist = + (* We are quite strict about what we accept here, except + for the first element in cmdlist which is assumed to be a + known command location rather than arbitrary user input. *) + let open Char + fun quote arg = + if List.all + (fn c => isAlphaNum c orelse c = #"-" orelse c = #"_") + (explode arg) + then arg + else "\"" ^ arg ^ "\"" + fun check arg = + let val valid = explode " /#:;?,._-{}@=+" + in + app (fn c => + if isAlphaNum c orelse + List.exists (fn v => v = c) valid orelse + c > chr 127 + then () + else raise Fail ("Invalid character '" ^ + (Char.toString c) ^ + "' in command list")) + (explode arg); + arg + end + in + String.concatWith " " + (map quote + (hd cmdlist :: map check (tl cmdlist))) + end + + val tick_cycle = ref 0 + val tick_chars = Vector.fromList (map String.str (explode "|/-\\")) + + fun tick libname cmdlist = + let val n = Vector.length tick_chars + fun pad_to n str = + if n <= String.size str then str + else pad_to n (str ^ " ") + val name = if libname <> "" then libname + else if cmdlist = nil then "" + else hd (rev cmdlist) + in + print (" " ^ + Vector.sub(tick_chars, !tick_cycle) ^ " " ^ + pad_to 70 name ^ + "\r"); + tick_cycle := (if !tick_cycle = n - 1 then 0 else 1 + !tick_cycle) + end + + fun run_command context libname cmdlist redirect = + let open OS + val dir = libpath context libname + val cmd = expand_commandline cmdlist + val _ = if verbose () + then print ("\n=== " ^ dir ^ "\n<<< " ^ cmd ^ "\n") + else tick libname cmdlist + val _ = FileSys.chDir dir + val status = case redirect of + NONE => Process.system cmd + | SOME file => Process.system (cmd ^ ">" ^ file) + in + if Process.isSuccess status + then OK () + else ERROR ("Command failed: " ^ cmd ^ " (in dir " ^ dir ^ ")") + end + handle ex => ERROR ("Unable to run command: " ^ exnMessage ex) + + fun command context libname cmdlist = + run_command context libname cmdlist NONE + + fun command_output context libname cmdlist = + let open OS + val tmpFile = FileSys.tmpName () + val result = run_command context libname cmdlist (SOME tmpFile) + val contents = file_contents tmpFile + val _ = if verbose () + then print (">>> \"" ^ contents ^ "\"\n") + else () + in + FileSys.remove tmpFile handle _ => (); + case result of + OK () => OK contents + | ERROR e => ERROR e + end + + fun mydir () = + let open OS + val { dir, file } = Path.splitDirFile (CommandLine.name ()) + in + FileSys.realPath + (if Path.isAbsolute dir + then dir + else Path.concat (FileSys.getDir (), dir)) + end + + fun homedir () = + (* Failure is not routine, so we use an exception here *) + case (OS.Process.getEnv "HOME", + OS.Process.getEnv "HOMEPATH") of + (SOME home, _) => home + | (NONE, SOME home) => home + | (NONE, NONE) => + raise Fail "Failed to look up home directory from environment" + + fun mkpath' path = + if OS.FileSys.isDir path handle _ => false + then OK () + else case OS.Path.fromString path of + { arcs = nil, ... } => OK () + | { isAbs = false, ... } => ERROR "mkpath requires absolute path" + | { isAbs, vol, arcs } => + case mkpath' (OS.Path.toString { (* parent *) + isAbs = isAbs, + vol = vol, + 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 mkpath path = + mkpath' (OS.Path.mkCanonical path) + + fun dir_contents dir = + 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 + 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 rmpath' path = + let open OS + fun remove path = + if FileSys.isLink path (* dangling links bother isDir *) + then FileSys.remove path + else if FileSys.isDir path + then (app remove (dir_contents path); FileSys.rmDir path) + else FileSys.remove path + in + (remove path; OK ()) + handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e) + end + + fun rmpath path = + rmpath' (OS.Path.mkCanonical path) + + fun nonempty_dir_exists path = + let open OS.FileSys + in + (not (isLink path) andalso + isDir path andalso + dir_contents path <> []) + handle _ => false + end + +end + +functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct + + (* Valid states for unpinned libraries: + + - CORRECT: We are on the right branch and are up-to-date with + it as far as we can tell. (If not using the network, this + should be reported to user as "Present" rather than "Correct" + as the remote repo may have advanced without us knowing.) + + - SUPERSEDED: We are on the right branch but we can see that + there is a newer revision either locally or on the remote (in + Git terms, we are at an ancestor of the desired branch tip). + + - WRONG: We are on the wrong branch (in Git terms, we are not + at the desired branch tip or any ancestor of it). + + - ABSENT: Repo doesn't exist here at all. + + Valid states for pinned libraries: + + - CORRECT: We are at the pinned revision. + + - WRONG: We are at any revision other than the pinned one. + + - ABSENT: Repo doesn't exist here at all. + *) + + fun check with_network context + ({ libname, source, branch, + project_pin, lock_pin, ... } : libspec) = + let fun check_unpinned () = + let val newest = + if with_network + then V.is_newest context (libname, source, branch) + else V.is_newest_locally context (libname, branch) + in + case newest of + ERROR e => ERROR e + | OK true => OK CORRECT + | OK false => + case V.is_on_branch context (libname, branch) of + ERROR e => ERROR e + | OK true => OK SUPERSEDED + | OK false => OK WRONG + end + fun check_pinned target = + case V.is_at context (libname, target) of + ERROR e => ERROR e + | OK true => OK CORRECT + | OK false => OK WRONG + fun check_remote () = + case project_pin of + UNPINNED => check_unpinned () + | PINNED target => check_pinned target + fun check_local () = + case V.is_modified_locally context libname of + ERROR e => ERROR e + | OK true => OK MODIFIED + | OK false => + case lock_pin of + UNPINNED => OK CLEAN + | PINNED target => + case V.is_at context (libname, target) of + ERROR e => ERROR e + | OK true => OK CLEAN + | OK false => OK LOCK_MISMATCHED + in + case V.exists context libname of + ERROR e => ERROR e + | OK false => OK (ABSENT, CLEAN) + | OK true => + case (check_remote (), check_local ()) of + (ERROR e, _) => ERROR e + | (_, ERROR e) => ERROR e + | (OK r, OK l) => OK (r, l) + end + + val review = check true + val status = check false + + fun update context + ({ libname, source, branch, + project_pin, lock_pin, ... } : libspec) = + let fun update_unpinned () = + case V.is_newest context (libname, source, branch) of + ERROR e => ERROR e + | OK true => OK () + | OK false => V.update context (libname, source, branch) + fun update_pinned target = + case V.is_at context (libname, target) of + ERROR e => ERROR e + | OK true => OK () + | OK false => V.update_to context (libname, source, target) + fun update' () = + case lock_pin of + PINNED target => update_pinned target + | UNPINNED => + case project_pin of + PINNED target => update_pinned target + | UNPINNED => update_unpinned () + in + case V.exists context libname of + ERROR e => ERROR e + | OK true => update' () + | OK false => + case V.checkout context (libname, source, branch) of + ERROR e => ERROR e + | OK () => update' () + end + + fun id_of context ({ libname, ... } : libspec) = + V.id_of context libname + + fun is_working context vcs = + V.is_working context + +end + +(* Simple Standard ML JSON parser + https://bitbucket.org/cannam/sml-simplejson + Copyright 2017 Chris Cannam. BSD licence. + Parts based on the JSON parser in the Ponyo library by Phil Eaton. +*) + +signature JSON = sig + + datatype json = OBJECT of (string * json) list + | ARRAY of json list + | NUMBER of real + | STRING of string + | BOOL of bool + | NULL + + datatype 'a result = OK of 'a + | ERROR of string + + val parse : string -> json result + val serialise : json -> string + val serialiseIndented : json -> string + +end + +structure Json :> JSON = struct + + datatype json = OBJECT of (string * json) list + | ARRAY of json list + | NUMBER of real + | STRING of string + | BOOL of bool + | NULL + + datatype 'a result = OK of 'a + | ERROR of string + + structure T = struct + datatype token = NUMBER of char list + | STRING of string + | BOOL of bool + | NULL + | CURLY_L + | CURLY_R + | SQUARE_L + | SQUARE_R + | COLON + | COMMA + + fun toString t = + case t of NUMBER digits => implode digits + | STRING s => s + | BOOL b => Bool.toString b + | NULL => "null" + | CURLY_L => "{" + | CURLY_R => "}" + | SQUARE_L => "[" + | SQUARE_R => "]" + | COLON => ":" + | COMMA => "," + end + + fun bmpToUtf8 cp = (* convert a codepoint in Unicode BMP to utf8 bytes *) + let open Word + infix 6 orb andb >> + in + map (Char.chr o toInt) + (if cp < 0wx80 then + [cp] + else if cp < 0wx800 then + [0wxc0 orb (cp >> 0w6), 0wx80 orb (cp andb 0wx3f)] + else if cp < 0wx10000 then + [0wxe0 orb (cp >> 0w12), + 0wx80 orb ((cp >> 0w6) andb 0wx3f), + 0wx80 orb (cp andb 0wx3f)] + else raise Fail ("Invalid BMP point " ^ (Word.toString cp))) + end + + fun error pos text = ERROR (text ^ " at character position " ^ + Int.toString (pos - 1)) + fun token_error pos = error pos ("Unexpected token") + + fun lexNull pos acc (#"u" :: #"l" :: #"l" :: xs) = + lex (pos + 3) (T.NULL :: acc) xs + | lexNull pos acc _ = token_error pos + + and lexTrue pos acc (#"r" :: #"u" :: #"e" :: xs) = + lex (pos + 3) (T.BOOL true :: acc) xs + | lexTrue pos acc _ = token_error pos + + and lexFalse pos acc (#"a" :: #"l" :: #"s" :: #"e" :: xs) = + lex (pos + 4) (T.BOOL false :: acc) xs + | lexFalse pos acc _ = token_error pos + + and lexChar tok pos acc xs = + lex pos (tok :: acc) xs + + and lexString pos acc cc = + let datatype escaped = ESCAPED | NORMAL + fun lexString' pos text ESCAPED [] = + error pos "End of input during escape sequence" + | lexString' pos text NORMAL [] = + error pos "End of input during string" + | lexString' pos text ESCAPED (x :: xs) = + let fun esc c = lexString' (pos + 1) (c :: text) NORMAL xs + in case x of + #"\"" => esc x + | #"\\" => esc x + | #"/" => esc x + | #"b" => esc #"\b" + | #"f" => esc #"\f" + | #"n" => esc #"\n" + | #"r" => esc #"\r" + | #"t" => esc #"\t" + | _ => error pos ("Invalid escape \\" ^ + Char.toString x) + end + | lexString' pos text NORMAL (#"\\" :: #"u" ::a::b::c::d:: xs) = + if List.all Char.isHexDigit [a,b,c,d] + then case Word.fromString ("0wx" ^ (implode [a,b,c,d])) of + SOME w => (let val utf = rev (bmpToUtf8 w) in + lexString' (pos + 6) (utf @ text) + NORMAL xs + end + handle Fail err => error pos err) + | NONE => error pos "Invalid Unicode BMP escape sequence" + else error pos "Invalid Unicode BMP escape sequence" + | lexString' pos text NORMAL (x :: xs) = + if Char.ord x < 0x20 + then error pos "Invalid unescaped control character" + else + case x of + #"\"" => OK (rev text, xs, pos + 1) + | #"\\" => lexString' (pos + 1) text ESCAPED xs + | _ => lexString' (pos + 1) (x :: text) NORMAL xs + in + case lexString' pos [] NORMAL cc of + OK (text, rest, newpos) => + lex newpos (T.STRING (implode text) :: acc) rest + | ERROR e => ERROR e + end + + and lexNumber firstChar pos acc cc = + let val valid = explode ".+-e" + fun lexNumber' pos digits [] = (rev digits, [], pos) + | lexNumber' pos digits (x :: xs) = + if x = #"E" then lexNumber' (pos + 1) (#"e" :: digits) xs + else if Char.isDigit x orelse List.exists (fn c => x = c) valid + then lexNumber' (pos + 1) (x :: digits) xs + else (rev digits, x :: xs, pos) + val (digits, rest, newpos) = + lexNumber' (pos - 1) [] (firstChar :: cc) + in + case digits of + [] => token_error pos + | _ => lex newpos (T.NUMBER digits :: acc) rest + end + + and lex pos acc [] = OK (rev acc) + | lex pos acc (x::xs) = + (case x of + #" " => lex + | #"\t" => lex + | #"\n" => lex + | #"\r" => lex + | #"{" => lexChar T.CURLY_L + | #"}" => lexChar T.CURLY_R + | #"[" => lexChar T.SQUARE_L + | #"]" => lexChar T.SQUARE_R + | #":" => lexChar T.COLON + | #"," => lexChar T.COMMA + | #"\"" => lexString + | #"t" => lexTrue + | #"f" => lexFalse + | #"n" => lexNull + | x => lexNumber x) (pos + 1) acc xs + + fun show [] = "end of input" + | show (tok :: _) = T.toString tok + + fun parseNumber digits = + (* Note lexNumber already case-insensitised the E for us *) + let open Char + + fun okExpDigits [] = false + | okExpDigits (c :: []) = isDigit c + | okExpDigits (c :: cs) = isDigit c andalso okExpDigits cs + + fun okExponent [] = false + | okExponent (#"+" :: cs) = okExpDigits cs + | okExponent (#"-" :: cs) = okExpDigits cs + | okExponent cc = okExpDigits cc + + fun okFracTrailing [] = true + | okFracTrailing (c :: cs) = + (isDigit c andalso okFracTrailing cs) orelse + (c = #"e" andalso okExponent cs) + + fun okFraction [] = false + | okFraction (c :: cs) = + isDigit c andalso okFracTrailing cs + + fun okPosTrailing [] = true + | okPosTrailing (#"." :: cs) = okFraction cs + | okPosTrailing (#"e" :: cs) = okExponent cs + | okPosTrailing (c :: cs) = + isDigit c andalso okPosTrailing cs + + fun okPositive [] = false + | okPositive (#"0" :: []) = true + | okPositive (#"0" :: #"." :: cs) = okFraction cs + | okPositive (#"0" :: #"e" :: cs) = okExponent cs + | okPositive (#"0" :: cs) = false + | okPositive (c :: cs) = isDigit c andalso okPosTrailing cs + + fun okNumber (#"-" :: cs) = okPositive cs + | okNumber cc = okPositive cc + in + if okNumber digits + then case Real.fromString (implode digits) of + NONE => ERROR "Number out of range" + | SOME r => OK r + else ERROR ("Invalid number \"" ^ (implode digits) ^ "\"") + end + + fun parseObject (T.CURLY_R :: xs) = OK (OBJECT [], xs) + | parseObject tokens = + let fun parsePair (T.STRING key :: T.COLON :: xs) = + (case parseTokens xs of + ERROR e => ERROR e + | OK (j, xs) => OK ((key, j), xs)) + | parsePair other = + ERROR ("Object key/value pair expected around \"" ^ + show other ^ "\"") + fun parseObject' acc [] = ERROR "End of input during object" + | parseObject' acc tokens = + case parsePair tokens of + ERROR e => ERROR e + | OK (pair, T.COMMA :: xs) => + parseObject' (pair :: acc) xs + | OK (pair, T.CURLY_R :: xs) => + OK (OBJECT (rev (pair :: acc)), xs) + | OK (_, _) => ERROR "Expected , or } after object element" + in + parseObject' [] tokens + end + + and parseArray (T.SQUARE_R :: xs) = OK (ARRAY [], xs) + | parseArray tokens = + let fun parseArray' acc [] = ERROR "End of input during array" + | parseArray' acc tokens = + case parseTokens tokens of + ERROR e => ERROR e + | OK (j, T.COMMA :: xs) => parseArray' (j :: acc) xs + | OK (j, T.SQUARE_R :: xs) => OK (ARRAY (rev (j :: acc)), xs) + | OK (_, _) => ERROR "Expected , or ] after array element" + in + parseArray' [] tokens + end + + and parseTokens [] = ERROR "Value expected" + | parseTokens (tok :: xs) = + (case tok of + T.NUMBER d => (case parseNumber d of + OK r => OK (NUMBER r, xs) + | ERROR e => ERROR e) + | T.STRING s => OK (STRING s, xs) + | T.BOOL b => OK (BOOL b, xs) + | T.NULL => OK (NULL, xs) + | T.CURLY_L => parseObject xs + | T.SQUARE_L => parseArray xs + | _ => ERROR ("Unexpected token " ^ T.toString tok ^ + " before " ^ show xs)) + + fun parse str = + case lex 1 [] (explode str) of + ERROR e => ERROR e + | OK tokens => case parseTokens tokens of + OK (value, []) => OK value + | OK (_, _) => ERROR "Extra data after input" + | ERROR e => ERROR e + + fun stringEscape s = + let fun esc x = [x, #"\\"] + fun escape' acc [] = rev acc + | escape' acc (x :: xs) = + escape' (case x of + #"\"" => esc x @ acc + | #"\\" => esc x @ acc + | #"\b" => esc #"b" @ acc + | #"\f" => esc #"f" @ acc + | #"\n" => esc #"n" @ acc + | #"\r" => esc #"r" @ acc + | #"\t" => esc #"t" @ acc + | _ => + let val c = Char.ord x + in + if c < 0x20 + then let val hex = Word.toString (Word.fromInt c) + in (rev o explode) (if c < 0x10 + then ("\\u000" ^ hex) + else ("\\u00" ^ hex)) + end @ acc + else + x :: acc + end) + xs + in + implode (escape' [] (explode s)) + end + + fun serialise json = + case json of + OBJECT pp => "{" ^ String.concatWith + "," (map (fn (key, value) => + serialise (STRING key) ^ ":" ^ + serialise value) pp) ^ + "}" + | ARRAY arr => "[" ^ String.concatWith "," (map serialise arr) ^ "]" + | NUMBER n => implode (map (fn #"~" => #"-" | c => c) + (explode (Real.toString n))) + | STRING s => "\"" ^ stringEscape s ^ "\"" + | BOOL b => Bool.toString b + | NULL => "null" + + fun serialiseIndented json = + let fun indent 0 = "" + | indent i = " " ^ indent (i - 1) + fun serialiseIndented' i json = + let val ser = serialiseIndented' (i + 1) + in + case json of + OBJECT [] => "{}" + | ARRAY [] => "[]" + | OBJECT pp => "{\n" ^ indent (i + 1) ^ + String.concatWith + (",\n" ^ indent (i + 1)) + (map (fn (key, value) => + ser (STRING key) ^ ": " ^ + ser value) pp) ^ + "\n" ^ indent i ^ "}" + | ARRAY arr => "[\n" ^ indent (i + 1) ^ + String.concatWith + (",\n" ^ indent (i + 1)) + (map ser arr) ^ + "\n" ^ indent i ^ "]" + | other => serialise other + end + in + serialiseIndented' 0 json ^ "\n" + end + +end + + +structure JsonBits :> sig + exception Config of string + val load_json_from : string -> Json.json (* filename -> json *) + val save_json_to : string -> Json.json -> unit + val lookup_optional : Json.json -> string list -> Json.json option + val lookup_optional_string : Json.json -> string list -> string option + val lookup_mandatory : Json.json -> string list -> Json.json + val lookup_mandatory_string : Json.json -> string list -> string +end = struct + + exception Config of string + + fun load_json_from filename = + case Json.parse (FileBits.file_contents filename) of + Json.OK json => json + | Json.ERROR e => raise Config ("Failed to parse file: " ^ e) + + fun save_json_to filename json = + (* using binary I/O to avoid ever writing CR/LF line endings *) + let val jstr = Json.serialiseIndented json + val stream = BinIO.openOut filename + in + BinIO.output (stream, Byte.stringToBytes jstr); + BinIO.closeOut stream + end + + fun lookup_optional json kk = + let fun lookup key = + case json of + Json.OBJECT kvs => + (case List.filter (fn (k, v) => k = key) kvs of + [] => NONE + | [(_,v)] => SOME v + | _ => raise Config ("Duplicate key: " ^ + (String.concatWith " -> " kk))) + | _ => raise Config "Object expected" + in + case kk of + [] => NONE + | key::[] => lookup key + | key::kk => case lookup key of + NONE => NONE + | SOME j => lookup_optional j kk + end + + fun lookup_optional_string json kk = + case lookup_optional json kk of + SOME (Json.STRING s) => SOME s + | SOME _ => raise Config ("Value (if present) must be string: " ^ + (String.concatWith " -> " kk)) + | NONE => NONE + + fun lookup_mandatory json kk = + case lookup_optional json kk of + SOME v => v + | NONE => raise Config ("Value is mandatory: " ^ + (String.concatWith " -> " kk)) + + fun lookup_mandatory_string json kk = + case lookup_optional json kk of + SOME (Json.STRING s) => s + | _ => raise Config ("Value must be string: " ^ + (String.concatWith " -> " kk)) +end + +structure Provider :> sig + val load_providers : Json.json -> provider list + val load_more_providers : provider list -> Json.json -> provider list + val remote_url : context -> vcs -> source -> libname -> string +end = struct + + val known_providers : provider list = + [ { + service = "bitbucket", + supports = [HG, GIT], + remote_spec = { + anon = SOME "https://bitbucket.org/{owner}/{repository}", + auth = SOME "ssh://{vcs}@bitbucket.org/{owner}/{repository}" + } + }, + { + service = "github", + supports = [GIT], + remote_spec = { + anon = SOME "https://github.com/{owner}/{repository}", + auth = SOME "ssh://{vcs}@github.com/{owner}/{repository}" + } + } + ] + + fun vcs_name vcs = + case vcs of HG => "hg" + | GIT => "git" + | SVN => "svn" + + fun vcs_from_name name = + case name of "hg" => HG + | "git" => GIT + | "svn" => SVN + | other => raise Fail ("Unknown vcs name \"" ^ name ^ "\"") + + fun load_more_providers previously_loaded json = + let open JsonBits + fun load pjson pname : provider = + { + service = pname, + supports = + case lookup_mandatory pjson ["vcs"] of + Json.ARRAY vv => + map (fn (Json.STRING v) => vcs_from_name v + | _ => raise Fail "Strings expected in vcs array") + vv + | _ => raise Fail "Array expected for vcs", + remote_spec = { + anon = lookup_optional_string pjson ["anonymous"], + auth = lookup_optional_string pjson ["authenticated"] + } + } + val loaded = + case lookup_optional json ["services"] of + NONE => [] + | SOME (Json.OBJECT pl) => map (fn (k, v) => load v k) pl + | _ => raise Fail "Object expected for services in config" + val newly_loaded = + List.filter (fn p => not (List.exists (fn pp => #service p = + #service pp) + previously_loaded)) + loaded + in + previously_loaded @ newly_loaded + end + + fun load_providers json = + load_more_providers known_providers json + + fun expand_spec spec { vcs, service, owner, repo } login = + (* ugly *) + let fun replace str = + case str of + "vcs" => vcs_name vcs + | "service" => service + | "owner" => + (case owner of + SOME ostr => ostr + | NONE => raise Fail ("Owner not specified for service " ^ + service)) + | "repository" => repo + | "account" => + (case login of + SOME acc => acc + | NONE => raise Fail ("Account not given for service " ^ + service)) + | other => raise Fail ("Unknown variable \"" ^ other ^ + "\" in spec for service " ^ service) + fun expand' acc sstr = + case Substring.splitl (fn c => c <> #"{") sstr of + (pfx, sfx) => + if Substring.isEmpty sfx + then rev (pfx :: acc) + else + case Substring.splitl (fn c => c <> #"}") sfx of + (tok, remainder) => + if Substring.isEmpty remainder + then rev (tok :: pfx :: acc) + else let val replacement = + replace + (* tok begins with "{": *) + (Substring.string + (Substring.triml 1 tok)) + in + expand' (Substring.full replacement :: + pfx :: acc) + (* remainder begins with "}": *) + (Substring.triml 1 remainder) + end + in + Substring.concat (expand' [] (Substring.full spec)) + end + + fun provider_url req login providers = + case providers of + [] => raise Fail ("Unknown service \"" ^ (#service req) ^ + "\" for vcs \"" ^ (vcs_name (#vcs req)) ^ "\"") + | ({ service, supports, remote_spec : remote_spec } :: rest) => + if service <> (#service req) orelse + not (List.exists (fn v => v = (#vcs req)) supports) + then provider_url req login rest + else + case (login, #auth remote_spec, #anon remote_spec) of + (SOME _, SOME auth, _) => expand_spec auth req login + | (SOME _, _, SOME anon) => expand_spec anon req NONE + | (NONE, _, SOME anon) => expand_spec anon req NONE + | _ => raise Fail ("No suitable anonymous or authenticated " ^ + "URL spec provided for service \"" ^ + service ^ "\"") + + fun login_for ({ accounts, ... } : context) service = + case List.find (fn a => service = #service a) accounts of + SOME { login, ... } => SOME login + | NONE => NONE + + fun reponame_for path = + case String.tokens (fn c => c = #"/") path of + [] => raise Fail "Non-empty library path required" + | toks => hd (rev toks) + + fun remote_url (context : context) vcs source libname = + case source of + URL_SOURCE u => u + | SERVICE_SOURCE { service, owner, repo } => + provider_url { vcs = vcs, + service = service, + owner = owner, + repo = case repo of + SOME r => r + | NONE => reponame_for libname } + (login_for context service) + (#providers context) +end + +structure HgControl :> VCS_CONTROL = struct + + (* Pulls always use an explicit URL, never just the default + remote, in order to ensure we update properly if the location + given in the project file changes. *) + + type vcsstate = { id: string, modified: bool, + branch: string, tags: string list } + + val hg_program = "hg" + + val hg_args = [ "--config", "ui.interactive=true", + "--config", "ui.merge=:merge" ] + + fun hg_command context libname args = + FileBits.command context libname (hg_program :: hg_args @ args) + + fun hg_command_output context libname args = + FileBits.command_output context libname (hg_program :: hg_args @ args) + + fun is_working context = + case hg_command_output context "" ["--version"] of + OK "" => OK false + | OK _ => OK true + | ERROR e => ERROR e + + fun exists context libname = + OK (OS.FileSys.isDir (FileBits.subpath context libname ".hg")) + handle _ => OK false + + fun remote_for context (libname, source) = + Provider.remote_url context HG source libname + + fun current_state context libname : vcsstate result = + let fun is_branch text = text <> "" andalso #"(" = hd (explode text) + and extract_branch b = + if is_branch b (* need to remove enclosing parens *) + then (implode o rev o tl o rev o tl o explode) b + else "default" + and is_modified id = id <> "" andalso #"+" = hd (rev (explode id)) + and extract_id id = + if is_modified id (* need to remove trailing "+" *) + then (implode o rev o tl o rev o explode) id + else id + and split_tags tags = String.tokens (fn c => c = #"/") tags + and state_for (id, branch, tags) = + OK { id = extract_id id, + modified = is_modified id, + branch = extract_branch branch, + tags = split_tags tags } + in + case hg_command_output context libname ["id"] of + ERROR e => ERROR e + | OK out => + case String.tokens (fn x => x = #" ") out of + [id, branch, tags] => state_for (id, branch, tags) + | [id, other] => if is_branch other + then state_for (id, other, "") + else state_for (id, "", other) + | [id] => state_for (id, "", "") + | _ => ERROR ("Unexpected output from hg id: " ^ out) + end + + fun branch_name branch = case branch of + DEFAULT_BRANCH => "default" + | BRANCH "" => "default" + | BRANCH b => b + + fun id_of context libname = + case current_state context libname of + ERROR e => ERROR e + | OK { id, ... } => OK id + + fun is_at context (libname, id_or_tag) = + case current_state context libname of + ERROR e => ERROR e + | OK { id, tags, ... } => + OK (String.isPrefix id_or_tag id orelse + String.isPrefix id id_or_tag orelse + List.exists (fn t => t = id_or_tag) tags) + + fun is_on_branch context (libname, b) = + case current_state context libname of + ERROR e => ERROR e + | OK { branch, ... } => OK (branch = branch_name b) + + fun is_newest_locally context (libname, branch) = + case hg_command_output context libname + ["log", "-l1", + "-b", branch_name branch, + "--template", "{node}"] of + ERROR e => OK false (* desired branch does not exist *) + | OK newest_in_repo => is_at context (libname, newest_in_repo) + + fun pull context (libname, source) = + let val url = remote_for context (libname, source) + in + hg_command context libname + (if FileBits.verbose () + then ["pull", url] + else ["pull", "-q", url]) + end + + fun is_newest context (libname, source, branch) = + case is_newest_locally context (libname, branch) of + ERROR e => ERROR e + | OK false => OK false + | OK true => + case pull context (libname, source) of + ERROR e => ERROR e + | _ => is_newest_locally context (libname, branch) + + fun is_modified_locally context libname = + case current_state context libname of + ERROR e => ERROR e + | OK { modified, ... } => OK modified + + fun checkout context (libname, source, branch) = + let val url = remote_for context (libname, source) + in + (* make the lib dir rather than just the ext dir, since + the lib dir might be nested and hg will happily check + out into an existing empty dir anyway *) + case FileBits.mkpath (FileBits.libpath context libname) of + ERROR e => ERROR e + | _ => hg_command context "" + ["clone", "-u", branch_name branch, + url, libname] + end + + fun update context (libname, source, branch) = + let val pull_result = pull context (libname, source) + in + case hg_command context libname ["update", branch_name branch] of + ERROR e => ERROR e + | _ => + case pull_result of + ERROR e => ERROR e + | _ => OK () + end + + fun update_to context (libname, _, "") = + ERROR "Non-empty id (tag or revision id) required for update_to" + | update_to context (libname, source, id) = + let val pull_result = pull context (libname, source) + in + case hg_command context libname ["update", "-r", id] of + OK _ => OK () + | ERROR e => + case pull_result of + ERROR e' => ERROR e' (* this was the ur-error *) + | _ => ERROR e + end + + fun copy_url_for context libname = + OK (FileBits.file_url (FileBits.libpath context libname)) + +end + +structure GitControl :> VCS_CONTROL = struct + + (* With Git repos we always operate in detached HEAD state. Even + the master branch is checked out using a remote reference + (repoint/master). The remote we use is always named repoint, and we + update it to the expected URL each time we fetch, in order to + ensure we update properly if the location given in the project + file changes. The origin remote is unused. *) + + val git_program = "git" + + fun git_command context libname args = + FileBits.command context libname (git_program :: args) + + fun git_command_output context libname args = + FileBits.command_output context libname (git_program :: args) + + fun is_working context = + case git_command_output context "" ["--version"] of + OK "" => OK false + | OK _ => OK true + | ERROR e => ERROR e + + fun exists context libname = + OK (OS.FileSys.isDir (FileBits.subpath context libname ".git")) + handle _ => OK false + + fun remote_for context (libname, source) = + Provider.remote_url context GIT source libname + + fun branch_name branch = case branch of + DEFAULT_BRANCH => "master" + | BRANCH "" => "master" + | BRANCH b => b + + val our_remote = "repoint" + + fun remote_branch_name branch = our_remote ^ "/" ^ branch_name branch + + fun checkout context (libname, source, branch) = + let val url = remote_for context (libname, source) + in + (* make the lib dir rather than just the ext dir, since + the lib dir might be nested and git will happily check + out into an existing empty dir anyway *) + case FileBits.mkpath (FileBits.libpath context libname) of + OK () => git_command context "" + ["clone", "--origin", our_remote, + "--branch", branch_name branch, + url, libname] + | ERROR e => ERROR e + end + + fun add_our_remote context (libname, source) = + (* When we do the checkout ourselves (above), we add the + remote at the same time. But if the repo was cloned by + someone else, we'll need to do it after the fact. Git + doesn't seem to have a means to add a remote or change its + url if it already exists; seems we have to do this: *) + let val url = remote_for context (libname, source) + in + case git_command context libname + ["remote", "set-url", our_remote, url] of + OK () => OK () + | ERROR e => git_command context libname + ["remote", "add", "-f", our_remote, url] + end + + (* NB git rev-parse HEAD shows revision id of current checkout; + git rev-list -1 shows revision id of revision with that tag *) + + fun id_of context libname = + git_command_output context libname ["rev-parse", "HEAD"] + + fun is_at context (libname, id_or_tag) = + case id_of context libname of + ERROR e => OK false (* HEAD nonexistent, expected in empty repo *) + | OK id => + if String.isPrefix id_or_tag id orelse + String.isPrefix id id_or_tag + then OK true + else is_at_tag context (libname, id, id_or_tag) + + and is_at_tag context (libname, id, tag) = + (* For annotated tags (with message) show-ref returns the tag + object ref rather than that of the revision being tagged; + we need the subsequent rev-list to chase that up. In fact + the rev-list on its own is enough to get us the id direct + from the tag name, but it fails with an error if the tag + doesn't exist, whereas we want to handle that quietly in + case the tag simply hasn't been pulled yet *) + case git_command_output context libname + ["show-ref", "refs/tags/" ^ tag, "--"] of + OK "" => OK false (* Not a tag *) + | ERROR _ => OK false + | OK s => + let val tag_ref = hd (String.tokens (fn c => c = #" ") s) + in + case git_command_output context libname + ["rev-list", "-1", tag_ref] of + OK tagged => OK (id = tagged) + | ERROR _ => OK false + end + + fun branch_tip context (libname, branch) = + (* We don't have access to the source info or the network + here, as this is used by status (e.g. via is_on_branch) as + well as review. It's possible the remote branch won't exist, + e.g. if the repo was checked out by something other than + Repoint, and if that's the case, we can't add it here; we'll + just have to fail, since checking against local branches + instead could produce the wrong result. *) + git_command_output context libname + ["rev-list", "-1", + remote_branch_name branch, "--"] + + fun is_newest_locally context (libname, branch) = + case branch_tip context (libname, branch) of + ERROR e => OK false + | OK rev => is_at context (libname, rev) + + fun is_on_branch context (libname, branch) = + case branch_tip context (libname, branch) of + ERROR e => OK false + | OK rev => + case is_at context (libname, rev) of + ERROR e => ERROR e + | OK true => OK true + | OK false => + case git_command context libname + ["merge-base", "--is-ancestor", + "HEAD", remote_branch_name branch] of + ERROR e => OK false (* cmd returns non-zero for no *) + | _ => OK true + + fun fetch context (libname, source) = + case add_our_remote context (libname, source) of + ERROR e => ERROR e + | _ => git_command context libname ["fetch", our_remote] + + fun is_newest context (libname, source, branch) = + case add_our_remote context (libname, source) of + ERROR e => ERROR e + | OK () => + case is_newest_locally context (libname, branch) of + ERROR e => ERROR e + | OK false => OK false + | OK true => + case fetch context (libname, source) of + ERROR e => ERROR e + | _ => is_newest_locally context (libname, branch) + + fun is_modified_locally context libname = + case git_command_output context libname ["status", "--porcelain"] of + ERROR e => ERROR e + | OK "" => OK false + | OK _ => OK true + + (* This function updates to the latest revision on a branch rather + than to a specific id or tag. We can't just checkout the given + branch, as that will succeed even if the branch isn't up to + date. We could checkout the branch and then fetch and merge, + but it's perhaps cleaner not to maintain a local branch at all, + but instead checkout the remote branch as a detached head. *) + + fun update context (libname, source, branch) = + case fetch context (libname, source) of + ERROR e => ERROR e + | _ => + case git_command context libname ["checkout", "--detach", + remote_branch_name branch] of + ERROR e => ERROR e + | _ => OK () + + (* This function is dealing with a specific id or tag, so if we + can successfully check it out (detached) then that's all we + need to do, regardless of whether fetch succeeded or not. We do + attempt the fetch first, though, purely in order to avoid ugly + error messages in the common case where we're being asked to + update to a new pin (from the lock file) that hasn't been + fetched yet. *) + + fun update_to context (libname, _, "") = + ERROR "Non-empty id (tag or revision id) required for update_to" + | update_to context (libname, source, id) = + let val fetch_result = fetch context (libname, source) + in + case git_command context libname ["checkout", "--detach", id] of + OK _ => OK () + | ERROR e => + case fetch_result of + ERROR e' => ERROR e' (* this was the ur-error *) + | _ => ERROR e + end + + fun copy_url_for context libname = + OK (FileBits.file_url (FileBits.libpath context libname)) + +end + +(* SubXml - A parser for a subset of XML + https://bitbucket.org/cannam/sml-subxml + Copyright 2018 Chris Cannam. BSD licence. +*) + +signature SUBXML = sig + + datatype node = ELEMENT of { name : string, children : node list } + | ATTRIBUTE of { name : string, value : string } + | TEXT of string + | CDATA of string + | COMMENT of string + + datatype document = DOCUMENT of { name : string, children : node list } + + datatype 'a result = OK of 'a + | ERROR of string + + val parse : string -> document result + val serialise : document -> string + +end + +structure SubXml :> SUBXML = struct + + datatype node = ELEMENT of { name : string, children : node list } + | ATTRIBUTE of { name : string, value : string } + | TEXT of string + | CDATA of string + | COMMENT of string + + datatype document = DOCUMENT of { name : string, children : node list } + + datatype 'a result = OK of 'a + | ERROR of string + + structure T = struct + datatype token = ANGLE_L + | ANGLE_R + | ANGLE_SLASH_L + | SLASH_ANGLE_R + | EQUAL + | NAME of string + | TEXT of string + | CDATA of string + | COMMENT of string + + fun name t = + case t of ANGLE_L => "<" + | ANGLE_R => ">" + | ANGLE_SLASH_L => " "/>" + | EQUAL => "=" + | NAME s => "name \"" ^ s ^ "\"" + | TEXT s => "text" + | CDATA _ => "CDATA section" + | COMMENT _ => "comment" + end + + structure Lex :> sig + val lex : string -> T.token list result + end = struct + + fun error pos text = + ERROR (text ^ " at character position " ^ Int.toString (pos-1)) + fun tokenError pos token = + error pos ("Unexpected token '" ^ Char.toString token ^ "'") + + val nameEnd = explode " \t\n\r\"'!=?" + + fun quoted quote pos acc cc = + let fun quoted' pos text [] = + error pos "Document ends during quoted string" + | quoted' pos text (x::xs) = + if x = quote + then OK (rev text, xs, pos+1) + else quoted' (pos+1) (x::text) xs + in + case quoted' pos [] cc of + ERROR e => ERROR e + | OK (text, rest, newpos) => + inside newpos (T.TEXT (implode text) :: acc) rest + end + + and name first pos acc cc = + let fun name' pos text [] = + error pos "Document ends during name" + | name' pos text (x::xs) = + if List.find (fn c => c = x) nameEnd <> NONE + then OK (rev text, (x::xs), pos) + else name' (pos+1) (x::text) xs + in + case name' (pos-1) [] (first::cc) of + ERROR e => ERROR e + | OK ([], [], pos) => error pos "Document ends before name" + | OK ([], (x::xs), pos) => tokenError pos x + | OK (text, rest, pos) => + inside pos (T.NAME (implode text) :: acc) rest + end + + and comment pos acc cc = + let fun comment' pos text cc = + case cc of + #"-" :: #"-" :: #">" :: xs => OK (rev text, xs, pos+3) + | x :: xs => comment' (pos+1) (x::text) xs + | [] => error pos "Document ends during comment" + in + case comment' pos [] cc of + ERROR e => ERROR e + | OK (text, rest, pos) => + outside pos (T.COMMENT (implode text) :: acc) rest + end + + and instruction pos acc cc = + case cc of + #"?" :: #">" :: xs => outside (pos+2) acc xs + | #">" :: _ => tokenError pos #">" + | x :: xs => instruction (pos+1) acc xs + | [] => error pos "Document ends during processing instruction" + + and cdata pos acc cc = + let fun cdata' pos text cc = + case cc of + #"]" :: #"]" :: #">" :: xs => OK (rev text, xs, pos+3) + | x :: xs => cdata' (pos+1) (x::text) xs + | [] => error pos "Document ends during CDATA section" + in + case cdata' pos [] cc of + ERROR e => ERROR e + | OK (text, rest, pos) => + outside pos (T.CDATA (implode text) :: acc) rest + end + + and doctype pos acc cc = + case cc of + #">" :: xs => outside (pos+1) acc xs + | x :: xs => doctype (pos+1) acc xs + | [] => error pos "Document ends during DOCTYPE" + + and declaration pos acc cc = + case cc of + #"-" :: #"-" :: xs => + comment (pos+2) acc xs + | #"[" :: #"C" :: #"D" :: #"A" :: #"T" :: #"A" :: #"[" :: xs => + cdata (pos+7) acc xs + | #"D" :: #"O" :: #"C" :: #"T" :: #"Y" :: #"P" :: #"E" :: xs => + doctype (pos+7) acc xs + | [] => error pos "Document ends during declaration" + | _ => error pos "Unsupported declaration type" + + and left pos acc cc = + case cc of + #"/" :: xs => inside (pos+1) (T.ANGLE_SLASH_L :: acc) xs + | #"!" :: xs => declaration (pos+1) acc xs + | #"?" :: xs => instruction (pos+1) acc xs + | xs => inside pos (T.ANGLE_L :: acc) xs + + and slash pos acc cc = + case cc of + #">" :: xs => outside (pos+1) (T.SLASH_ANGLE_R :: acc) xs + | x :: _ => tokenError pos x + | [] => error pos "Document ends before element closed" + + and close pos acc xs = outside pos (T.ANGLE_R :: acc) xs + + and equal pos acc xs = inside pos (T.EQUAL :: acc) xs + + and outside pos acc [] = OK acc + | outside pos acc cc = + let fun textOf text = T.TEXT (implode (rev text)) + fun outside' pos [] acc [] = OK acc + | outside' pos text acc [] = OK (textOf text :: acc) + | outside' pos text acc (x::xs) = + case x of + #"<" => if text = [] + then left (pos+1) acc xs + else left (pos+1) (textOf text :: acc) xs + | x => outside' (pos+1) (x::text) acc xs + in + outside' pos [] acc cc + end + + and inside pos acc [] = error pos "Document ends within tag" + | inside pos acc (#"<"::_) = tokenError pos #"<" + | inside pos acc (x::xs) = + (case x of + #" " => inside | #"\t" => inside + | #"\n" => inside | #"\r" => inside + | #"\"" => quoted x | #"'" => quoted x + | #"/" => slash | #">" => close | #"=" => equal + | x => name x) (pos+1) acc xs + + fun lex str = + case outside 1 [] (explode str) of + ERROR e => ERROR e + | OK tokens => OK (rev tokens) + end + + structure Parse :> sig + val parse : string -> document result + end = struct + + fun show [] = "end of input" + | show (tok :: _) = T.name tok + + fun error toks text = ERROR (text ^ " before " ^ show toks) + + fun attribute elt name toks = + case toks of + T.EQUAL :: T.TEXT value :: xs => + namedElement { + name = #name elt, + children = ATTRIBUTE { name = name, value = value } :: + #children elt + } xs + | T.EQUAL :: xs => error xs "Expected attribute value" + | toks => error toks "Expected attribute assignment" + + and content elt toks = + case toks of + T.ANGLE_SLASH_L :: T.NAME n :: T.ANGLE_R :: xs => + if n = #name elt + then OK (elt, xs) + else ERROR ("Closing tag " ^ + "does not match opening <" ^ #name elt ^ ">") + | T.TEXT text :: xs => + content { + name = #name elt, + children = TEXT text :: #children elt + } xs + | T.CDATA text :: xs => + content { + name = #name elt, + children = CDATA text :: #children elt + } xs + | T.COMMENT text :: xs => + content { + name = #name elt, + children = COMMENT text :: #children elt + } xs + | T.ANGLE_L :: xs => + (case element xs of + ERROR e => ERROR e + | OK (child, xs) => + content { + name = #name elt, + children = ELEMENT child :: #children elt + } xs) + | tok :: xs => + error xs ("Unexpected token " ^ T.name tok) + | [] => + ERROR ("Document ends within element \"" ^ #name elt ^ "\"") + + and namedElement elt toks = + case toks of + T.SLASH_ANGLE_R :: xs => OK (elt, xs) + | T.NAME name :: xs => attribute elt name xs + | T.ANGLE_R :: xs => content elt xs + | x :: xs => error xs ("Unexpected token " ^ T.name x) + | [] => ERROR "Document ends within opening tag" + + and element toks = + case toks of + T.NAME name :: xs => + (case namedElement { name = name, children = [] } xs of + ERROR e => ERROR e + | OK ({ name, children }, xs) => + OK ({ name = name, children = rev children }, xs)) + | toks => error toks "Expected element name" + + and document [] = ERROR "Empty document" + | document (tok :: xs) = + case tok of + T.TEXT _ => document xs + | T.COMMENT _ => document xs + | T.ANGLE_L => + (case element xs of + ERROR e => ERROR e + | OK (elt, []) => OK (DOCUMENT elt) + | OK (elt, (T.TEXT _ :: xs)) => OK (DOCUMENT elt) + | OK (elt, xs) => error xs "Extra data after document") + | _ => error xs ("Unexpected token " ^ T.name tok) + + fun parse str = + case Lex.lex str of + ERROR e => ERROR e + | OK tokens => document tokens + end + + structure Serialise :> sig + val serialise : document -> string + end = struct + + fun attributes nodes = + String.concatWith + " " + (map node (List.filter + (fn ATTRIBUTE _ => true | _ => false) + nodes)) + + and nonAttributes nodes = + String.concat + (map node (List.filter + (fn ATTRIBUTE _ => false | _ => true) + nodes)) + + and node n = + case n of + TEXT string => + string + | CDATA string => + "" + | COMMENT string => + "" + | ATTRIBUTE { name, value } => + name ^ "=" ^ "\"" ^ value ^ "\"" (*!!!*) + | ELEMENT { name, children } => + "<" ^ name ^ + (case (attributes children) of + "" => "" + | s => " " ^ s) ^ + (case (nonAttributes children) of + "" => "/>" + | s => ">" ^ s ^ "") + + fun serialise (DOCUMENT { name, children }) = + "\n" ^ + node (ELEMENT { name = name, children = children }) + end + + val parse = Parse.parse + val serialise = Serialise.serialise + +end + + +structure SvnControl :> VCS_CONTROL = struct + + val svn_program = "svn" + + fun svn_command context libname args = + FileBits.command context libname (svn_program :: args) + + fun svn_command_output context libname args = + FileBits.command_output context libname (svn_program :: args) + + fun svn_command_lines context libname args = + case svn_command_output context libname args of + ERROR e => ERROR e + | OK s => OK (String.tokens (fn c => c = #"\n" orelse c = #"\r") s) + + fun split_line_pair line = + let fun strip_leading_ws str = case explode str of + #" "::rest => implode rest + | _ => str + in + case String.tokens (fn c => c = #":") line of + [] => ("", "") + | first::rest => + (first, strip_leading_ws (String.concatWith ":" rest)) + end + + fun is_working context = + case svn_command_output context "" ["--version"] of + OK "" => OK false + | OK _ => OK true + | ERROR e => ERROR e + + structure X = SubXml + + fun svn_info context libname route = + (* SVN 1.9 has info --show-item which is just what we need, + but at this point we still have 1.8 on the CI boxes so we + might as well aim to support it. For that we really have to + use the XML output format, since the default info output is + localised. This is the only thing our mini-XML parser is + used for though, so it would be good to trim it at some + point *) + let fun find elt [] = OK elt + | find { children, ... } (first :: rest) = + case List.find (fn (X.ELEMENT { name, ... }) => name = first + | _ => false) + children of + NONE => ERROR ("No element \"" ^ first ^ "\" in SVN XML") + | SOME (X.ELEMENT e) => find e rest + | SOME _ => ERROR "Internal error" + in + case svn_command_output context libname ["info", "--xml"] of + ERROR e => ERROR e + | OK xml => + case X.parse xml of + X.ERROR e => ERROR e + | X.OK (X.DOCUMENT doc) => find doc route + end + + fun exists context libname = + OK (OS.FileSys.isDir (FileBits.subpath context libname ".svn")) + handle _ => OK false + + fun remote_for context (libname, source) = + Provider.remote_url context SVN source libname + + (* Remote the checkout came from, not necessarily the one we want *) + fun actual_remote_for context libname = + case svn_info context libname ["entry", "url"] of + ERROR e => ERROR e + | OK { children, ... } => + case List.find (fn (X.TEXT _) => true | _ => false) children of + NONE => ERROR "No content for URL in SVN info XML" + | SOME (X.TEXT url) => OK url + | SOME _ => ERROR "Internal error" + + fun id_of context libname = + case svn_info context libname ["entry"] of + ERROR e => ERROR e + | OK { children, ... } => + case List.find + (fn (X.ATTRIBUTE { name = "revision", ... }) => true + | _ => false) + children of + NONE => ERROR "No revision for entry in SVN info XML" + | SOME (X.ATTRIBUTE { value, ... }) => OK value + | SOME _ => ERROR "Internal error" + + fun is_at context (libname, id_or_tag) = + case id_of context libname of + ERROR e => ERROR e + | OK id => OK (id = id_or_tag) + + fun is_on_branch context (libname, b) = + OK (b = DEFAULT_BRANCH) + + fun check_remote context (libname, source) = + case (remote_for context (libname, source), + actual_remote_for context libname) of + (_, ERROR e) => ERROR e + | (url, OK actual) => + if actual = url + then OK () + else svn_command context libname ["relocate", url] + + fun is_newest context (libname, source, branch) = + case check_remote context (libname, source) of + ERROR e => ERROR e + | OK () => + case svn_command_lines context libname + ["status", "--show-updates"] of + ERROR e => ERROR e + | OK lines => + case rev lines of + [] => ERROR "No result returned for server status" + | last_line::_ => + case rev (String.tokens (fn c => c = #" ") last_line) of + [] => ERROR "No revision field found in server status" + | server_id::_ => is_at context (libname, server_id) + + fun is_newest_locally context (libname, branch) = + OK true (* no local history *) + + fun is_modified_locally context libname = + case svn_command_output context libname ["status"] of + ERROR e => ERROR e + | OK "" => OK false + | OK _ => OK true + + fun checkout context (libname, source, branch) = + let val url = remote_for context (libname, source) + val path = FileBits.libpath context libname + in + if FileBits.nonempty_dir_exists path + then (* Surprisingly, SVN itself has no problem with + this. But for consistency with other VCSes we + don't allow it *) + ERROR ("Refusing checkout to nonempty dir \"" ^ path ^ "\"") + else + (* make the lib dir rather than just the ext dir, since + the lib dir might be nested and svn will happily check + out into an existing empty dir anyway *) + case FileBits.mkpath (FileBits.libpath context libname) of + ERROR e => ERROR e + | _ => svn_command context "" ["checkout", url, libname] + end + + fun update context (libname, source, branch) = + case check_remote context (libname, source) of + ERROR e => ERROR e + | OK () => + case svn_command context libname + ["update", "--accept", "postpone"] of + ERROR e => ERROR e + | _ => OK () + + fun update_to context (libname, _, "") = + ERROR "Non-empty id (tag or revision id) required for update_to" + | update_to context (libname, source, id) = + case check_remote context (libname, source) of + ERROR e => ERROR e + | OK () => + case svn_command context libname + ["update", "-r", id, "--accept", "postpone"] of + ERROR e => ERROR e + | OK _ => OK () + + fun copy_url_for context libname = + actual_remote_for context libname + +end + +structure AnyLibControl :> LIB_CONTROL = struct + + structure H = LibControlFn(HgControl) + structure G = LibControlFn(GitControl) + structure S = LibControlFn(SvnControl) + + fun review context (spec as { vcs, ... } : libspec) = + (fn HG => H.review | GIT => G.review | SVN => S.review) vcs context spec + + fun status context (spec as { vcs, ... } : libspec) = + (fn HG => H.status | GIT => G.status | SVN => S.status) vcs context spec + + fun update context (spec as { vcs, ... } : libspec) = + (fn HG => H.update | GIT => G.update | SVN => S.update) vcs context spec + + fun id_of context (spec as { vcs, ... } : libspec) = + (fn HG => H.id_of | GIT => G.id_of | SVN => S.id_of) vcs context spec + + fun is_working context vcs = + (fn HG => H.is_working | GIT => G.is_working | SVN => S.is_working) + vcs context vcs + +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 Repoint-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 .repoint-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 Repoint doesn't + otherwise care about), not for an individual library + + - Synthesise a Repoint 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 Repoint 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 repoint-project.json file and any trace of + Repoint. 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 Repoint) + + - Clean up by deleting the new copy + *) + + fun project_vcs_id_and_url dir = + let val context = { + rootpath = dir, + extdir = ".", + providers = [], + accounts = [] + } + val vcs_maybe = + case [HgControl.exists context ".", + GitControl.exists context ".", + SvnControl.exists context "."] of + [OK true, OK false, OK false] => OK HG + | [OK false, OK true, OK false] => OK GIT + | [OK false, OK false, OK true] => OK SVN + | _ => 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 + | SVN => SvnControl.id_of) + vcs context "." of + ERROR e => ERROR ("Unable to find id of project repo: " ^ e) + | OK id => + case (fn HG => HgControl.copy_url_for + | GIT => GitControl.copy_url_for + | SVN => SvnControl.copy_url_for) + vcs context "." of + ERROR e => ERROR ("Unable to find URL of project repo: " + ^ e) + | OK url => OK (vcs, id, url) + end + + fun make_archive_root (context : context) = + let val path = OS.Path.joinDirFile { + dir = #rootpath context, + file = RepointFilenames.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 make_archive_copy target_name (vcs, project_id, source_url) + ({ 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 source_url, + 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=.svn", + "--exclude=repoint", + "--exclude=repoint.sml", + "--exclude=repoint.ps1", + "--exclude=repoint.bat", + "--exclude=repoint-project.json", + "--exclude=repoint-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_id_and_url (#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] + val vcs = lookup_mandatory_string libobj ["vcs"] + val retrieve = lookup_optional_string libobj + val service = retrieve ["service"] + val owner = retrieve ["owner"] + val repo = retrieve ["repository"] + val url = retrieve ["url"] + val branch = retrieve ["branch"] + val project_pin = case retrieve ["pin"] of + NONE => UNPINNED + | SOME p => PINNED p + val lock_pin = case lookup_optional lock_json [libobjname, libname] of + NONE => UNPINNED + | SOME ll => case lookup_optional_string ll ["pin"] of + SOME p => PINNED p + | NONE => UNPINNED + in + { + libname = libname, + vcs = case vcs of + "hg" => HG + | "git" => GIT + | "svn" => SVN + | other => raise Fail ("Unknown version-control system \"" ^ + other ^ "\""), + source = case (url, service, owner, repo) of + (SOME u, NONE, _, _) => URL_SOURCE u + | (NONE, SOME ss, owner, repo) => + SERVICE_SOURCE { service = ss, owner = owner, repo = repo } + | _ => raise Fail ("Must have exactly one of service " ^ + "or url string"), + project_pin = project_pin, + lock_pin = lock_pin, + branch = case branch of + NONE => DEFAULT_BRANCH + | SOME b => + case vcs of + "svn" => raise Fail ("Branches not supported for " ^ + "svn repositories; change " ^ + "URL instead") + | _ => BRANCH b + } + end + +fun load_userconfig () : userconfig = + let val home = FileBits.homedir () + val conf_json = + JsonBits.load_json_from + (OS.Path.joinDirFile { + dir = home, + file = RepointFilenames.user_config_file }) + handle IO.Io _ => Json.OBJECT [] + in + { + accounts = case JsonBits.lookup_optional conf_json ["accounts"] of + NONE => [] + | SOME (Json.OBJECT aa) => + map (fn (k, (Json.STRING v)) => + { service = k, login = v } + | _ => raise Fail + "String expected for account name") + aa + | _ => raise Fail "Array expected for accounts", + providers = Provider.load_providers conf_json + } + end + +datatype pintype = + NO_LOCKFILE | + USE_LOCKFILE + +fun load_project (userconfig : userconfig) rootpath pintype : project = + let val spec_file = FileBits.project_spec_path rootpath + val lock_file = FileBits.project_lock_path rootpath + val _ = if OS.FileSys.access (spec_file, [OS.FileSys.A_READ]) + handle OS.SysErr _ => false + then () + else raise Fail ("Failed to open project spec file " ^ + (RepointFilenames.project_file) ^ " in " ^ + rootpath ^ + ".\nPlease ensure the spec file is in the " ^ + "project root and run this from there.") + val spec_json = JsonBits.load_json_from spec_file + val lock_json = if pintype = USE_LOCKFILE + then JsonBits.load_json_from lock_file + handle IO.Io _ => Json.OBJECT [] + else Json.OBJECT [] + val extdir = JsonBits.lookup_mandatory_string spec_json + ["config", "extdir"] + val spec_libs = JsonBits.lookup_optional spec_json [libobjname] + val lock_libs = JsonBits.lookup_optional lock_json [libobjname] + val providers = Provider.load_more_providers + (#providers userconfig) spec_json + val libnames = case spec_libs of + NONE => [] + | SOME (Json.OBJECT ll) => map (fn (k, v) => k) ll + | _ => raise Fail "Object expected for libs" + in + { + context = { + rootpath = rootpath, + extdir = extdir, + providers = providers, + accounts = #accounts userconfig + }, + libs = map (load_libspec spec_json lock_json) libnames + } + end + +fun save_lock_file rootpath locks = + let val lock_file = FileBits.project_lock_path rootpath + open Json + val lock_json = + OBJECT [ + (libobjname, + OBJECT (map (fn { libname, id_or_tag } => + (libname, + OBJECT [ ("pin", STRING id_or_tag) ])) + locks)) + ] + in + JsonBits.save_json_to lock_file lock_json + end + +fun pad_to n str = + if n <= String.size str then str + else pad_to n (str ^ " ") + +fun hline_to 0 = "" + | hline_to n = "-" ^ hline_to (n-1) + +val libname_width = 28 +val libstate_width = 11 +val localstate_width = 17 +val notes_width = 5 +val divider = " | " +val clear_line = "\r" ^ pad_to 80 ""; + +fun print_status_header () = + print (clear_line ^ "\n " ^ + pad_to libname_width "Library" ^ divider ^ + pad_to libstate_width "State" ^ divider ^ + pad_to localstate_width "Local" ^ divider ^ + "Notes" ^ "\n " ^ + hline_to libname_width ^ "-+-" ^ + hline_to libstate_width ^ "-+-" ^ + hline_to localstate_width ^ "-+-" ^ + hline_to notes_width ^ "\n") + +fun print_outcome_header () = + print (clear_line ^ "\n " ^ + pad_to libname_width "Library" ^ divider ^ + pad_to libstate_width "Outcome" ^ divider ^ + "Notes" ^ "\n " ^ + hline_to libname_width ^ "-+-" ^ + hline_to libstate_width ^ "-+-" ^ + hline_to notes_width ^ "\n") + +fun print_status with_network (lib : libspec, status) = + let val libstate_str = + case status of + OK (ABSENT, _) => "Absent" + | OK (CORRECT, _) => if with_network then "Correct" else "Present" + | OK (SUPERSEDED, _) => "Superseded" + | OK (WRONG, _) => "Wrong" + | ERROR _ => "Error" + val localstate_str = + case status of + OK (_, MODIFIED) => "Modified" + | OK (_, LOCK_MISMATCHED) => "Differs from Lock" + | OK (_, CLEAN) => "Clean" + | ERROR _ => "" + val error_str = + case status of + ERROR e => e + | _ => "" + in + print (" " ^ + pad_to libname_width (#libname lib) ^ divider ^ + pad_to libstate_width libstate_str ^ divider ^ + pad_to localstate_width localstate_str ^ divider ^ + error_str ^ "\n") + end + +fun print_update_outcome (lib : libspec, outcome) = + let val outcome_str = + case outcome of + OK id => "Ok" + | ERROR e => "Failed" + val error_str = + case outcome of + ERROR e => e + | _ => "" + in + print (" " ^ + pad_to libname_width (#libname lib) ^ divider ^ + pad_to libstate_width outcome_str ^ divider ^ + error_str ^ "\n") + end + +fun vcs_name HG = ("Mercurial", "hg") + | vcs_name GIT = ("Git", "git") + | vcs_name SVN = ("Subversion", "svn") + +fun print_problem_summary context lines = + let val failed_vcs = + foldl (fn (({ vcs, ... } : libspec, ERROR _), acc) => vcs::acc + | (_, acc) => acc) [] lines + fun report_nonworking vcs error = + print ((if error = "" then "" else error ^ "\n\n") ^ + "Error: The project uses the " ^ (#1 (vcs_name vcs)) ^ + " version control system, but its\n" ^ + "executable program (" ^ (#2 (vcs_name vcs)) ^ + ") does not appear to be installed in the program path\n\n") + fun check_working [] checked = () + | check_working (vcs::rest) checked = + if List.exists (fn v => vcs = v) checked + then check_working rest checked + else + case AnyLibControl.is_working context vcs of + OK true => check_working rest checked + | OK false => (report_nonworking vcs ""; + check_working rest (vcs::checked)) + | ERROR e => (report_nonworking vcs e; + check_working rest (vcs::checked)) + in + print "\nError: Some operations failed\n\n"; + check_working failed_vcs [] + end + +fun act_and_print action print_header print_line context (libs : libspec list) = + let val lines = map (fn lib => (lib, action lib)) libs + val imperfect = List.exists (fn (_, ERROR _) => true | _ => false) lines + val _ = print_header () + in + app print_line lines; + if imperfect then print_problem_summary context lines else (); + lines + end + +fun return_code_for outcomes = + foldl (fn ((_, result), acc) => + case result of + ERROR _ => OS.Process.failure + | _ => acc) + OS.Process.success + outcomes + +fun status_of_project ({ context, libs } : project) = + return_code_for (act_and_print (AnyLibControl.status context) + print_status_header (print_status false) + context libs) + +fun review_project ({ context, libs } : project) = + return_code_for (act_and_print (AnyLibControl.review context) + print_status_header (print_status true) + context libs) + +fun lock_project ({ context, libs } : project) = + let val _ = if FileBits.verbose () + then print ("Scanning IDs for lock file...\n") + else () + val outcomes = map (fn lib => (lib, AnyLibControl.id_of context lib)) + libs + val locks = + List.concat + (map (fn (lib : libspec, result) => + case result of + ERROR _ => [] + | OK id => [{ libname = #libname lib, + id_or_tag = id }]) + outcomes) + val return_code = return_code_for outcomes + val _ = print clear_line + in + if OS.Process.isSuccess return_code + then save_lock_file (#rootpath context) locks + else (); + return_code + end + +fun update_project (project as { context, libs }) = + let val outcomes = act_and_print + (AnyLibControl.update context) + print_outcome_header print_update_outcome + context libs + val _ = if List.exists (fn (_, OK _) => true | _ => false) outcomes + then lock_project project + else OS.Process.success + in + return_code_for outcomes + 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 open OS.Process + val return_code = + f (load_local_project pintype) + handle Fail msg => + failure before print ("Error: " ^ msg) + | JsonBits.Config msg => + failure before print ("Error in configuration: " ^ msg) + | e => + failure before print ("Error: " ^ exnMessage e) + val _ = print "\n"; + in + return_code + end + +fun review () = with_local_project USE_LOCKFILE review_project +fun status () = with_local_project USE_LOCKFILE status_of_project +fun update () = with_local_project NO_LOCKFILE update_project +fun lock () = with_local_project NO_LOCKFILE lock_project +fun install () = with_local_project USE_LOCKFILE update_project + +fun version () = + (print ("v" ^ repoint_version ^ "\n"); + OS.Process.success) + +fun usage () = + (print "\nRepoint "; + version (); + print ("\nA simple manager for third-party source code dependencies.\n\n" + ^ "Usage:\n\n" + ^ " repoint \n\n" + ^ "where is one of:\n\n" + ^ " 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 'repoint archive target-file.tar.gz')\n" + ^ " version print the Repoint 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 repoint 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 + | arg::_ => (print ("Error: unknown argument \"" ^ arg ^ "\"\n"); + usage ()) + | _ => usage () + in + OS.Process.exit return_code; + () + end + +fun main () = + repoint (CommandLine.arguments ()) diff -r dc4e6eb475ed -r adc8a48f4e4c vext --- a/vext Tue May 08 14:28:58 2018 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,166 +0,0 @@ -#!/bin/bash - -# Disable shellcheck warnings for useless-use-of-cat. UUOC is good -# practice, not bad: clearer, safer, less error-prone. -# shellcheck disable=SC2002 - -sml="$VEXT_SML" - -set -eu - -# avoid gussying up output -export HGPLAIN=true - -mydir=$(dirname "$0") -program="$mydir/vext.sml" - -hasher= -local_install= -if [ -w "$mydir" ]; then - if echo | sha256sum >/dev/null 2>&1 ; then - hasher=sha256sum - local_install=true - elif echo | shasum >/dev/null 2>&1 ; then - hasher=shasum - local_install=true - else - echo "WARNING: sha256sum or shasum program not found" 1>&2 - fi -fi - -if [ -n "$local_install" ]; then - hash=$(echo "$sml" | cat "$program" - | $hasher | cut -c1-16) - gen_sml=$mydir/.vext-$hash.sml - gen_out=$mydir/.vext-$hash.bin - trap 'rm -f $gen_sml' 0 -else - gen_sml=$(mktemp /tmp/vext-XXXXXXXX.sml) - gen_out=$(mktemp /tmp/vext-XXXXXXXX.bin) - trap 'rm -f $gen_sml $gen_out' 0 -fi - -if [ -x "$gen_out" ]; then - exec "$gen_out" "$@" -fi - -# We need one of Poly/ML, SML/NJ, MLton, or MLKit. Since we're running -# a single-file SML program as if it were a script, our order of -# preference is usually based on startup speed. An exception is the -# local_install case, where we retain a persistent binary - -if [ -z "$sml" ]; then - if [ -n "$local_install" ] && mlton 2>&1 | grep -q 'MLton'; then - sml="mlton" - elif sml -h 2>&1 | grep -q 'Standard ML of New Jersey'; then - sml="smlnj" - # We would prefer Poly/ML to SML/NJ, except that Poly v5.7 has a - # nasty bug that occasionally causes it to deadlock on startup. - # That is fixed in v5.7.1, so we could promote it up the order - # again at some point in future - elif echo | poly -v 2>/dev/null | grep -q 'Poly/ML'; then - sml="poly" - elif mlton 2>&1 | grep -q 'MLton'; then - sml="mlton" - # MLKit is at the bottom because it leaves compiled files around - # in an MLB subdir in the current directory - elif mlkit 2>&1 | grep -q 'MLKit'; then - sml="mlkit" - else cat 1>&2 <&2 </dev/null 2>&1 ; then - if [ ! -x "$gen_out" ]; then - polyc -o "$gen_out" "$program" - fi - "$gen_out" "$@" - else - echo 'use "'"$program"'"; vext ['"$arglist"'];' | - poly -q --error-exit - fi ;; - mlton) - if [ ! -x "$gen_out" ]; then - echo "[Precompiling Vext binary...]" 1>&2 - echo "val _ = main ()" | cat "$program" - > "$gen_sml" - mlton -output "$gen_out" "$gen_sml" - fi - "$gen_out" "$@" ;; - mlkit) - if [ ! -x "$gen_out" ]; then - echo "[Precompiling Vext binary...]" 1>&2 - echo "val _ = main ()" | cat "$program" - > "$gen_sml" - mlkit -output "$gen_out" "$gen_sml" - fi - "$gen_out" "$@" ;; - smlnj) - cat "$program" | ( - cat < (), flush = fn () => () }; - x - end; -val smlrun__prev = ref ""; -Control.Print.out := { - say = fn s => - (if String.isSubstring " Error" s - then (Control.Print.out := smlrun__cp; - (#say smlrun__cp) (!smlrun__prev); - (#say smlrun__cp) s) - else (smlrun__prev := s; ())), - flush = fn s => () -}; -EOF - cat - - cat < "$gen_sml" - CM_VERBOSE=false sml "$gen_sml" ;; - *) - echo "ERROR: Unknown SML implementation name: $sml" 1>&2; - exit 2 ;; -esac - diff -r dc4e6eb475ed -r adc8a48f4e4c vext-lock.json --- a/vext-lock.json Tue May 08 14:28:58 2018 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -{ - "libraries": { - "vamp-plugin-sdk": { - "pin": "8742125177ae" - }, - "svcore": { - "pin": "aab2d7177d3d" - }, - "svgui": { - "pin": "51e6125627fa" - }, - "svapp": { - "pin": "f03bc1d38cac" - }, - "checker": { - "pin": "cf18645ff411" - }, - "piper": { - "pin": "dde809643316e7bb606fc14d66e55f07059bcf36" - }, - "piper-cpp": { - "pin": "d81b56f1c7372ccf9d21f726d0fc122c2bf93484" - }, - "dataquay": { - "pin": "807b55408d9e" - }, - "bqvec": { - "pin": "3c9de9e7f6e8" - }, - "bqfft": { - "pin": "a766fe47501b" - }, - "bqresample": { - "pin": "a9a5555d9b6d" - }, - "bqaudioio": { - "pin": "d90244c003be" - }, - "sv-dependency-builds": { - "pin": "a69c1527268d" - }, - "icons/scalable": { - "pin": "a0a78163e88e" - } - } -} diff -r dc4e6eb475ed -r adc8a48f4e4c vext-project.json --- a/vext-project.json Tue May 08 14:28:58 2018 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,81 +0,0 @@ -{ - "config": { - "extdir": "." - }, - "services": { - "soundsoftware": { - "vcs": ["hg", "git"], - "anonymous": "https://code.soundsoftware.ac.uk/{vcs}/{repository}", - "authenticated": "https://{account}@code.soundsoftware.ac.uk/{vcs}/{repository}" - } - }, - "libraries": { - "vamp-plugin-sdk": { - "vcs": "hg", - "service": "soundsoftware" - }, - "svcore": { - "vcs": "hg", - "service": "soundsoftware" - }, - "svgui": { - "vcs": "hg", - "service": "soundsoftware" - }, - "svapp": { - "vcs": "hg", - "service": "soundsoftware" - }, - "checker": { - "vcs": "hg", - "service": "soundsoftware", - "repository": "vamp-plugin-load-checker" - }, - "piper": { - "vcs": "git", - "service": "github", - "owner": "piper-audio" - }, - "piper-cpp": { - "vcs": "git", - "service": "github", - "owner": "piper-audio", - "repository": "piper-vamp-cpp" - }, - "dataquay": { - "vcs": "hg", - "service": "bitbucket", - "owner": "breakfastquay" - }, - "bqvec": { - "vcs": "hg", - "service": "bitbucket", - "owner": "breakfastquay" - }, - "bqfft": { - "vcs": "hg", - "service": "bitbucket", - "owner": "breakfastquay" - }, - "bqresample": { - "vcs": "hg", - "service": "bitbucket", - "owner": "breakfastquay" - }, - "bqaudioio": { - "vcs": "hg", - "service": "bitbucket", - "owner": "breakfastquay" - }, - "sv-dependency-builds": { - "vcs": "hg", - "service": "soundsoftware" - }, - "icons/scalable": { - "vcs": "hg", - "service": "soundsoftware", - "repository": "sv-iconset" - } - } -} - diff -r dc4e6eb475ed -r adc8a48f4e4c vext.bat --- a/vext.bat Tue May 08 14:28:58 2018 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3 +0,0 @@ -@echo off -PowerShell -NoProfile -ExecutionPolicy Bypass -Command "& '%~dpn0.ps1' %*"; - diff -r dc4e6eb475ed -r adc8a48f4e4c vext.ps1 --- a/vext.ps1 Tue May 08 14:28:58 2018 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,117 +0,0 @@ -<# - -.SYNOPSIS -A simple manager for third-party source code dependencies. -Run "vext help" for more documentation. - -#> - -Set-StrictMode -Version 2.0 -$ErrorActionPreference = "Stop" -$env:HGPLAIN = "true" - -$sml = $env:VEXT_SML - -$mydir = Split-Path $MyInvocation.MyCommand.Path -Parent -$program = "$mydir/vext.sml" - -# We need either Poly/ML or SML/NJ. No great preference as to which. - -# Typical locations -$env:PATH = "$env:PATH;C:\Program Files (x86)\SMLNJ\bin;C:\Program Files\Poly ML;C:\Program Files (x86)\Poly ML" - -if (!$sml) { - if (Get-Command "sml" -ErrorAction SilentlyContinue) { - $sml = "smlnj" - } elseif (Get-Command "polyml" -ErrorAction SilentlyContinue) { - $sml = "poly" - } else { - echo @" - -ERROR: No supported SML compiler or interpreter found - - The Vext external source code manager needs a Standard ML (SML) - compiler or interpreter to run. - - Please ensure you have one of the following SML implementations - installed and present in your PATH, and try again. - - 1. Standard ML of New Jersey - - executable name: sml - - 2. Poly/ML - - executable name: polyml - -"@ - exit 1 - } -} - -if ($args -match "'""") { - $arglist = '["usage"]' -} else { - $arglist = '["' + ($args -join '","') + '"]' -} - -if ($sml -eq "poly") { - - $program = $program -replace "\\","\\\\" - echo "use ""$program""; vext $arglist" | polyml -q --error-exit | Out-Host - - if (-not $?) { - exit $LastExitCode - } - -} elseif ($sml -eq "smlnj") { - - $lines = @(Get-Content $program) - $lines = $lines -notmatch "val _ = main ()" - - $intro = @" -val smlrun__cp = - let val x = !Control.Print.out in - Control.Print.out := { say = fn _ => (), flush = fn () => () }; - x - end; -val smlrun__prev = ref ""; -Control.Print.out := { - say = fn s => - (if String.isSubstring "Error" s orelse String.isSubstring "Fail" s - then (Control.Print.out := smlrun__cp; - (#say smlrun__cp) (!smlrun__prev); - (#say smlrun__cp) s) - else (smlrun__prev := s; ())), - flush = fn s => () -}; -"@ -split "[\r\n]+" - - $outro = @" -val _ = vext $arglist; -val _ = OS.Process.exit (OS.Process.success); -"@ -split "[\r\n]+" - - $script = @() - $script += $intro - $script += $lines - $script += $outro - - $tmpfile = ([System.IO.Path]::GetTempFileName()) -replace "[.]tmp",".sml" - - $script | Out-File -Encoding "ASCII" $tmpfile - - $env:CM_VERBOSE="false" - - sml $tmpfile - - if (-not $?) { - del $tmpfile - exit $LastExitCode - } - - del $tmpfile - -} else { - - "Unknown SML implementation name: $sml" - exit 2 -} diff -r dc4e6eb475ed -r adc8a48f4e4c vext.sml --- a/vext.sml Tue May 08 14:28:58 2018 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2670 +0,0 @@ -(* - 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 2018 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, - modify, merge, publish, distribute, sublicense, and/or sell copies - of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - 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, - 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.98" - - -datatype vcs = - HG | - GIT | - SVN - -datatype source = - URL_SOURCE of string | - SERVICE_SOURCE of { - service : string, - owner : string option, - repo : string option - } - -type id_or_tag = string - -datatype pin = - UNPINNED | - PINNED of id_or_tag - -datatype libstate = - ABSENT | - CORRECT | - SUPERSEDED | - WRONG - -datatype localstate = - MODIFIED | - LOCK_MISMATCHED | - CLEAN - -datatype branch = - BRANCH of string | - DEFAULT_BRANCH - -(* If we can recover from an error, for example by reporting failure - for this one thing and going on to the next thing, then the error - should usually be returned through a result type rather than an - exception. *) - -datatype 'a result = - OK of 'a | - ERROR of string - -type libname = string - -type libspec = { - libname : libname, - vcs : vcs, - source : source, - branch : branch, - project_pin : pin, - lock_pin : pin -} - -type lock = { - libname : libname, - id_or_tag : id_or_tag -} - -type remote_spec = { - anon : string option, - auth : string option -} - -type provider = { - service : string, - supports : vcs list, - remote_spec : remote_spec -} - -type account = { - service : string, - login : string -} - -type context = { - rootpath : string, - extdir : string, - providers : provider list, - accounts : account list -} - -type userconfig = { - providers : provider list, - accounts : account list -} - -type project = { - context : context, - libs : libspec list -} - -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 - - (** Check whether the given VCS is installed and working *) - val is_working : context -> bool result - - (** Test whether the library is present locally at all *) - val exists : context -> libname -> bool result - - (** Return the id (hash) of the current revision for the library *) - val id_of : context -> libname -> id_or_tag result - - (** Test whether the library is at the given id *) - val is_at : context -> libname * id_or_tag -> bool result - - (** Test whether the library is on the given branch, i.e. is at - the branch tip or an ancestor of it *) - val is_on_branch : context -> libname * branch -> bool result - - (** Test whether the library is at the newest revision for the - given branch. False may indicate that the branch has advanced - or that the library is not on the branch at all. This function - may use the network to check for new revisions *) - val is_newest : context -> libname * source * branch -> bool result - - (** Test whether the library is at the newest revision available - locally for the given branch. False may indicate that the - branch has advanced or that the library is not on the branch - at all. This function must not use the network *) - val is_newest_locally : context -> libname * branch -> bool result - - (** Test whether the library has been modified in the local - working copy *) - val is_modified_locally : context -> libname -> bool result - - (** Check out, i.e. clone a fresh copy of, the repo for the given - library on the given branch *) - val checkout : context -> libname * source * branch -> unit result - - (** Update the library to the given branch tip. Assumes that a - local copy of the library already exists *) - val update : context -> libname * source * branch -> unit result - - (** Update the library to the given specific id or tag *) - val update_to : context -> libname * source * id_or_tag -> unit result - - (** Return a URL from which the library can be cloned, given that - the local copy already exists. For a DVCS this can be the - local copy, but for a centralised VCS it will have to be the - remote repository URL. Used for archiving *) - val copy_url_for : context -> libname -> string result -end - -signature LIB_CONTROL = sig - val review : context -> libspec -> (libstate * localstate) result - val status : context -> libspec -> (libstate * localstate) result - val update : context -> libspec -> unit result - val id_of : context -> libspec -> id_or_tag result - val is_working : context -> vcs -> bool result -end - -structure FileBits :> sig - val extpath : context -> string - val libpath : context -> libname -> string - val subpath : context -> libname -> string -> string - val command_output : context -> libname -> string list -> string result - val command : context -> libname -> string list -> unit result - val file_url : string -> string - val file_contents : string -> string - val mydir : unit -> string - val homedir : unit -> string - val mkpath : string -> unit result - val rmpath : string -> unit result - val nonempty_dir_exists : string -> bool - val project_spec_path : string -> string - val project_lock_path : string -> string - val verbose : unit -> bool -end = struct - - fun verbose () = - case OS.Process.getEnv "VEXT_VERBOSE" of - SOME "0" => false - | SOME _ => true - | NONE => false - - fun split_relative path desc = - case OS.Path.fromString path of - { isAbs = true, ... } => raise Fail (desc ^ " may not be absolute") - | { arcs, ... } => arcs - - fun extpath ({ rootpath, extdir, ... } : context) = - let val { isAbs, vol, arcs } = OS.Path.fromString rootpath - in OS.Path.toString { - isAbs = isAbs, - vol = vol, - arcs = arcs @ - split_relative extdir "extdir" - } - end - - fun subpath ({ rootpath, extdir, ... } : context) libname remainder = - (* NB libname is allowed to be a path fragment, e.g. foo/bar *) - let val { isAbs, vol, arcs } = OS.Path.fromString rootpath - in OS.Path.toString { - isAbs = isAbs, - vol = vol, - arcs = arcs @ - split_relative extdir "extdir" @ - split_relative libname "library path" @ - split_relative remainder "subpath" - } - end - - fun libpath context "" = - extpath context - | libpath context libname = - subpath context libname "" - - fun project_file_path rootpath filename = - let val { isAbs, vol, arcs } = OS.Path.fromString rootpath - in OS.Path.toString { - isAbs = isAbs, - vol = vol, - arcs = arcs @ [ filename ] - } - end - - fun project_spec_path rootpath = - project_file_path rootpath (VextFilenames.project_file) - - fun project_lock_path rootpath = - project_file_path rootpath (VextFilenames.project_lock_file) - - fun trim str = - hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str) - - fun file_url path = - let val forward_path = - String.translate (fn #"\\" => "/" | - c => Char.toString c) - (OS.Path.mkCanonical 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 file_contents filename = - let val stream = TextIO.openIn filename - fun read_all str acc = - case TextIO.inputLine str of - SOME line => read_all str (trim line :: acc) - | NONE => rev acc - val contents = read_all stream [] - val _ = TextIO.closeIn stream - in - String.concatWith "\n" contents - end - - fun expand_commandline cmdlist = - (* We are quite [too] strict about what we accept here, except - for the first element in cmdlist which is assumed to be a - known command location rather than arbitrary user input. NB - only ASCII accepted at this point. *) - let open Char - fun quote arg = - if List.all - (fn c => isAlphaNum c orelse c = #"-" orelse c = #"_") - (explode arg) - then arg - else "\"" ^ arg ^ "\"" - fun check arg = - let val valid = explode " /#:;?,._-{}@=+" - in - app (fn c => - if isAlphaNum c orelse - List.exists (fn v => v = c) valid orelse - c > chr 127 - then () - else raise Fail ("Invalid character '" ^ - (Char.toString c) ^ - "' in command list")) - (explode arg); - arg - end - in - String.concatWith " " - (map quote - (hd cmdlist :: map check (tl cmdlist))) - end - - val tick_cycle = ref 0 - val tick_chars = Vector.fromList (map String.str (explode "|/-\\")) - - fun tick libname cmdlist = - let val n = Vector.length tick_chars - fun pad_to n str = - if n <= String.size str then str - else pad_to n (str ^ " ") - val name = if libname <> "" then libname - else if cmdlist = nil then "" - else hd (rev cmdlist) - in - print (" " ^ - Vector.sub(tick_chars, !tick_cycle) ^ " " ^ - pad_to 70 name ^ - "\r"); - tick_cycle := (if !tick_cycle = n - 1 then 0 else 1 + !tick_cycle) - end - - fun run_command context libname cmdlist redirect = - let open OS - val dir = libpath context libname - val cmd = expand_commandline cmdlist - val _ = if verbose () - then print ("\n=== " ^ dir ^ "\n<<< " ^ cmd ^ "\n") - else tick libname cmdlist - val _ = FileSys.chDir dir - val status = case redirect of - NONE => Process.system cmd - | SOME file => Process.system (cmd ^ ">" ^ file) - in - if Process.isSuccess status - then OK () - else ERROR ("Command failed: " ^ cmd ^ " (in dir " ^ dir ^ ")") - end - handle ex => ERROR ("Unable to run command: " ^ exnMessage ex) - - fun command context libname cmdlist = - run_command context libname cmdlist NONE - - fun command_output context libname cmdlist = - let open OS - val tmpFile = FileSys.tmpName () - val result = run_command context libname cmdlist (SOME tmpFile) - val contents = file_contents tmpFile - val _ = if verbose () - then print (">>> \"" ^ contents ^ "\"\n") - else () - in - FileSys.remove tmpFile handle _ => (); - case result of - OK () => OK contents - | ERROR e => ERROR e - end - - fun mydir () = - let open OS - val { dir, file } = Path.splitDirFile (CommandLine.name ()) - in - FileSys.realPath - (if Path.isAbsolute dir - then dir - else Path.concat (FileSys.getDir (), dir)) - end - - fun homedir () = - (* Failure is not routine, so we use an exception here *) - case (OS.Process.getEnv "HOME", - OS.Process.getEnv "HOMEPATH") of - (SOME home, _) => home - | (NONE, SOME home) => home - | (NONE, NONE) => - raise Fail "Failed to look up home directory from environment" - - fun mkpath' path = - if OS.FileSys.isDir path handle _ => false - then OK () - else case OS.Path.fromString path of - { arcs = nil, ... } => OK () - | { isAbs = false, ... } => ERROR "mkpath requires absolute path" - | { isAbs, vol, arcs } => - case mkpath' (OS.Path.toString { (* parent *) - isAbs = isAbs, - vol = vol, - 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 mkpath path = - mkpath' (OS.Path.mkCanonical path) - - fun dir_contents dir = - 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 - 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 rmpath' path = - let open OS - fun remove path = - if FileSys.isLink path (* dangling links bother isDir *) - then FileSys.remove path - else if FileSys.isDir path - then (app remove (dir_contents path); FileSys.rmDir path) - else FileSys.remove path - in - (remove path; OK ()) - handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e) - end - - fun rmpath path = - rmpath' (OS.Path.mkCanonical path) - - fun nonempty_dir_exists path = - let open OS.FileSys - in - (not (isLink path) andalso - isDir path andalso - dir_contents path <> []) - handle _ => false - end - -end - -functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct - - (* Valid states for unpinned libraries: - - - CORRECT: We are on the right branch and are up-to-date with - it as far as we can tell. (If not using the network, this - should be reported to user as "Present" rather than "Correct" - as the remote repo may have advanced without us knowing.) - - - SUPERSEDED: We are on the right branch but we can see that - there is a newer revision either locally or on the remote (in - Git terms, we are at an ancestor of the desired branch tip). - - - WRONG: We are on the wrong branch (in Git terms, we are not - at the desired branch tip or any ancestor of it). - - - ABSENT: Repo doesn't exist here at all. - - Valid states for pinned libraries: - - - CORRECT: We are at the pinned revision. - - - WRONG: We are at any revision other than the pinned one. - - - ABSENT: Repo doesn't exist here at all. - *) - - fun check with_network context - ({ libname, source, branch, - project_pin, lock_pin, ... } : libspec) = - let fun check_unpinned () = - let val newest = - if with_network - then V.is_newest context (libname, source, branch) - else V.is_newest_locally context (libname, branch) - in - case newest of - ERROR e => ERROR e - | OK true => OK CORRECT - | OK false => - case V.is_on_branch context (libname, branch) of - ERROR e => ERROR e - | OK true => OK SUPERSEDED - | OK false => OK WRONG - end - fun check_pinned target = - case V.is_at context (libname, target) of - ERROR e => ERROR e - | OK true => OK CORRECT - | OK false => OK WRONG - fun check_remote () = - case project_pin of - UNPINNED => check_unpinned () - | PINNED target => check_pinned target - fun check_local () = - case V.is_modified_locally context libname of - ERROR e => ERROR e - | OK true => OK MODIFIED - | OK false => - case lock_pin of - UNPINNED => OK CLEAN - | PINNED target => - case V.is_at context (libname, target) of - ERROR e => ERROR e - | OK true => OK CLEAN - | OK false => OK LOCK_MISMATCHED - in - case V.exists context libname of - ERROR e => ERROR e - | OK false => OK (ABSENT, CLEAN) - | OK true => - case (check_remote (), check_local ()) of - (ERROR e, _) => ERROR e - | (_, ERROR e) => ERROR e - | (OK r, OK l) => OK (r, l) - end - - val review = check true - val status = check false - - fun update context - ({ libname, source, branch, - project_pin, lock_pin, ... } : libspec) = - let fun update_unpinned () = - case V.is_newest context (libname, source, branch) of - ERROR e => ERROR e - | OK true => OK () - | OK false => V.update context (libname, source, branch) - fun update_pinned target = - case V.is_at context (libname, target) of - ERROR e => ERROR e - | OK true => OK () - | OK false => V.update_to context (libname, source, target) - fun update' () = - case lock_pin of - PINNED target => update_pinned target - | UNPINNED => - case project_pin of - PINNED target => update_pinned target - | UNPINNED => update_unpinned () - in - case V.exists context libname of - ERROR e => ERROR e - | OK true => update' () - | OK false => - case V.checkout context (libname, source, branch) of - ERROR e => ERROR e - | OK () => update' () - end - - fun id_of context ({ libname, ... } : libspec) = - V.id_of context libname - - fun is_working context vcs = - V.is_working context - -end - -(* Simple Standard ML JSON parser - https://bitbucket.org/cannam/sml-simplejson - Copyright 2017 Chris Cannam. BSD licence. - Parts based on the JSON parser in the Ponyo library by Phil Eaton. -*) - -signature JSON = sig - - datatype json = OBJECT of (string * json) list - | ARRAY of json list - | NUMBER of real - | STRING of string - | BOOL of bool - | NULL - - datatype 'a result = OK of 'a - | ERROR of string - - val parse : string -> json result - val serialise : json -> string - val serialiseIndented : json -> string - -end - -structure Json :> JSON = struct - - datatype json = OBJECT of (string * json) list - | ARRAY of json list - | NUMBER of real - | STRING of string - | BOOL of bool - | NULL - - datatype 'a result = OK of 'a - | ERROR of string - - structure T = struct - datatype token = NUMBER of char list - | STRING of string - | BOOL of bool - | NULL - | CURLY_L - | CURLY_R - | SQUARE_L - | SQUARE_R - | COLON - | COMMA - - fun toString t = - case t of NUMBER digits => implode digits - | STRING s => s - | BOOL b => Bool.toString b - | NULL => "null" - | CURLY_L => "{" - | CURLY_R => "}" - | SQUARE_L => "[" - | SQUARE_R => "]" - | COLON => ":" - | COMMA => "," - end - - fun bmpToUtf8 cp = (* convert a codepoint in Unicode BMP to utf8 bytes *) - let open Word - infix 6 orb andb >> - in - map (Char.chr o toInt) - (if cp < 0wx80 then - [cp] - else if cp < 0wx800 then - [0wxc0 orb (cp >> 0w6), 0wx80 orb (cp andb 0wx3f)] - else if cp < 0wx10000 then - [0wxe0 orb (cp >> 0w12), - 0wx80 orb ((cp >> 0w6) andb 0wx3f), - 0wx80 orb (cp andb 0wx3f)] - else raise Fail ("Invalid BMP point " ^ (Word.toString cp))) - end - - fun error pos text = ERROR (text ^ " at character position " ^ - Int.toString (pos - 1)) - fun token_error pos = error pos ("Unexpected token") - - fun lexNull pos acc (#"u" :: #"l" :: #"l" :: xs) = - lex (pos + 3) (T.NULL :: acc) xs - | lexNull pos acc _ = token_error pos - - and lexTrue pos acc (#"r" :: #"u" :: #"e" :: xs) = - lex (pos + 3) (T.BOOL true :: acc) xs - | lexTrue pos acc _ = token_error pos - - and lexFalse pos acc (#"a" :: #"l" :: #"s" :: #"e" :: xs) = - lex (pos + 4) (T.BOOL false :: acc) xs - | lexFalse pos acc _ = token_error pos - - and lexChar tok pos acc xs = - lex pos (tok :: acc) xs - - and lexString pos acc cc = - let datatype escaped = ESCAPED | NORMAL - fun lexString' pos text ESCAPED [] = - error pos "End of input during escape sequence" - | lexString' pos text NORMAL [] = - error pos "End of input during string" - | lexString' pos text ESCAPED (x :: xs) = - let fun esc c = lexString' (pos + 1) (c :: text) NORMAL xs - in case x of - #"\"" => esc x - | #"\\" => esc x - | #"/" => esc x - | #"b" => esc #"\b" - | #"f" => esc #"\f" - | #"n" => esc #"\n" - | #"r" => esc #"\r" - | #"t" => esc #"\t" - | _ => error pos ("Invalid escape \\" ^ - Char.toString x) - end - | lexString' pos text NORMAL (#"\\" :: #"u" ::a::b::c::d:: xs) = - if List.all Char.isHexDigit [a,b,c,d] - then case Word.fromString ("0wx" ^ (implode [a,b,c,d])) of - SOME w => (let val utf = rev (bmpToUtf8 w) in - lexString' (pos + 6) (utf @ text) - NORMAL xs - end - handle Fail err => error pos err) - | NONE => error pos "Invalid Unicode BMP escape sequence" - else error pos "Invalid Unicode BMP escape sequence" - | lexString' pos text NORMAL (x :: xs) = - if Char.ord x < 0x20 - then error pos "Invalid unescaped control character" - else - case x of - #"\"" => OK (rev text, xs, pos + 1) - | #"\\" => lexString' (pos + 1) text ESCAPED xs - | _ => lexString' (pos + 1) (x :: text) NORMAL xs - in - case lexString' pos [] NORMAL cc of - OK (text, rest, newpos) => - lex newpos (T.STRING (implode text) :: acc) rest - | ERROR e => ERROR e - end - - and lexNumber firstChar pos acc cc = - let val valid = explode ".+-e" - fun lexNumber' pos digits [] = (rev digits, [], pos) - | lexNumber' pos digits (x :: xs) = - if x = #"E" then lexNumber' (pos + 1) (#"e" :: digits) xs - else if Char.isDigit x orelse List.exists (fn c => x = c) valid - then lexNumber' (pos + 1) (x :: digits) xs - else (rev digits, x :: xs, pos) - val (digits, rest, newpos) = - lexNumber' (pos - 1) [] (firstChar :: cc) - in - case digits of - [] => token_error pos - | _ => lex newpos (T.NUMBER digits :: acc) rest - end - - and lex pos acc [] = OK (rev acc) - | lex pos acc (x::xs) = - (case x of - #" " => lex - | #"\t" => lex - | #"\n" => lex - | #"\r" => lex - | #"{" => lexChar T.CURLY_L - | #"}" => lexChar T.CURLY_R - | #"[" => lexChar T.SQUARE_L - | #"]" => lexChar T.SQUARE_R - | #":" => lexChar T.COLON - | #"," => lexChar T.COMMA - | #"\"" => lexString - | #"t" => lexTrue - | #"f" => lexFalse - | #"n" => lexNull - | x => lexNumber x) (pos + 1) acc xs - - fun show [] = "end of input" - | show (tok :: _) = T.toString tok - - fun parseNumber digits = - (* Note lexNumber already case-insensitised the E for us *) - let open Char - - fun okExpDigits [] = false - | okExpDigits (c :: []) = isDigit c - | okExpDigits (c :: cs) = isDigit c andalso okExpDigits cs - - fun okExponent [] = false - | okExponent (#"+" :: cs) = okExpDigits cs - | okExponent (#"-" :: cs) = okExpDigits cs - | okExponent cc = okExpDigits cc - - fun okFracTrailing [] = true - | okFracTrailing (c :: cs) = - (isDigit c andalso okFracTrailing cs) orelse - (c = #"e" andalso okExponent cs) - - fun okFraction [] = false - | okFraction (c :: cs) = - isDigit c andalso okFracTrailing cs - - fun okPosTrailing [] = true - | okPosTrailing (#"." :: cs) = okFraction cs - | okPosTrailing (#"e" :: cs) = okExponent cs - | okPosTrailing (c :: cs) = - isDigit c andalso okPosTrailing cs - - fun okPositive [] = false - | okPositive (#"0" :: []) = true - | okPositive (#"0" :: #"." :: cs) = okFraction cs - | okPositive (#"0" :: #"e" :: cs) = okExponent cs - | okPositive (#"0" :: cs) = false - | okPositive (c :: cs) = isDigit c andalso okPosTrailing cs - - fun okNumber (#"-" :: cs) = okPositive cs - | okNumber cc = okPositive cc - in - if okNumber digits - then case Real.fromString (implode digits) of - NONE => ERROR "Number out of range" - | SOME r => OK r - else ERROR ("Invalid number \"" ^ (implode digits) ^ "\"") - end - - fun parseObject (T.CURLY_R :: xs) = OK (OBJECT [], xs) - | parseObject tokens = - let fun parsePair (T.STRING key :: T.COLON :: xs) = - (case parseTokens xs of - ERROR e => ERROR e - | OK (j, xs) => OK ((key, j), xs)) - | parsePair other = - ERROR ("Object key/value pair expected around \"" ^ - show other ^ "\"") - fun parseObject' acc [] = ERROR "End of input during object" - | parseObject' acc tokens = - case parsePair tokens of - ERROR e => ERROR e - | OK (pair, T.COMMA :: xs) => - parseObject' (pair :: acc) xs - | OK (pair, T.CURLY_R :: xs) => - OK (OBJECT (rev (pair :: acc)), xs) - | OK (_, _) => ERROR "Expected , or } after object element" - in - parseObject' [] tokens - end - - and parseArray (T.SQUARE_R :: xs) = OK (ARRAY [], xs) - | parseArray tokens = - let fun parseArray' acc [] = ERROR "End of input during array" - | parseArray' acc tokens = - case parseTokens tokens of - ERROR e => ERROR e - | OK (j, T.COMMA :: xs) => parseArray' (j :: acc) xs - | OK (j, T.SQUARE_R :: xs) => OK (ARRAY (rev (j :: acc)), xs) - | OK (_, _) => ERROR "Expected , or ] after array element" - in - parseArray' [] tokens - end - - and parseTokens [] = ERROR "Value expected" - | parseTokens (tok :: xs) = - (case tok of - T.NUMBER d => (case parseNumber d of - OK r => OK (NUMBER r, xs) - | ERROR e => ERROR e) - | T.STRING s => OK (STRING s, xs) - | T.BOOL b => OK (BOOL b, xs) - | T.NULL => OK (NULL, xs) - | T.CURLY_L => parseObject xs - | T.SQUARE_L => parseArray xs - | _ => ERROR ("Unexpected token " ^ T.toString tok ^ - " before " ^ show xs)) - - fun parse str = - case lex 1 [] (explode str) of - ERROR e => ERROR e - | OK tokens => case parseTokens tokens of - OK (value, []) => OK value - | OK (_, _) => ERROR "Extra data after input" - | ERROR e => ERROR e - - fun stringEscape s = - let fun esc x = [x, #"\\"] - fun escape' acc [] = rev acc - | escape' acc (x :: xs) = - escape' (case x of - #"\"" => esc x @ acc - | #"\\" => esc x @ acc - | #"\b" => esc #"b" @ acc - | #"\f" => esc #"f" @ acc - | #"\n" => esc #"n" @ acc - | #"\r" => esc #"r" @ acc - | #"\t" => esc #"t" @ acc - | _ => - let val c = Char.ord x - in - if c < 0x20 - then let val hex = Word.toString (Word.fromInt c) - in (rev o explode) (if c < 0x10 - then ("\\u000" ^ hex) - else ("\\u00" ^ hex)) - end @ acc - else - x :: acc - end) - xs - in - implode (escape' [] (explode s)) - end - - fun serialise json = - case json of - OBJECT pp => "{" ^ String.concatWith - "," (map (fn (key, value) => - serialise (STRING key) ^ ":" ^ - serialise value) pp) ^ - "}" - | ARRAY arr => "[" ^ String.concatWith "," (map serialise arr) ^ "]" - | NUMBER n => implode (map (fn #"~" => #"-" | c => c) - (explode (Real.toString n))) - | STRING s => "\"" ^ stringEscape s ^ "\"" - | BOOL b => Bool.toString b - | NULL => "null" - - fun serialiseIndented json = - let fun indent 0 = "" - | indent i = " " ^ indent (i - 1) - fun serialiseIndented' i json = - let val ser = serialiseIndented' (i + 1) - in - case json of - OBJECT [] => "{}" - | ARRAY [] => "[]" - | OBJECT pp => "{\n" ^ indent (i + 1) ^ - String.concatWith - (",\n" ^ indent (i + 1)) - (map (fn (key, value) => - ser (STRING key) ^ ": " ^ - ser value) pp) ^ - "\n" ^ indent i ^ "}" - | ARRAY arr => "[\n" ^ indent (i + 1) ^ - String.concatWith - (",\n" ^ indent (i + 1)) - (map ser arr) ^ - "\n" ^ indent i ^ "]" - | other => serialise other - end - in - serialiseIndented' 0 json ^ "\n" - end - -end - - -structure JsonBits :> sig - exception Config of string - val load_json_from : string -> Json.json (* filename -> json *) - val save_json_to : string -> Json.json -> unit - val lookup_optional : Json.json -> string list -> Json.json option - val lookup_optional_string : Json.json -> string list -> string option - val lookup_mandatory : Json.json -> string list -> Json.json - val lookup_mandatory_string : Json.json -> string list -> string -end = struct - - exception Config of string - - fun load_json_from filename = - case Json.parse (FileBits.file_contents filename) of - Json.OK json => json - | Json.ERROR e => raise Config ("Failed to parse file: " ^ e) - - fun save_json_to filename json = - (* using binary I/O to avoid ever writing CR/LF line endings *) - let val jstr = Json.serialiseIndented json - val stream = BinIO.openOut filename - in - BinIO.output (stream, Byte.stringToBytes jstr); - BinIO.closeOut stream - end - - fun lookup_optional json kk = - let fun lookup key = - case json of - Json.OBJECT kvs => - (case List.filter (fn (k, v) => k = key) kvs of - [] => NONE - | [(_,v)] => SOME v - | _ => raise Config ("Duplicate key: " ^ - (String.concatWith " -> " kk))) - | _ => raise Config "Object expected" - in - case kk of - [] => NONE - | key::[] => lookup key - | key::kk => case lookup key of - NONE => NONE - | SOME j => lookup_optional j kk - end - - fun lookup_optional_string json kk = - case lookup_optional json kk of - SOME (Json.STRING s) => SOME s - | SOME _ => raise Config ("Value (if present) must be string: " ^ - (String.concatWith " -> " kk)) - | NONE => NONE - - fun lookup_mandatory json kk = - case lookup_optional json kk of - SOME v => v - | NONE => raise Config ("Value is mandatory: " ^ - (String.concatWith " -> " kk)) - - fun lookup_mandatory_string json kk = - case lookup_optional json kk of - SOME (Json.STRING s) => s - | _ => raise Config ("Value must be string: " ^ - (String.concatWith " -> " kk)) -end - -structure Provider :> sig - val load_providers : Json.json -> provider list - val load_more_providers : provider list -> Json.json -> provider list - val remote_url : context -> vcs -> source -> libname -> string -end = struct - - val known_providers : provider list = - [ { - service = "bitbucket", - supports = [HG, GIT], - remote_spec = { - anon = SOME "https://bitbucket.org/{owner}/{repository}", - auth = SOME "ssh://{vcs}@bitbucket.org/{owner}/{repository}" - } - }, - { - service = "github", - supports = [GIT], - remote_spec = { - anon = SOME "https://github.com/{owner}/{repository}", - auth = SOME "ssh://{vcs}@github.com/{owner}/{repository}" - } - } - ] - - fun vcs_name vcs = - case vcs of HG => "hg" - | GIT => "git" - | SVN => "svn" - - fun vcs_from_name name = - case name of "hg" => HG - | "git" => GIT - | "svn" => SVN - | other => raise Fail ("Unknown vcs name \"" ^ name ^ "\"") - - fun load_more_providers previously_loaded json = - let open JsonBits - fun load pjson pname : provider = - { - service = pname, - supports = - case lookup_mandatory pjson ["vcs"] of - Json.ARRAY vv => - map (fn (Json.STRING v) => vcs_from_name v - | _ => raise Fail "Strings expected in vcs array") - vv - | _ => raise Fail "Array expected for vcs", - remote_spec = { - anon = lookup_optional_string pjson ["anonymous"], - auth = lookup_optional_string pjson ["authenticated"] - } - } - val loaded = - case lookup_optional json ["services"] of - NONE => [] - | SOME (Json.OBJECT pl) => map (fn (k, v) => load v k) pl - | _ => raise Fail "Object expected for services in config" - val newly_loaded = - List.filter (fn p => not (List.exists (fn pp => #service p = - #service pp) - previously_loaded)) - loaded - in - previously_loaded @ newly_loaded - end - - fun load_providers json = - load_more_providers known_providers json - - fun expand_spec spec { vcs, service, owner, repo } login = - (* ugly *) - let fun replace str = - case str of - "vcs" => vcs_name vcs - | "service" => service - | "owner" => - (case owner of - SOME ostr => ostr - | NONE => raise Fail ("Owner not specified for service " ^ - service)) - | "repository" => repo - | "account" => - (case login of - SOME acc => acc - | NONE => raise Fail ("Account not given for service " ^ - service)) - | other => raise Fail ("Unknown variable \"" ^ other ^ - "\" in spec for service " ^ service) - fun expand' acc sstr = - case Substring.splitl (fn c => c <> #"{") sstr of - (pfx, sfx) => - if Substring.isEmpty sfx - then rev (pfx :: acc) - else - case Substring.splitl (fn c => c <> #"}") sfx of - (tok, remainder) => - if Substring.isEmpty remainder - then rev (tok :: pfx :: acc) - else let val replacement = - replace - (* tok begins with "{": *) - (Substring.string - (Substring.triml 1 tok)) - in - expand' (Substring.full replacement :: - pfx :: acc) - (* remainder begins with "}": *) - (Substring.triml 1 remainder) - end - in - Substring.concat (expand' [] (Substring.full spec)) - end - - fun provider_url req login providers = - case providers of - [] => raise Fail ("Unknown service \"" ^ (#service req) ^ - "\" for vcs \"" ^ (vcs_name (#vcs req)) ^ "\"") - | ({ service, supports, remote_spec : remote_spec } :: rest) => - if service <> (#service req) orelse - not (List.exists (fn v => v = (#vcs req)) supports) - then provider_url req login rest - else - case (login, #auth remote_spec, #anon remote_spec) of - (SOME _, SOME auth, _) => expand_spec auth req login - | (SOME _, _, SOME anon) => expand_spec anon req NONE - | (NONE, _, SOME anon) => expand_spec anon req NONE - | _ => raise Fail ("No suitable anonymous or authenticated " ^ - "URL spec provided for service \"" ^ - service ^ "\"") - - fun login_for ({ accounts, ... } : context) service = - case List.find (fn a => service = #service a) accounts of - SOME { login, ... } => SOME login - | NONE => NONE - - fun reponame_for path = - case String.tokens (fn c => c = #"/") path of - [] => raise Fail "Non-empty library path required" - | toks => hd (rev toks) - - fun remote_url (context : context) vcs source libname = - case source of - URL_SOURCE u => u - | SERVICE_SOURCE { service, owner, repo } => - provider_url { vcs = vcs, - service = service, - owner = owner, - repo = case repo of - SOME r => r - | NONE => reponame_for libname } - (login_for context service) - (#providers context) -end - -structure HgControl :> VCS_CONTROL = struct - - (* Pulls always use an explicit URL, never just the default - remote, in order to ensure we update properly if the location - given in the project file changes. *) - - type vcsstate = { id: string, modified: bool, - branch: string, tags: string list } - - val hg_program = "hg" - - val hg_args = [ "--config", "ui.interactive=true", - "--config", "ui.merge=:merge" ] - - fun hg_command context libname args = - FileBits.command context libname (hg_program :: hg_args @ args) - - fun hg_command_output context libname args = - FileBits.command_output context libname (hg_program :: hg_args @ args) - - fun is_working context = - case hg_command_output context "" ["--version"] of - OK "" => OK false - | OK _ => OK true - | ERROR e => ERROR e - - fun exists context libname = - OK (OS.FileSys.isDir (FileBits.subpath context libname ".hg")) - handle _ => OK false - - fun remote_for context (libname, source) = - Provider.remote_url context HG source libname - - fun current_state context libname : vcsstate result = - let fun is_branch text = text <> "" andalso #"(" = hd (explode text) - and extract_branch b = - if is_branch b (* need to remove enclosing parens *) - then (implode o rev o tl o rev o tl o explode) b - else "default" - and is_modified id = id <> "" andalso #"+" = hd (rev (explode id)) - and extract_id id = - if is_modified id (* need to remove trailing "+" *) - then (implode o rev o tl o rev o explode) id - else id - and split_tags tags = String.tokens (fn c => c = #"/") tags - and state_for (id, branch, tags) = - OK { id = extract_id id, - modified = is_modified id, - branch = extract_branch branch, - tags = split_tags tags } - in - case hg_command_output context libname ["id"] of - ERROR e => ERROR e - | OK out => - case String.tokens (fn x => x = #" ") out of - [id, branch, tags] => state_for (id, branch, tags) - | [id, other] => if is_branch other - then state_for (id, other, "") - else state_for (id, "", other) - | [id] => state_for (id, "", "") - | _ => ERROR ("Unexpected output from hg id: " ^ out) - end - - fun branch_name branch = case branch of - DEFAULT_BRANCH => "default" - | BRANCH "" => "default" - | BRANCH b => b - - fun id_of context libname = - case current_state context libname of - ERROR e => ERROR e - | OK { id, ... } => OK id - - fun is_at context (libname, id_or_tag) = - case current_state context libname of - ERROR e => ERROR e - | OK { id, tags, ... } => - OK (String.isPrefix id_or_tag id orelse - String.isPrefix id id_or_tag orelse - List.exists (fn t => t = id_or_tag) tags) - - fun is_on_branch context (libname, b) = - case current_state context libname of - ERROR e => ERROR e - | OK { branch, ... } => OK (branch = branch_name b) - - fun is_newest_locally context (libname, branch) = - case hg_command_output context libname - ["log", "-l1", - "-b", branch_name branch, - "--template", "{node}"] of - ERROR e => OK false (* desired branch does not exist *) - | OK newest_in_repo => is_at context (libname, newest_in_repo) - - fun pull context (libname, source) = - let val url = remote_for context (libname, source) - in - hg_command context libname - (if FileBits.verbose () - then ["pull", url] - else ["pull", "-q", url]) - end - - fun is_newest context (libname, source, branch) = - case is_newest_locally context (libname, branch) of - ERROR e => ERROR e - | OK false => OK false - | OK true => - case pull context (libname, source) of - ERROR e => ERROR e - | _ => is_newest_locally context (libname, branch) - - fun is_modified_locally context libname = - case current_state context libname of - ERROR e => ERROR e - | OK { modified, ... } => OK modified - - fun checkout context (libname, source, branch) = - let val url = remote_for context (libname, source) - in - (* make the lib dir rather than just the ext dir, since - the lib dir might be nested and hg will happily check - out into an existing empty dir anyway *) - case FileBits.mkpath (FileBits.libpath context libname) of - ERROR e => ERROR e - | _ => hg_command context "" - ["clone", "-u", branch_name branch, - url, libname] - end - - fun update context (libname, source, branch) = - let val pull_result = pull context (libname, source) - in - case hg_command context libname ["update", branch_name branch] of - ERROR e => ERROR e - | _ => - case pull_result of - ERROR e => ERROR e - | _ => OK () - end - - fun update_to context (libname, _, "") = - ERROR "Non-empty id (tag or revision id) required for update_to" - | update_to context (libname, source, id) = - let val pull_result = pull context (libname, source) - in - case hg_command context libname ["update", "-r", id] of - OK _ => OK () - | ERROR e => - case pull_result of - ERROR e' => ERROR e' (* this was the ur-error *) - | _ => ERROR e - end - - fun copy_url_for context libname = - OK (FileBits.file_url (FileBits.libpath context libname)) - -end - -structure GitControl :> VCS_CONTROL = struct - - (* With Git repos we always operate in detached HEAD state. Even - the master branch is checked out using a remote reference - (vext/master). The remote we use is always named vext, and we - update it to the expected URL each time we fetch, in order to - ensure we update properly if the location given in the project - file changes. The origin remote is unused. *) - - val git_program = "git" - - fun git_command context libname args = - FileBits.command context libname (git_program :: args) - - fun git_command_output context libname args = - FileBits.command_output context libname (git_program :: args) - - fun is_working context = - case git_command_output context "" ["--version"] of - OK "" => OK false - | OK _ => OK true - | ERROR e => ERROR e - - fun exists context libname = - OK (OS.FileSys.isDir (FileBits.subpath context libname ".git")) - handle _ => OK false - - fun remote_for context (libname, source) = - Provider.remote_url context GIT source libname - - fun branch_name branch = case branch of - DEFAULT_BRANCH => "master" - | BRANCH "" => "master" - | BRANCH b => b - - val our_remote = "vext" - - fun remote_branch_name branch = our_remote ^ "/" ^ branch_name branch - - fun checkout context (libname, source, branch) = - let val url = remote_for context (libname, source) - in - (* make the lib dir rather than just the ext dir, since - the lib dir might be nested and git will happily check - out into an existing empty dir anyway *) - case FileBits.mkpath (FileBits.libpath context libname) of - OK () => git_command context "" - ["clone", "--origin", our_remote, - "--branch", branch_name branch, - url, libname] - | ERROR e => ERROR e - end - - fun add_our_remote context (libname, source) = - (* When we do the checkout ourselves (above), we add the - remote at the same time. But if the repo was cloned by - someone else, we'll need to do it after the fact. Git - doesn't seem to have a means to add a remote or change its - url if it already exists; seems we have to do this: *) - let val url = remote_for context (libname, source) - in - case git_command context libname - ["remote", "set-url", our_remote, url] of - OK () => OK () - | ERROR e => git_command context libname - ["remote", "add", "-f", our_remote, url] - end - - (* NB git rev-parse HEAD shows revision id of current checkout; - git rev-list -1 shows revision id of revision with that tag *) - - fun id_of context libname = - git_command_output context libname ["rev-parse", "HEAD"] - - fun is_at context (libname, id_or_tag) = - case id_of context libname of - ERROR e => OK false (* HEAD nonexistent, expected in empty repo *) - | OK id => - if String.isPrefix id_or_tag id orelse - String.isPrefix id id_or_tag - then OK true - else is_at_tag context (libname, id, id_or_tag) - - and is_at_tag context (libname, id, tag) = - (* For annotated tags (with message) show-ref returns the tag - object ref rather than that of the revision being tagged; - we need the subsequent rev-list to chase that up. In fact - the rev-list on its own is enough to get us the id direct - from the tag name, but it fails with an error if the tag - doesn't exist, whereas we want to handle that quietly in - case the tag simply hasn't been pulled yet *) - case git_command_output context libname - ["show-ref", "refs/tags/" ^ tag, "--"] of - OK "" => OK false (* Not a tag *) - | ERROR _ => OK false - | OK s => - let val tag_ref = hd (String.tokens (fn c => c = #" ") s) - in - case git_command_output context libname - ["rev-list", "-1", tag_ref] of - OK tagged => OK (id = tagged) - | ERROR _ => OK false - end - - fun branch_tip context (libname, branch) = - (* We don't have access to the source info or the network - here, as this is used by status (e.g. via is_on_branch) as - well as review. It's possible the remote branch won't exist, - e.g. if the repo was checked out by something other than - Vext, and if that's the case, we can't add it here; we'll - just have to fail, since checking against local branches - instead could produce the wrong result. *) - git_command_output context libname - ["rev-list", "-1", - remote_branch_name branch, "--"] - - fun is_newest_locally context (libname, branch) = - case branch_tip context (libname, branch) of - ERROR e => OK false - | OK rev => is_at context (libname, rev) - - fun is_on_branch context (libname, branch) = - case branch_tip context (libname, branch) of - ERROR e => OK false - | OK rev => - case is_at context (libname, rev) of - ERROR e => ERROR e - | OK true => OK true - | OK false => - case git_command context libname - ["merge-base", "--is-ancestor", - "HEAD", remote_branch_name branch] of - ERROR e => OK false (* cmd returns non-zero for no *) - | _ => OK true - - fun fetch context (libname, source) = - case add_our_remote context (libname, source) of - ERROR e => ERROR e - | _ => git_command context libname ["fetch", our_remote] - - fun is_newest context (libname, source, branch) = - case add_our_remote context (libname, source) of - ERROR e => ERROR e - | OK () => - case is_newest_locally context (libname, branch) of - ERROR e => ERROR e - | OK false => OK false - | OK true => - case fetch context (libname, source) of - ERROR e => ERROR e - | _ => is_newest_locally context (libname, branch) - - fun is_modified_locally context libname = - case git_command_output context libname ["status", "--porcelain"] of - ERROR e => ERROR e - | OK "" => OK false - | OK _ => OK true - - (* This function updates to the latest revision on a branch rather - than to a specific id or tag. We can't just checkout the given - branch, as that will succeed even if the branch isn't up to - date. We could checkout the branch and then fetch and merge, - but it's perhaps cleaner not to maintain a local branch at all, - but instead checkout the remote branch as a detached head. *) - - fun update context (libname, source, branch) = - case fetch context (libname, source) of - ERROR e => ERROR e - | _ => - case git_command context libname ["checkout", "--detach", - remote_branch_name branch] of - ERROR e => ERROR e - | _ => OK () - - (* This function is dealing with a specific id or tag, so if we - can successfully check it out (detached) then that's all we - need to do, regardless of whether fetch succeeded or not. We do - attempt the fetch first, though, purely in order to avoid ugly - error messages in the common case where we're being asked to - update to a new pin (from the lock file) that hasn't been - fetched yet. *) - - fun update_to context (libname, _, "") = - ERROR "Non-empty id (tag or revision id) required for update_to" - | update_to context (libname, source, id) = - let val fetch_result = fetch context (libname, source) - in - case git_command context libname ["checkout", "--detach", id] of - OK _ => OK () - | ERROR e => - case fetch_result of - ERROR e' => ERROR e' (* this was the ur-error *) - | _ => ERROR e - end - - fun copy_url_for context libname = - OK (FileBits.file_url (FileBits.libpath context libname)) - -end - -(* SubXml - A parser for a subset of XML - https://bitbucket.org/cannam/sml-subxml - Copyright 2018 Chris Cannam. BSD licence. -*) - -signature SUBXML = sig - - datatype node = ELEMENT of { name : string, children : node list } - | ATTRIBUTE of { name : string, value : string } - | TEXT of string - | CDATA of string - | COMMENT of string - - datatype document = DOCUMENT of { name : string, children : node list } - - datatype 'a result = OK of 'a - | ERROR of string - - val parse : string -> document result - val serialise : document -> string - -end - -structure SubXml :> SUBXML = struct - - datatype node = ELEMENT of { name : string, children : node list } - | ATTRIBUTE of { name : string, value : string } - | TEXT of string - | CDATA of string - | COMMENT of string - - datatype document = DOCUMENT of { name : string, children : node list } - - datatype 'a result = OK of 'a - | ERROR of string - - structure T = struct - datatype token = ANGLE_L - | ANGLE_R - | ANGLE_SLASH_L - | SLASH_ANGLE_R - | EQUAL - | NAME of string - | TEXT of string - | CDATA of string - | COMMENT of string - - fun name t = - case t of ANGLE_L => "<" - | ANGLE_R => ">" - | ANGLE_SLASH_L => " "/>" - | EQUAL => "=" - | NAME s => "name \"" ^ s ^ "\"" - | TEXT s => "text" - | CDATA _ => "CDATA section" - | COMMENT _ => "comment" - end - - structure Lex :> sig - val lex : string -> T.token list result - end = struct - - fun error pos text = - ERROR (text ^ " at character position " ^ Int.toString (pos-1)) - fun tokenError pos token = - error pos ("Unexpected token '" ^ Char.toString token ^ "'") - - val nameEnd = explode " \t\n\r\"'!=?" - - fun quoted quote pos acc cc = - let fun quoted' pos text [] = - error pos "Document ends during quoted string" - | quoted' pos text (x::xs) = - if x = quote - then OK (rev text, xs, pos+1) - else quoted' (pos+1) (x::text) xs - in - case quoted' pos [] cc of - ERROR e => ERROR e - | OK (text, rest, newpos) => - inside newpos (T.TEXT (implode text) :: acc) rest - end - - and name first pos acc cc = - let fun name' pos text [] = - error pos "Document ends during name" - | name' pos text (x::xs) = - if List.find (fn c => c = x) nameEnd <> NONE - then OK (rev text, (x::xs), pos) - else name' (pos+1) (x::text) xs - in - case name' (pos-1) [] (first::cc) of - ERROR e => ERROR e - | OK ([], [], pos) => error pos "Document ends before name" - | OK ([], (x::xs), pos) => tokenError pos x - | OK (text, rest, pos) => - inside pos (T.NAME (implode text) :: acc) rest - end - - and comment pos acc cc = - let fun comment' pos text cc = - case cc of - #"-" :: #"-" :: #">" :: xs => OK (rev text, xs, pos+3) - | x :: xs => comment' (pos+1) (x::text) xs - | [] => error pos "Document ends during comment" - in - case comment' pos [] cc of - ERROR e => ERROR e - | OK (text, rest, pos) => - outside pos (T.COMMENT (implode text) :: acc) rest - end - - and instruction pos acc cc = - case cc of - #"?" :: #">" :: xs => outside (pos+2) acc xs - | #">" :: _ => tokenError pos #">" - | x :: xs => instruction (pos+1) acc xs - | [] => error pos "Document ends during processing instruction" - - and cdata pos acc cc = - let fun cdata' pos text cc = - case cc of - #"]" :: #"]" :: #">" :: xs => OK (rev text, xs, pos+3) - | x :: xs => cdata' (pos+1) (x::text) xs - | [] => error pos "Document ends during CDATA section" - in - case cdata' pos [] cc of - ERROR e => ERROR e - | OK (text, rest, pos) => - outside pos (T.CDATA (implode text) :: acc) rest - end - - and doctype pos acc cc = - case cc of - #">" :: xs => outside (pos+1) acc xs - | x :: xs => doctype (pos+1) acc xs - | [] => error pos "Document ends during DOCTYPE" - - and declaration pos acc cc = - case cc of - #"-" :: #"-" :: xs => - comment (pos+2) acc xs - | #"[" :: #"C" :: #"D" :: #"A" :: #"T" :: #"A" :: #"[" :: xs => - cdata (pos+7) acc xs - | #"D" :: #"O" :: #"C" :: #"T" :: #"Y" :: #"P" :: #"E" :: xs => - doctype (pos+7) acc xs - | [] => error pos "Document ends during declaration" - | _ => error pos "Unsupported declaration type" - - and left pos acc cc = - case cc of - #"/" :: xs => inside (pos+1) (T.ANGLE_SLASH_L :: acc) xs - | #"!" :: xs => declaration (pos+1) acc xs - | #"?" :: xs => instruction (pos+1) acc xs - | xs => inside pos (T.ANGLE_L :: acc) xs - - and slash pos acc cc = - case cc of - #">" :: xs => outside (pos+1) (T.SLASH_ANGLE_R :: acc) xs - | x :: _ => tokenError pos x - | [] => error pos "Document ends before element closed" - - and close pos acc xs = outside pos (T.ANGLE_R :: acc) xs - - and equal pos acc xs = inside pos (T.EQUAL :: acc) xs - - and outside pos acc [] = OK acc - | outside pos acc cc = - let fun textOf text = T.TEXT (implode (rev text)) - fun outside' pos [] acc [] = OK acc - | outside' pos text acc [] = OK (textOf text :: acc) - | outside' pos text acc (x::xs) = - case x of - #"<" => if text = [] - then left (pos+1) acc xs - else left (pos+1) (textOf text :: acc) xs - | x => outside' (pos+1) (x::text) acc xs - in - outside' pos [] acc cc - end - - and inside pos acc [] = error pos "Document ends within tag" - | inside pos acc (#"<"::_) = tokenError pos #"<" - | inside pos acc (x::xs) = - (case x of - #" " => inside | #"\t" => inside - | #"\n" => inside | #"\r" => inside - | #"\"" => quoted x | #"'" => quoted x - | #"/" => slash | #">" => close | #"=" => equal - | x => name x) (pos+1) acc xs - - fun lex str = - case outside 1 [] (explode str) of - ERROR e => ERROR e - | OK tokens => OK (rev tokens) - end - - structure Parse :> sig - val parse : string -> document result - end = struct - - fun show [] = "end of input" - | show (tok :: _) = T.name tok - - fun error toks text = ERROR (text ^ " before " ^ show toks) - - fun attribute elt name toks = - case toks of - T.EQUAL :: T.TEXT value :: xs => - namedElement { - name = #name elt, - children = ATTRIBUTE { name = name, value = value } :: - #children elt - } xs - | T.EQUAL :: xs => error xs "Expected attribute value" - | toks => error toks "Expected attribute assignment" - - and content elt toks = - case toks of - T.ANGLE_SLASH_L :: T.NAME n :: T.ANGLE_R :: xs => - if n = #name elt - then OK (elt, xs) - else ERROR ("Closing tag " ^ - "does not match opening <" ^ #name elt ^ ">") - | T.TEXT text :: xs => - content { - name = #name elt, - children = TEXT text :: #children elt - } xs - | T.CDATA text :: xs => - content { - name = #name elt, - children = CDATA text :: #children elt - } xs - | T.COMMENT text :: xs => - content { - name = #name elt, - children = COMMENT text :: #children elt - } xs - | T.ANGLE_L :: xs => - (case element xs of - ERROR e => ERROR e - | OK (child, xs) => - content { - name = #name elt, - children = ELEMENT child :: #children elt - } xs) - | tok :: xs => - error xs ("Unexpected token " ^ T.name tok) - | [] => - ERROR ("Document ends within element \"" ^ #name elt ^ "\"") - - and namedElement elt toks = - case toks of - T.SLASH_ANGLE_R :: xs => OK (elt, xs) - | T.NAME name :: xs => attribute elt name xs - | T.ANGLE_R :: xs => content elt xs - | x :: xs => error xs ("Unexpected token " ^ T.name x) - | [] => ERROR "Document ends within opening tag" - - and element toks = - case toks of - T.NAME name :: xs => - (case namedElement { name = name, children = [] } xs of - ERROR e => ERROR e - | OK ({ name, children }, xs) => - OK ({ name = name, children = rev children }, xs)) - | toks => error toks "Expected element name" - - and document [] = ERROR "Empty document" - | document (tok :: xs) = - case tok of - T.TEXT _ => document xs - | T.COMMENT _ => document xs - | T.ANGLE_L => - (case element xs of - ERROR e => ERROR e - | OK (elt, []) => OK (DOCUMENT elt) - | OK (elt, (T.TEXT _ :: xs)) => OK (DOCUMENT elt) - | OK (elt, xs) => error xs "Extra data after document") - | _ => error xs ("Unexpected token " ^ T.name tok) - - fun parse str = - case Lex.lex str of - ERROR e => ERROR e - | OK tokens => document tokens - end - - structure Serialise :> sig - val serialise : document -> string - end = struct - - fun attributes nodes = - String.concatWith - " " - (map node (List.filter - (fn ATTRIBUTE _ => true | _ => false) - nodes)) - - and nonAttributes nodes = - String.concat - (map node (List.filter - (fn ATTRIBUTE _ => false | _ => true) - nodes)) - - and node n = - case n of - TEXT string => - string - | CDATA string => - "" - | COMMENT string => - "" - | ATTRIBUTE { name, value } => - name ^ "=" ^ "\"" ^ value ^ "\"" (*!!!*) - | ELEMENT { name, children } => - "<" ^ name ^ - (case (attributes children) of - "" => "" - | s => " " ^ s) ^ - (case (nonAttributes children) of - "" => "/>" - | s => ">" ^ s ^ "") - - fun serialise (DOCUMENT { name, children }) = - "\n" ^ - node (ELEMENT { name = name, children = children }) - end - - val parse = Parse.parse - val serialise = Serialise.serialise - -end - - -structure SvnControl :> VCS_CONTROL = struct - - val svn_program = "svn" - - fun svn_command context libname args = - FileBits.command context libname (svn_program :: args) - - fun svn_command_output context libname args = - FileBits.command_output context libname (svn_program :: args) - - fun svn_command_lines context libname args = - case svn_command_output context libname args of - ERROR e => ERROR e - | OK s => OK (String.tokens (fn c => c = #"\n" orelse c = #"\r") s) - - fun split_line_pair line = - let fun strip_leading_ws str = case explode str of - #" "::rest => implode rest - | _ => str - in - case String.tokens (fn c => c = #":") line of - [] => ("", "") - | first::rest => - (first, strip_leading_ws (String.concatWith ":" rest)) - end - - fun is_working context = - case svn_command_output context "" ["--version"] of - OK "" => OK false - | OK _ => OK true - | ERROR e => ERROR e - - structure X = SubXml - - fun svn_info context libname route = - (* SVN 1.9 has info --show-item which is just what we need, - but at this point we still have 1.8 on the CI boxes so we - might as well aim to support it. For that we really have to - use the XML output format, since the default info output is - localised. This is the only thing our mini-XML parser is - used for though, so it would be good to trim it at some - point *) - let fun find elt [] = OK elt - | find { children, ... } (first :: rest) = - case List.find (fn (X.ELEMENT { name, ... }) => name = first - | _ => false) - children of - NONE => ERROR ("No element \"" ^ first ^ "\" in SVN XML") - | SOME (X.ELEMENT e) => find e rest - | SOME _ => ERROR "Internal error" - in - case svn_command_output context libname ["info", "--xml"] of - ERROR e => ERROR e - | OK xml => - case X.parse xml of - X.ERROR e => ERROR e - | X.OK (X.DOCUMENT doc) => find doc route - end - - fun exists context libname = - OK (OS.FileSys.isDir (FileBits.subpath context libname ".svn")) - handle _ => OK false - - fun remote_for context (libname, source) = - Provider.remote_url context SVN source libname - - (* Remote the checkout came from, not necessarily the one we want *) - fun actual_remote_for context libname = - case svn_info context libname ["entry", "url"] of - ERROR e => ERROR e - | OK { children, ... } => - case List.find (fn (X.TEXT _) => true | _ => false) children of - NONE => ERROR "No content for URL in SVN info XML" - | SOME (X.TEXT url) => OK url - | SOME _ => ERROR "Internal error" - - fun id_of context libname = - case svn_info context libname ["entry"] of - ERROR e => ERROR e - | OK { children, ... } => - case List.find - (fn (X.ATTRIBUTE { name = "revision", ... }) => true - | _ => false) - children of - NONE => ERROR "No revision for entry in SVN info XML" - | SOME (X.ATTRIBUTE { value, ... }) => OK value - | SOME _ => ERROR "Internal error" - - fun is_at context (libname, id_or_tag) = - case id_of context libname of - ERROR e => ERROR e - | OK id => OK (id = id_or_tag) - - fun is_on_branch context (libname, b) = - OK (b = DEFAULT_BRANCH) - - fun check_remote context (libname, source) = - case (remote_for context (libname, source), - actual_remote_for context libname) of - (_, ERROR e) => ERROR e - | (url, OK actual) => - if actual = url - then OK () - else svn_command context libname ["relocate", url] - - fun is_newest context (libname, source, branch) = - case check_remote context (libname, source) of - ERROR e => ERROR e - | OK () => - case svn_command_lines context libname - ["status", "--show-updates"] of - ERROR e => ERROR e - | OK lines => - case rev lines of - [] => ERROR "No result returned for server status" - | last_line::_ => - case rev (String.tokens (fn c => c = #" ") last_line) of - [] => ERROR "No revision field found in server status" - | server_id::_ => is_at context (libname, server_id) - - fun is_newest_locally context (libname, branch) = - OK true (* no local history *) - - fun is_modified_locally context libname = - case svn_command_output context libname ["status"] of - ERROR e => ERROR e - | OK "" => OK false - | OK _ => OK true - - fun checkout context (libname, source, branch) = - let val url = remote_for context (libname, source) - val path = FileBits.libpath context libname - in - if FileBits.nonempty_dir_exists path - then (* Surprisingly, SVN itself has no problem with - this. But for consistency with other VCSes we - don't allow it *) - ERROR ("Refusing checkout to nonempty dir \"" ^ path ^ "\"") - else - (* make the lib dir rather than just the ext dir, since - the lib dir might be nested and svn will happily check - out into an existing empty dir anyway *) - case FileBits.mkpath (FileBits.libpath context libname) of - ERROR e => ERROR e - | _ => svn_command context "" ["checkout", url, libname] - end - - fun update context (libname, source, branch) = - case check_remote context (libname, source) of - ERROR e => ERROR e - | OK () => - case svn_command context libname - ["update", "--accept", "postpone"] of - ERROR e => ERROR e - | _ => OK () - - fun update_to context (libname, _, "") = - ERROR "Non-empty id (tag or revision id) required for update_to" - | update_to context (libname, source, id) = - case check_remote context (libname, source) of - ERROR e => ERROR e - | OK () => - case svn_command context libname - ["update", "-r", id, "--accept", "postpone"] of - ERROR e => ERROR e - | OK _ => OK () - - fun copy_url_for context libname = - actual_remote_for context libname - -end - -structure AnyLibControl :> LIB_CONTROL = struct - - structure H = LibControlFn(HgControl) - structure G = LibControlFn(GitControl) - structure S = LibControlFn(SvnControl) - - fun review context (spec as { vcs, ... } : libspec) = - (fn HG => H.review | GIT => G.review | SVN => S.review) vcs context spec - - fun status context (spec as { vcs, ... } : libspec) = - (fn HG => H.status | GIT => G.status | SVN => S.status) vcs context spec - - fun update context (spec as { vcs, ... } : libspec) = - (fn HG => H.update | GIT => G.update | SVN => S.update) vcs context spec - - fun id_of context (spec as { vcs, ... } : libspec) = - (fn HG => H.id_of | GIT => G.id_of | SVN => S.id_of) vcs context spec - - fun is_working context vcs = - (fn HG => H.is_working | GIT => G.is_working | SVN => S.is_working) - vcs context vcs - -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_id_and_url dir = - let val context = { - rootpath = dir, - extdir = ".", - providers = [], - accounts = [] - } - val vcs_maybe = - case [HgControl.exists context ".", - GitControl.exists context ".", - SvnControl.exists context "."] of - [OK true, OK false, OK false] => OK HG - | [OK false, OK true, OK false] => OK GIT - | [OK false, OK false, OK true] => OK SVN - | _ => 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 - | SVN => SvnControl.id_of) - vcs context "." of - ERROR e => ERROR ("Unable to find id of project repo: " ^ e) - | OK id => - case (fn HG => HgControl.copy_url_for - | GIT => GitControl.copy_url_for - | SVN => SvnControl.copy_url_for) - vcs context "." of - ERROR e => ERROR ("Unable to find URL of project repo: " - ^ e) - | OK url => OK (vcs, id, url) - 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 make_archive_copy target_name (vcs, project_id, source_url) - ({ 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 source_url, - 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=.svn", - "--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_id_and_url (#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] - val vcs = lookup_mandatory_string libobj ["vcs"] - val retrieve = lookup_optional_string libobj - val service = retrieve ["service"] - val owner = retrieve ["owner"] - val repo = retrieve ["repository"] - val url = retrieve ["url"] - val branch = retrieve ["branch"] - val project_pin = case retrieve ["pin"] of - NONE => UNPINNED - | SOME p => PINNED p - val lock_pin = case lookup_optional lock_json [libobjname, libname] of - NONE => UNPINNED - | SOME ll => case lookup_optional_string ll ["pin"] of - SOME p => PINNED p - | NONE => UNPINNED - in - { - libname = libname, - vcs = case vcs of - "hg" => HG - | "git" => GIT - | "svn" => SVN - | other => raise Fail ("Unknown version-control system \"" ^ - other ^ "\""), - source = case (url, service, owner, repo) of - (SOME u, NONE, _, _) => URL_SOURCE u - | (NONE, SOME ss, owner, repo) => - SERVICE_SOURCE { service = ss, owner = owner, repo = repo } - | _ => raise Fail ("Must have exactly one of service " ^ - "or url string"), - project_pin = project_pin, - lock_pin = lock_pin, - branch = case branch of - NONE => DEFAULT_BRANCH - | SOME b => - case vcs of - "svn" => raise Fail ("Branches not supported for " ^ - "svn repositories; change " ^ - "URL instead") - | _ => BRANCH b - } - end - -fun load_userconfig () : userconfig = - let val home = FileBits.homedir () - val conf_json = - JsonBits.load_json_from - (OS.Path.joinDirFile { - dir = home, - file = VextFilenames.user_config_file }) - handle IO.Io _ => Json.OBJECT [] - in - { - accounts = case JsonBits.lookup_optional conf_json ["accounts"] of - NONE => [] - | SOME (Json.OBJECT aa) => - map (fn (k, (Json.STRING v)) => - { service = k, login = v } - | _ => raise Fail - "String expected for account name") - aa - | _ => raise Fail "Array expected for accounts", - providers = Provider.load_providers conf_json - } - end - -datatype pintype = - NO_LOCKFILE | - USE_LOCKFILE - -fun load_project (userconfig : userconfig) rootpath pintype : project = - let val spec_file = FileBits.project_spec_path rootpath - val lock_file = FileBits.project_lock_path rootpath - val _ = if OS.FileSys.access (spec_file, [OS.FileSys.A_READ]) - handle OS.SysErr _ => false - then () - else raise Fail ("Failed to open project spec file " ^ - (VextFilenames.project_file) ^ " in " ^ - rootpath ^ - ".\nPlease ensure the spec file is in the " ^ - "project root and run this from there.") - val spec_json = JsonBits.load_json_from spec_file - val lock_json = if pintype = USE_LOCKFILE - then JsonBits.load_json_from lock_file - handle IO.Io _ => Json.OBJECT [] - else Json.OBJECT [] - val extdir = JsonBits.lookup_mandatory_string spec_json - ["config", "extdir"] - val spec_libs = JsonBits.lookup_optional spec_json [libobjname] - val lock_libs = JsonBits.lookup_optional lock_json [libobjname] - val providers = Provider.load_more_providers - (#providers userconfig) spec_json - val libnames = case spec_libs of - NONE => [] - | SOME (Json.OBJECT ll) => map (fn (k, v) => k) ll - | _ => raise Fail "Object expected for libs" - in - { - context = { - rootpath = rootpath, - extdir = extdir, - providers = providers, - accounts = #accounts userconfig - }, - libs = map (load_libspec spec_json lock_json) libnames - } - end - -fun save_lock_file rootpath locks = - let val lock_file = FileBits.project_lock_path rootpath - open Json - val lock_json = - OBJECT [ - (libobjname, - OBJECT (map (fn { libname, id_or_tag } => - (libname, - OBJECT [ ("pin", STRING id_or_tag) ])) - locks)) - ] - in - JsonBits.save_json_to lock_file lock_json - end - -fun pad_to n str = - if n <= String.size str then str - else pad_to n (str ^ " ") - -fun hline_to 0 = "" - | hline_to n = "-" ^ hline_to (n-1) - -val libname_width = 28 -val libstate_width = 11 -val localstate_width = 17 -val notes_width = 5 -val divider = " | " -val clear_line = "\r" ^ pad_to 80 ""; - -fun print_status_header () = - print (clear_line ^ "\n " ^ - pad_to libname_width "Library" ^ divider ^ - pad_to libstate_width "State" ^ divider ^ - pad_to localstate_width "Local" ^ divider ^ - "Notes" ^ "\n " ^ - hline_to libname_width ^ "-+-" ^ - hline_to libstate_width ^ "-+-" ^ - hline_to localstate_width ^ "-+-" ^ - hline_to notes_width ^ "\n") - -fun print_outcome_header () = - print (clear_line ^ "\n " ^ - pad_to libname_width "Library" ^ divider ^ - pad_to libstate_width "Outcome" ^ divider ^ - "Notes" ^ "\n " ^ - hline_to libname_width ^ "-+-" ^ - hline_to libstate_width ^ "-+-" ^ - hline_to notes_width ^ "\n") - -fun print_status with_network (lib : libspec, status) = - let val libstate_str = - case status of - OK (ABSENT, _) => "Absent" - | OK (CORRECT, _) => if with_network then "Correct" else "Present" - | OK (SUPERSEDED, _) => "Superseded" - | OK (WRONG, _) => "Wrong" - | ERROR _ => "Error" - val localstate_str = - case status of - OK (_, MODIFIED) => "Modified" - | OK (_, LOCK_MISMATCHED) => "Differs from Lock" - | OK (_, CLEAN) => "Clean" - | ERROR _ => "" - val error_str = - case status of - ERROR e => e - | _ => "" - in - print (" " ^ - pad_to libname_width (#libname lib) ^ divider ^ - pad_to libstate_width libstate_str ^ divider ^ - pad_to localstate_width localstate_str ^ divider ^ - error_str ^ "\n") - end - -fun print_update_outcome (lib : libspec, outcome) = - let val outcome_str = - case outcome of - OK id => "Ok" - | ERROR e => "Failed" - val error_str = - case outcome of - ERROR e => e - | _ => "" - in - print (" " ^ - pad_to libname_width (#libname lib) ^ divider ^ - pad_to libstate_width outcome_str ^ divider ^ - error_str ^ "\n") - end - -fun vcs_name HG = ("Mercurial", "hg") - | vcs_name GIT = ("Git", "git") - | vcs_name SVN = ("Subversion", "svn") - -fun print_problem_summary context lines = - let val failed_vcs = - foldl (fn (({ vcs, ... } : libspec, ERROR _), acc) => vcs::acc - | (_, acc) => acc) [] lines - fun report_nonworking vcs error = - print ((if error = "" then "" else error ^ "\n\n") ^ - "Error: The project uses the " ^ (#1 (vcs_name vcs)) ^ - " version control system, but its\n" ^ - "executable program (" ^ (#2 (vcs_name vcs)) ^ - ") does not appear to be installed in the program path\n\n") - fun check_working [] checked = () - | check_working (vcs::rest) checked = - if List.exists (fn v => vcs = v) checked - then check_working rest checked - else - case AnyLibControl.is_working context vcs of - OK true => check_working rest checked - | OK false => (report_nonworking vcs ""; - check_working rest (vcs::checked)) - | ERROR e => (report_nonworking vcs e; - check_working rest (vcs::checked)) - in - print "\nError: Some operations failed\n\n"; - check_working failed_vcs [] - end - -fun act_and_print action print_header print_line context (libs : libspec list) = - let val lines = map (fn lib => (lib, action lib)) libs - val imperfect = List.exists (fn (_, ERROR _) => true | _ => false) lines - val _ = print_header () - in - app print_line lines; - if imperfect then print_problem_summary context lines else (); - lines - end - -fun return_code_for outcomes = - foldl (fn ((_, result), acc) => - case result of - ERROR _ => OS.Process.failure - | _ => acc) - OS.Process.success - outcomes - -fun status_of_project ({ context, libs } : project) = - return_code_for (act_and_print (AnyLibControl.status context) - print_status_header (print_status false) - context libs) - -fun review_project ({ context, libs } : project) = - return_code_for (act_and_print (AnyLibControl.review context) - print_status_header (print_status true) - context libs) - -fun lock_project ({ context, libs } : project) = - let val _ = if FileBits.verbose () - then print ("Scanning IDs for lock file...\n") - else () - val outcomes = map (fn lib => (lib, AnyLibControl.id_of context lib)) - libs - val locks = - List.concat - (map (fn (lib : libspec, result) => - case result of - ERROR _ => [] - | OK id => [{ libname = #libname lib, - id_or_tag = id }]) - outcomes) - val return_code = return_code_for outcomes - val _ = print clear_line - in - if OS.Process.isSuccess return_code - then save_lock_file (#rootpath context) locks - else (); - return_code - end - -fun update_project (project as { context, libs }) = - let val outcomes = act_and_print - (AnyLibControl.update context) - print_outcome_header print_update_outcome - context libs - val _ = if List.exists (fn (_, OK _) => true | _ => false) outcomes - then lock_project project - else OS.Process.success - in - return_code_for outcomes - 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 open OS.Process - val return_code = - f (load_local_project pintype) - handle Fail msg => - failure before print ("Error: " ^ msg) - | JsonBits.Config msg => - failure before print ("Error in configuration: " ^ msg) - | e => - failure before print ("Error: " ^ exnMessage e) - val _ = print "\n"; - in - return_code - end - -fun review () = with_local_project USE_LOCKFILE review_project -fun status () = with_local_project USE_LOCKFILE status_of_project -fun update () = with_local_project NO_LOCKFILE update_project -fun lock () = with_local_project NO_LOCKFILE lock_project -fun install () = with_local_project USE_LOCKFILE update_project - -fun version () = - (print ("v" ^ vext_version ^ "\n"); - OS.Process.success) - -fun usage () = - (print "\nVext "; - version (); - print ("\nA simple manager for third-party source code dependencies.\n\n" - ^ "Usage:\n\n" - ^ " vext \n\n" - ^ "where is one of:\n\n" - ^ " 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 - | arg::_ => (print ("Error: unknown argument \"" ^ arg ^ "\"\n"); - usage ()) - | _ => usage () - in - OS.Process.exit return_code; - () - end - -fun main () = - vext (CommandLine.arguments ())