diff --git a/src/pkg.sml b/src/pkg.sml index 3b3f2a7..8fc3750 100644 --- a/src/pkg.sml +++ b/src/pkg.sml @@ -1,385 +1,501 @@ - -structure Pkg : sig val main : string -> unit end = +structure Pkg: +sig + val main: string -> unit +end = struct -structure Solve = Solve(PkgInfo) - -(* Some utilities *) -fun println s = print (s ^ "\n") - -fun log s = if !PkgInfo.verboseFlag then println ("[" ^ s ^ "]") else () - -fun isPrefixList (nil,_) = true - | isPrefixList (x::xs,y::ys) = x = y andalso isPrefixList (xs,ys) - | isPrefixList _ = false - -fun isInPkgDir (from_dir:string) (f:string) : bool = - isPrefixList(System.splitPath from_dir, System.splitPath f) - -fun is_in e l = List.exists (fn x => x = e) l - -structure M = FinMapEq -type filepath = string -type pkgpath = Manifest.pkgpath -type required = Manifest.required -type buildlist = Solve.buildlist -type semver = SemVer.t - -infix -val op = System. - -val smlpkg_filename = Manifest.smlpkg_filename - -(* Installing packages *) - -fun installInDir (bl:buildlist) (dir:filepath) : unit = - let fun unpack (p,v) = - let val info = PkgInfo.lookupPackageRev p v - val zipurl = PkgInfo.pkgRevZipballUrl info - val () = log ("downloading " ^ zipurl) - val a = Zip.download zipurl - val m = PkgInfo.pkgRevGetManifest info - (* Compute the directory in the zipball that should contain the - package files. *) - val from_dir = - case Manifest.pkg_dir m of - SOME d => PkgInfo.pkgRevZipballDir info d - | NONE => raise Fail (smlpkg_filename() ^ " for " - ^ Manifest.pkgpathToString p ^ "-" - ^ SemVer.toString v - ^ " does not define a package path.") - (* The directory in the local file system that will contain the - package files . *) - val pdir = dir Manifest.pkgpathToString p - (* Remove any existing directory for this package. This is a bit - inefficient, as the likelihood that the old ``lib`` directory - already contains the correct version is rather high. We should - have a way to recognise this situation, and not download the - zipball in that case. *) - in System.removePathForcibly pdir - ; Zip.extractSubDir {log=log} a {path=from_dir,target=pdir} - end - val list = M.toList bl - in List.app unpack list - ; log (Int.toString (length list) ^ " packages extracted") + structure Solve = Solve(PkgInfo) + + (* Some utilities *) + fun println s = + print (s ^ "\n") + + fun log s = + if ! PkgInfo.verboseFlag then println ("[" ^ s ^ "]") else () + + fun isPrefixList (nil, _) = true + | isPrefixList (x :: xs, y :: ys) = + x = y andalso isPrefixList (xs, ys) + | isPrefixList _ = false + + fun isInPkgDir (from_dir: string) (f: string) : bool = + isPrefixList (System.splitPath from_dir, System.splitPath f) + + fun is_in e l = + List.exists (fn x => x = e) l + + structure M = FinMapEq + type filepath = string + type pkgpath = Manifest.pkgpath + type required = Manifest.required + type buildlist = Solve.buildlist + type semver = SemVer.t + + infix + val op = System. + + val smlpkg_filename = Manifest.smlpkg_filename + + (* Installing packages *) + + fun installInDir (bl: buildlist) (dir: filepath) : unit = + let + fun install (p, v) = + let + val info = PkgInfo.lookupPackageRev p v + val repo_url = PkgInfo.pkgRevRepoUrl info + val refe = PkgInfo.pkgRevRef info + val () = log ("cloning " ^ repo_url ^ " @ " ^ refe) + val m = PkgInfo.pkgRevGetManifest info + (* Compute the directory in the repository that contains the + package files. *) + val from_dir = + case Manifest.pkg_dir m of + SOME d => d + | NONE => + raise Fail + (smlpkg_filename () ^ " for " ^ Manifest.pkgpathToString p + ^ "-" ^ SemVer.toString v + ^ " does not define a package path.") + (* The directory in the local file system that will contain the + package files. *) + val pdir = dir Manifest.pkgpathToString p + (* Remove any existing directory for this package. *) + val () = System.removePathForcibly pdir + (* Get the cached bare repository *) + val bare_repo = PkgInfo.getCachedRepo repo_url + (* Extract files from the bare repository to a temporary location *) + val tmpdir = OS.FileSys.tmpName () ^ "-smlpkg-install" + val () = log + ("extracting " ^ refe ^ " to temporary directory " ^ tmpdir) + val () = + if System.doesDirExist tmpdir then () else OS.FileSys.mkDir tmpdir + (* Perform extraction, copying, and cleanup, ensuring tmpdir is removed on failure. *) + in + (* Use git archive to extract the specific ref *) + + let + val archive_cmd = + "git --git-dir=" ^ System.shellEscape bare_repo ^ " archive " + ^ System.shellEscape refe ^ " | tar -x -C " + ^ System.shellEscape tmpdir + val (status, out, err) = System.command archive_cmd + val () = + if OS.Process.isSuccess status then + () + else + raise Fail + ("Failed to extract " ^ refe ^ " from " ^ repo_url ^ ": " + ^ err) + (* Copy the package directory to the target location *) + val src = tmpdir from_dir + val () = log ("copying " ^ src ^ " to " ^ pdir) + val () = System.createDirectoryIfMissing true pdir + (* Use cp -r to copy all files *) + val copy_cmd = + "cp -r " ^ System.shellEscape (src ^ "/.") ^ " " + ^ System.shellEscape pdir ^ "/" + val (status3, out3, err3) = System.command copy_cmd + val () = + if OS.Process.isSuccess status3 then () + else raise Fail ("Failed to copy package files: " ^ err3) + (* Clean up temporary directory on success *) + val () = log ("removing temporary directory " ^ tmpdir) + val () = System.removePathForcibly tmpdir + in + () + end + handle e => + ( log ("removing temporary directory " ^ tmpdir) + ; System.removePathForcibly tmpdir + ; raise e + ) + end + val list = M.toList bl + in + List.app install list; + log (Int.toString (length list) ^ " packages installed") end -val (libDir:filepath, libNewDir:filepath, libOldDir:filepath) = + val (libDir: filepath, libNewDir: filepath, libOldDir: filepath) = ("lib", "lib~new", "lib~old") -(* - Install the packages listed in the build list in the 'lib' - directory of the current working directory. Since we are touching - the file system, we are going to be very paranoid. In particular, - we want to avoid corrupting the 'lib' directory if something fails - along the way. - - The procedure is as follows: - - 1) Create a directory 'lib~new'. Delete an existing 'lib~new' if - necessary. - - 2) Populate 'lib~new' based on the build list. - - 3) Rename 'lib' to 'lib~old'. Delete an existing 'lib~old' if - necessary. - - 4) Rename 'lib~new' to 'lib' - - 5) If the current package has package path 'p', move 'lib~old/p' to - 'lib~new/p'. - - 6) Delete 'lib~old'. - - Since POSIX at least guarantees atomic renames, the only place this - can fail is between steps 3, 4, and 5. In that case, at least the - 'lib~old' will still exist and can be put back by the user. -*) - -fun installBuildList (p:pkgpath option) (bl:buildlist) : unit = - let val libdir_exists = System.doesDirExist libDir - - val () = System.removePathForcibly libNewDir (* 1 *) - val () = System.createDirectoryIfMissing false libNewDir - - val () = installInDir bl libNewDir (* 2 *) - - val () = if libdir_exists then (* 3 *) - ( System.removePathForcibly libOldDir - ; System.renameDirectory libDir libOldDir) - else () - - val () = System.renameDirectory libNewDir libDir (* 4 *) - - val () = case Option.map Manifest.pkgpathToString p of (* 5 *) - SOME pfp => - if libdir_exists then - let val pkgdir_exists = System.doesDirExist (libOldDir pfp) - in if pkgdir_exists then - (* Ensure the parent directories exist so that we can move the - package directory directly. *) - ( System.createDirectoryIfMissing true (System.takeDirectory (libDir pfp)) - ; System.renameDirectory (libOldDir pfp) (libDir pfp)) - else () - end - else () - | NONE => () + (* + Install the packages listed in the build list in the 'lib' + directory of the current working directory. Since we are touching + the file system, we are going to be very paranoid. In particular, + we want to avoid corrupting the 'lib' directory if something fails + along the way. + + The procedure is as follows: + + 1) Create a directory 'lib~new'. Delete an existing 'lib~new' if + necessary. + + 2) Populate 'lib~new' based on the build list. + + 3) Rename 'lib' to 'lib~old'. Delete an existing 'lib~old' if + necessary. + + 4) Rename 'lib~new' to 'lib' + + 5) If the current package has package path 'p', move 'lib~old/p' to + 'lib~new/p'. + + 6) Delete 'lib~old'. + + Since POSIX at least guarantees atomic renames, the only place this + can fail is between steps 3, 4, and 5. In that case, at least the + 'lib~old' will still exist and can be put back by the user. + *) + + fun installBuildList (p: pkgpath option) (bl: buildlist) : unit = + let + val libdir_exists = System.doesDirExist libDir + + val () = System.removePathForcibly libNewDir (* 1 *) + val () = System.createDirectoryIfMissing false libNewDir + + val () = installInDir bl libNewDir (* 2 *) + + val () = + if libdir_exists then (* 3 *) + ( System.removePathForcibly libOldDir + ; System.renameDirectory libDir libOldDir + ) + else + () + + val () = System.renameDirectory libNewDir libDir (* 4 *) + + val () = + case Option.map Manifest.pkgpathToString p of (* 5 *) + SOME pfp => + if libdir_exists then + let + val pkgdir_exists = System.doesDirExist (libOldDir pfp) + in + if pkgdir_exists then + (* Ensure the parent directories exist so that we can move the + package directory directly. *) + ( System.createDirectoryIfMissing true + (System.takeDirectory (libDir pfp)) + ; System.renameDirectory (libOldDir pfp) (libDir pfp) + ) + else + () + end + else + () + | NONE => () - val () = if libdir_exists then (* 6 *) - System.removePathForcibly libOldDir - else () - in () + val () = + if libdir_exists then (* 6 *) System.removePathForcibly libOldDir + else () + in + () end -fun getPkgManifest () : Manifest.t = - let val smlpkg = smlpkg_filename () - in if System.doesDirExist smlpkg then - raise Fail (smlpkg ^ - " exists, but it is a directory! What in Odin's beard...") - else if System.doesFileExist smlpkg then - Manifest.fromFile smlpkg - else ( log (smlpkg ^ " not found - pretending it's empty.") - ; Manifest.empty NONE) + fun getPkgManifest () : Manifest.t = + let + val smlpkg = smlpkg_filename () + in + if System.doesDirExist smlpkg then + raise Fail + (smlpkg ^ " exists, but it is a directory! What in Odin's beard...") + else if System.doesFileExist smlpkg then + Manifest.fromFile smlpkg + else + ( log (smlpkg ^ " not found - pretending it's empty.") + ; Manifest.empty NONE + ) end -fun putPkgManifest (m:Manifest.t) : unit = - System.writeFile (smlpkg_filename()) (Manifest.toString m) + fun putPkgManifest (m: Manifest.t) : unit = + System.writeFile (smlpkg_filename ()) (Manifest.toString m) -(* The Command-line interface *) + (* The Command-line interface *) -fun usageMsg s = - let val prog = OS.Path.file (CommandLine.name()) - in print ("Usage: " ^ prog ^ " [--version] [--verbose] [--help] " ^ s ^ "\n") - ; OS.Process.exit(OS.Process.failure) + fun usageMsg s = + let + val prog = OS.Path.file (CommandLine.name ()) + in + print ("Usage: " ^ prog ^ " [--version] [--verbose] [--help] " ^ s ^ "\n"); + OS.Process.exit (OS.Process.failure) end -fun doFmt args = + fun doFmt args = case args of - [] => let val smlpkg = smlpkg_filename() - val m = Manifest.fromFile smlpkg - in System.writeFile smlpkg (Manifest.toString m) - end - | _ => raise Fail "command 'fmt' expects zero arguments." + [] => + let + val smlpkg = smlpkg_filename () + val m = Manifest.fromFile smlpkg + in + System.writeFile smlpkg (Manifest.toString m) + end + | _ => raise Fail "command 'fmt' expects zero arguments." -fun doCheck args = + fun doCheck args = case args of - [] => let val m = getPkgManifest() - val bl = Solve.solveDeps (Solve.pkgRevDeps m) - val () = println "Dependencies chosen:" - val () = println (Solve.buildListToString bl) - in case Manifest.package m of - NONE => () - | SOME pkgpath => - let val pdir = "lib" Manifest.pkgpathToString pkgpath - val pdir_exists = OS.FileSys.isDir pdir - in if pdir_exists then () - else raise Fail ("the directory " ^ pdir ^ " does not exist.") - end + [] => + let + val m = getPkgManifest () + val bl = Solve.solveDeps (Solve.pkgRevDeps m) + val () = println "Dependencies chosen:" + val () = println (Solve.buildListToString bl) + in + case Manifest.package m of + NONE => () + | SOME pkgpath => + let + val pdir = "lib" Manifest.pkgpathToString pkgpath + val pdir_exists = OS.FileSys.isDir pdir + in + if pdir_exists then () + else raise Fail ("the directory " ^ pdir ^ " does not exist.") end - | _ => raise Fail "command 'check' expects zero arguments." + end + | _ => raise Fail "command 'check' expects zero arguments." -fun doSync args = + fun doSync args = case args of - [] => let val m = getPkgManifest() - val bl = Solve.solveDeps (Solve.pkgRevDeps m) - in installBuildList (Manifest.package m) bl - end - | _ => raise Fail "command 'sync' expects zero arguments." + [] => + let + val m = getPkgManifest () + val bl = Solve.solveDeps (Solve.pkgRevDeps m) + in + installBuildList (Manifest.package m) bl + end + | _ => raise Fail "command 'sync' expects zero arguments." -fun pkgpathParse (s:string) : pkgpath = + fun pkgpathParse (s: string) : pkgpath = case Manifest.pkgpathFromString s of - SOME p => p - | NONE => raise Fail ("invalid package path '" ^ s ^ "'.") + SOME p => p + | NONE => raise Fail ("invalid package path '" ^ s ^ "'.") -fun semverParse (s:string) : semver = + fun semverParse (s: string) : semver = case SemVer.fromString s of - SOME v => v - | NONE => raise Fail ("invalid semantic version '" ^ s ^ "'.") - -fun doAdd' (p:pkgpath) (v:semver) : unit = - let val m = getPkgManifest() - - (* See if this package (and its dependencies) even exists. We - do this by running the solver with the dependencies already - in the manifest, plus this new one. The Monoid instance - for PkgRevDeps is left-biased, so we are careful to use the - new version for this package. *) - - val () = ignore (Solve.solveDeps (M.add (p,(v,NONE)) - (Solve.pkgRevDeps m))) - - (* We either replace any existing occurence of package 'p', or - we add a new one. *) - val p_info = PkgInfo.lookupPackageRev p v - val hash_opt = case (SemVer.major v, SemVer.minor v, SemVer.patch v) of - (* We do not perform hash-pinning for - (0,0,0)-versions, because these already embed a - specific revision ID into their version number. *) - (0,0,0) => NONE - | _ => SOME (PkgInfo.pkgRevCommit p_info) - val req = (p, v, hash_opt) - val prev_r = Manifest.get_required m p - val m = case prev_r of - SOME _ => let val m = Manifest.del_required p m - in Manifest.add_required req m - end - | NONE => Manifest.add_required req m - val () = - case prev_r of - SOME prev_r' => - if #2 prev_r' = v - then println ("Package already at version " ^ SemVer.toString v ^ - "; nothing to do.") - else println ("Replaced " ^ Manifest.pkgpathToString p ^ " " ^ - SemVer.toString (#2 prev_r') ^ " => " ^ - SemVer.toString v ^ ".") - | NONE => println ("Added new required package " ^ Manifest.pkgpathToString p ^ - " " ^ SemVer.toString v ^ ".") - in putPkgManifest m - ; println ("Remember to run '" ^ OS.Path.file(CommandLine.name()) ^ - " sync'.") + SOME v => v + | NONE => raise Fail ("invalid semantic version '" ^ s ^ "'.") + + fun doAdd' (p: pkgpath) (v: semver) : unit = + let + val m = getPkgManifest () + + (* See if this package (and its dependencies) even exists. We + do this by running the solver with the dependencies already + in the manifest, plus this new one. The Monoid instance + for PkgRevDeps is left-biased, so we are careful to use the + new version for this package. *) + + val () = ignore (Solve.solveDeps + (M.add (p, (v, NONE)) (Solve.pkgRevDeps m))) + + (* We either replace any existing occurence of package 'p', or + we add a new one. *) + val p_info = PkgInfo.lookupPackageRev p v + val hash_opt = + case (SemVer.major v, SemVer.minor v, SemVer.patch v) of + (* We do not perform hash-pinning for + (0,0,0)-versions, because these already embed a + specific revision ID into their version number. *) + (0, 0, 0) => NONE + | _ => SOME (PkgInfo.pkgRevCommit p_info) + val req = (p, v, hash_opt) + val prev_r = Manifest.get_required m p + val m = + case prev_r of + SOME _ => + let val m = Manifest.del_required p m + in Manifest.add_required req m + end + | NONE => Manifest.add_required req m + val () = + case prev_r of + SOME prev_r' => + if #2 prev_r' = v then + println + ("Package already at version " ^ SemVer.toString v + ^ "; nothing to do.") + else + println + ("Replaced " ^ Manifest.pkgpathToString p ^ " " + ^ SemVer.toString (#2 prev_r') ^ " => " ^ SemVer.toString v + ^ ".") + | NONE => + println + ("Added new required package " ^ Manifest.pkgpathToString p ^ " " + ^ SemVer.toString v ^ ".") + in + putPkgManifest m; + println + ("Remember to run '" ^ OS.Path.file (CommandLine.name ()) ^ " sync'.") end -fun doAdd args : unit = + fun doAdd args : unit = case args of - [p, v] => doAdd' (pkgpathParse p) (semverParse v) - | [p] => doAdd' (pkgpathParse p) (PkgInfo.lookupNewestRev (pkgpathParse p)) - | _ => raise Fail "command 'add' expects one or two arguments." + [p, v] => doAdd' (pkgpathParse p) (semverParse v) + | [p] => doAdd' (pkgpathParse p) (PkgInfo.lookupNewestRev (pkgpathParse p)) + | _ => raise Fail "command 'add' expects one or two arguments." -fun doRemove args : unit = + fun doRemove args : unit = case args of - [p as ps] => - let val m = getPkgManifest() - val p = pkgpathParse p - in case Manifest.get_required m p of - SOME r => - let val m = Manifest.del_required p m - in putPkgManifest m - ; println ("Removed " ^ ps ^ " " ^ SemVer.toString (#2 r) ^ ".") - end - | NONE => - raise Fail ("no package " ^ ps ^ " found in " ^ smlpkg_filename() ^ ".") + [p as ps] => + let + val m = getPkgManifest () + val p = pkgpathParse p + in + case Manifest.get_required m p of + SOME r => + let + val m = Manifest.del_required p m + in + putPkgManifest m; + println ("Removed " ^ ps ^ " " ^ SemVer.toString (#2 r) ^ ".") + end + | NONE => + raise Fail + ("no package " ^ ps ^ " found in " ^ smlpkg_filename () ^ ".") end - | _ => raise Fail "command 'remove' expects one argument." + | _ => raise Fail "command 'remove' expects one argument." -fun doInit args = + fun doInit args = case args of - [p as ps] => - let val smlpkg = smlpkg_filename() - val () = log "checking for package file" - val () = if System.doesFileExist smlpkg - then raise Fail (smlpkg ^ " already exists.") - else () - val p = pkgpathParse p - val () = log "creating directory 'lib'" - val () = System.createDirectoryIfMissing true ("lib" ps) - val () = println("Created directory 'lib/" ^ ps ^ "'.") - val m = Manifest.empty (SOME p) - in putPkgManifest m - ; println ("Wrote " ^ smlpkg_filename() ^ ".") + [p as ps] => + let + val smlpkg = smlpkg_filename () + val () = log "checking for package file" + val () = + if System.doesFileExist smlpkg then + raise Fail (smlpkg ^ " already exists.") + else + () + val p = pkgpathParse p + val () = log "creating directory 'lib'" + val () = System.createDirectoryIfMissing true ("lib" ps) + val () = println ("Created directory 'lib/" ^ ps ^ "'.") + val m = Manifest.empty (SOME p) + in + putPkgManifest m; + println ("Wrote " ^ smlpkg_filename () ^ ".") end - | _ => raise Fail "command 'init' expects one argument." + | _ => raise Fail "command 'init' expects one argument." -fun doUpgrade args : unit = + fun doUpgrade args : unit = case args of - [] => - let fun upgrade (req:required) : required = - let val v = PkgInfo.lookupNewestRev (#1 req) - val h = PkgInfo.pkgRevCommit (PkgInfo.lookupPackageRev (#1 req) v) - in if v <> (#2 req) then - ( println ("Upgraded " ^ Manifest.pkgpathToString (#1 req) ^ " " ^ - SemVer.toString (#2 req) ^ " => " ^ - SemVer.toString v ^ ".") - ; (#1 req, v, SOME h) - ) - else req - end - val m = getPkgManifest() - val rs0 = Manifest.requires m - val rs = List.map upgrade rs0 - val m = Manifest.replace_requires m rs - in putPkgManifest m - ; (if rs = rs0 then println ("Nothing to upgrade.") - else println ("Remember to run '" ^ - OS.Path.file(CommandLine.name()) ^ " sync'.")) + [] => + let + fun upgrade (req: required) : required = + let + val v = PkgInfo.lookupNewestRev (#1 req) + val h = PkgInfo.pkgRevCommit (PkgInfo.lookupPackageRev (#1 req) v) + in + if v <> (#2 req) then + ( println + ("Upgraded " ^ Manifest.pkgpathToString (#1 req) ^ " " + ^ SemVer.toString (#2 req) ^ " => " ^ SemVer.toString v + ^ ".") + ; (#1 req, v, SOME h) + ) + else + req + end + val m = getPkgManifest () + val rs0 = Manifest.requires m + val rs = List.map upgrade rs0 + val m = Manifest.replace_requires m rs + in + putPkgManifest m; + (if rs = rs0 then + println ("Nothing to upgrade.") + else + println + ("Remember to run '" ^ OS.Path.file (CommandLine.name ()) + ^ " sync'.")) end - | _ => raise Fail "command 'upgrade' expects zero arguments." + | _ => raise Fail "command 'upgrade' expects zero arguments." -fun doVersions args : unit = + fun doVersions args : unit = case args of - [p] => - let val p = pkgpathParse p - val pinfo = PkgInfo.lookupPackage p - val versions = PkgInfo.pkgVersions pinfo - in List.app (println o SemVer.toString) (M.keys versions) + [p] => + let + val p = pkgpathParse p + val pinfo = PkgInfo.lookupPackage p + val versions = PkgInfo.pkgVersions pinfo + in + List.app (println o SemVer.toString) (M.keys versions) end - | _ => raise Fail "command 'versions' expects one argument." + | _ => raise Fail "command 'versions' expects one argument." -fun print_prog_version () = - let val prog = OS.Path.file (CommandLine.name()) + fun print_prog_version () = + let val prog = OS.Path.file (CommandLine.name ()) in println (prog ^ " " ^ Version.version ^ " (" ^ Version.gitversion ^ ")") end -fun eatFlags args = + fun eatFlags args = case args of - arg :: args' => if arg = "-v" orelse arg = "--verbose" - then (PkgInfo.verboseFlag := true; eatFlags args') - else if arg = "-V" orelse arg = "--version" - then (print_prog_version(); OS.Process.exit OS.Process.success) - else args - | nil => args - -fun main (pkg_filename:string) : unit = - let val () = Manifest.set_smlpkg_filename pkg_filename - val smlpkg = smlpkg_filename () - val commands = [ ("add", - (doAdd, "Add another required package to " ^ smlpkg ^ ".")) - , ("check", - (doCheck, "Check that " ^ smlpkg ^ " is satisfiable.")) - , ("init", - (doInit, "Create a new " ^ smlpkg ^ " and a lib/ skeleton.")) - , ("fmt", - (doFmt, "Reformat " ^ smlpkg ^ ".")) - , ("sync", - (doSync, "Populate lib/ as specified by " ^ smlpkg ^ ".")) - , ("remove", - (doRemove, "Remove a required package from " ^ smlpkg ^ ".")) - , ("upgrade", - (doUpgrade, "Upgrade all packages to newest versions.")) - , ("versions", - (doVersions, "List available versions for a package.")) - ] - - fun look s l = - Option.map #2 (List.find (fn (k,v) => s=k) l) - - fun doUsage () = - let val k = List.foldl Int.max 0 (map (size o #1) commands) + 3 - val msg = String.concatWith "\n" - ([" ...:", "", "Commands:"] @ - map (fn (cmd,(_,desc)) => - " " ^ - StringCvt.padRight #" " k cmd ^ - desc) - commands) - in usageMsg msg - end + arg :: args' => + if arg = "-v" orelse arg = "--verbose" then + (PkgInfo.verboseFlag := true; eatFlags args') + else if arg = "-V" orelse arg = "--version" then + (print_prog_version (); OS.Process.exit OS.Process.success) + else + args + | nil => args + + fun main (pkg_filename: string) : unit = + let + val () = Manifest.set_smlpkg_filename pkg_filename + val smlpkg = smlpkg_filename () + val commands = + [ ("add", (doAdd, "Add another required package to " ^ smlpkg ^ ".")) + , ("check", (doCheck, "Check that " ^ smlpkg ^ " is satisfiable.")) + , ("init", (doInit, "Create a new " ^ smlpkg ^ " and a lib/ skeleton.")) + , ("fmt", (doFmt, "Reformat " ^ smlpkg ^ ".")) + , ("sync", (doSync, "Populate lib/ as specified by " ^ smlpkg ^ ".")) + , ( "remove" + , (doRemove, "Remove a required package from " ^ smlpkg ^ ".") + ) + , ("upgrade", (doUpgrade, "Upgrade all packages to newest versions.")) + , ("versions", (doVersions, "List available versions for a package.")) + ] + + fun look s l = + Option.map #2 (List.find (fn (k, v) => s = k) l) + + fun doUsage () = + let + val k = List.foldl Int.max 0 (map (size o #1) commands) + 3 + val msg = String.concatWith "\n" + ([" ...:", "", "Commands:"] + @ + map + (fn (cmd, (_, desc)) => + " " ^ StringCvt.padRight #" " k cmd ^ desc) commands) + in + usageMsg msg + end - fun simpleUsage () = - usageMsg ("options... <" ^ - String.concatWith "|" (map #1 commands) - ^ ">") + fun simpleUsage () = + usageMsg + ("options... <" ^ String.concatWith "|" (map #1 commands) ^ ">") in - case eatFlags (CommandLine.arguments()) of - [] => doUsage() + ( case eatFlags (CommandLine.arguments ()) of + [] => doUsage () | cmd :: args => - case look cmd commands of - SOME (doCmd,doc) => - (doCmd args - handle Fail s => (println ("Error: " ^ s); - simpleUsage())) - | NONE => doUsage() + case look cmd commands of + SOME (doCmd, doc) => + (doCmd args + handle Fail s => + ( println ("Error: " ^ s) + ; PkgInfo.cleanupCache () + ; simpleUsage () + )) + | NONE => doUsage () + ; PkgInfo.cleanupCache () + ) + handle e => (PkgInfo.cleanupCache (); raise e) end end diff --git a/src/pkginfo.sig b/src/pkginfo.sig index c456574..35ada66 100644 --- a/src/pkginfo.sig +++ b/src/pkginfo.sig @@ -4,8 +4,8 @@ signature PKG_INFO = sig type semver = SemVer.t type pkg_revinfo - val pkgRevZipballUrl : pkg_revinfo -> string - val pkgRevZipballDir : pkg_revinfo -> string + val pkgRevRepoUrl : pkg_revinfo -> string + val pkgRevRef : pkg_revinfo -> string val pkgRevCommit : pkg_revinfo -> string val pkgRevGetManifest : pkg_revinfo -> Manifest.t (* cached access *) val pkgRevTime : pkg_revinfo -> Time.time @@ -20,5 +20,9 @@ signature PKG_INFO = sig val lookupPackageRev : pkgpath -> semver -> pkg_revinfo val lookupNewestRev : pkgpath -> semver + (* Cache management *) + val getCachedRepo : string -> string (* Get cached repository for URL *) + val cleanupCache : unit -> unit (* Clean up temporary cache directory *) + val verboseFlag : bool ref end diff --git a/src/pkginfo.sml b/src/pkginfo.sml index bf4fe6c..b457d6e 100644 --- a/src/pkginfo.sml +++ b/src/pkginfo.sml @@ -3,170 +3,240 @@ struct structure M = FinMapEq - fun println s = print (s ^ "\n") + fun println s = + print (s ^ "\n") val verboseFlag = ref false - fun log s = if !verboseFlag then println ("[" ^ s ^ "]") else () + fun log s = + if !verboseFlag then println ("[" ^ s ^ "]") else () type pkgpath = Manifest.pkgpath type semver = SemVer.t type pkg_revinfo = - {pkgRevZipballUrl : string, - pkgRevZipballDir : string, (* the directory inside zipball containing the 'lib' dir *) - pkgRevCommit : string, (* commit id for verification *) - pkgRevGetManifest : unit -> Manifest.t, - pkgRevTime : Time.time} + { pkgRevRepoUrl: string + , (* git repository URL *) pkgRevRef: string + , (* git ref (tag or commit) *) pkgRevCommit: string + , (* commit id for verification *) pkgRevGetManifest: unit -> Manifest.t + , pkgRevTime: Time.time + } - fun pkgRevZipballUrl (r:pkg_revinfo) : string = #pkgRevZipballUrl r - fun pkgRevZipballDir (r:pkg_revinfo) : string = #pkgRevZipballDir r - fun pkgRevCommit (r:pkg_revinfo) : string = #pkgRevCommit r - fun pkgRevGetManifest (r:pkg_revinfo) : Manifest.t = #pkgRevGetManifest r () - fun pkgRevTime (r:pkg_revinfo) : Time.time = #pkgRevTime r + fun pkgRevRepoUrl (r: pkg_revinfo) : string = #pkgRevRepoUrl r + fun pkgRevRef (r: pkg_revinfo) : string = #pkgRevRef r + fun pkgRevCommit (r: pkg_revinfo) : string = #pkgRevCommit r + fun pkgRevGetManifest (r: pkg_revinfo) : Manifest.t = #pkgRevGetManifest r () + fun pkgRevTime (r: pkg_revinfo) : Time.time = #pkgRevTime r - type pkg_info = {pkgVersions: (semver,pkg_revinfo)M.t, - pkgLookupCommit: string option -> pkg_revinfo} + type pkg_info = + { pkgVersions: (semver, pkg_revinfo) M.t + , pkgLookupCommit: string option -> pkg_revinfo + } - fun pkgVersions (pinfo:pkg_info) : (semver,pkg_revinfo) M.t = - #pkgVersions pinfo + fun pkgVersions (pinfo: pkg_info) : (semver, pkg_revinfo) M.t = + #pkgVersions pinfo - fun lookupPkgRev (v:semver) (pi:pkg_info) : pkg_revinfo option = - M.lookup (pkgVersions pi) v + fun lookupPkgRev (v: semver) (pi: pkg_info) : pkg_revinfo option = + M.lookup (pkgVersions pi) v fun majorRevOfPkg (p: pkgpath) : pkgpath * int list = - let fun mk r = {host= #host p, owner= #owner p, repo= r} - in case String.fields (fn c => c = #"@") (#repo p) of - [r,v] => (case Int.fromString v of - SOME i => if Int.toString i = v then (mk r,[i]) - else raise Fail "majorRevOfPkg: expecting integer" - | NONE => (mk r,[0,1])) - | _ => (p,[0,1]) - end + let + fun mk r = {host = #host p, owner = #owner p, repo = r} + in + case String.fields (fn c => c = #"@") (#repo p) of + [r, v] => + (case Int.fromString v of + SOME i => + if Int.toString i = v then (mk r, [i]) + else raise Fail "majorRevOfPkg: expecting integer" + | NONE => (mk r, [0, 1])) + | _ => (p, [0, 1]) + end (* Utilities *) - fun httpRequest (url:string) : string = - let val cmd = "curl -L " ^ url - val (status,out,err) = System.command cmd - in if OS.Process.isSuccess status then out - else (TextIO.output(TextIO.stdErr,err); - raise Fail ("Failed to execute http request using curl: '" ^ cmd ^ "'")) - end + fun gitCmd (opts: string list) : string = (* may raise Fail and print errors on stderr *) + let + val cmd = String.concatWith " " ("git" :: opts) + (* + val () = (* Avoid Git asking for credentials. We prefer failure. *) + setEnv "GIT_TERMINAL_PROMPT" "0" + *) + val (status, out, err) = System.command cmd + in + if OS.Process.isSuccess status then + out + else + ( TextIO.output (TextIO.stdErr, err) + ; raise Fail ("Failed to execute git command '" ^ cmd ^ "'") + ) + end - fun gitCmd (opts : string list) : string = (* may raise Fail and print errors on stderr *) - let val cmd = String.concatWith " " ("git"::opts) -(* - val () = (* Avoid Git asking for credentials. We prefer failure. *) - setEnv "GIT_TERMINAL_PROMPT" "0" -*) - val (status,out,err) = System.command cmd - in if OS.Process.isSuccess status then out - else (TextIO.output(TextIO.stdErr,err); - raise Fail ("Failed to execute git command '" ^ cmd ^ "'")) - end + (* Shared temporary directory for all repository clones during this execution *) + val cacheDir: string option ref = ref NONE - (* The GitLab and GitHub interactions are very similar, so we define a - couple of generic functions that are used to implement support for - both. *) - - fun ghglRevGetManifest (url:string) (owner:string) (repo:string) (tag:string) : Manifest.t = - let val () = log ("downloading package manifest from " ^ url) - val path = owner ^ "/" ^ repo ^ "@" ^ tag ^ "/" ^ Manifest.smlpkg_filename() - val s = httpRequest url - handle Fail e => - raise Fail ("Network error when reading " ^ path ^ ":\n" ^ e) - in Manifest.fromString path s - end + fun getCacheDir () : string = + case !cacheDir of + SOME dir => dir + | NONE => + let + val dir = OS.FileSys.tmpName () ^ "-smlpkg-cache" + val () = if System.doesDirExist dir then () else OS.FileSys.mkDir dir + val () = log ("created cache directory " ^ dir) + val () = cacheDir := SOME dir + in + dir + end + + (* Convert repository URL to a safe directory name *) + fun repoUrlToDir (repo_url: string) : string = + let + fun sanitize #"/" = #"-" + | sanitize #":" = #"-" + | sanitize #"@" = #"-" + | sanitize #"." = #"-" + | sanitize c = c + in + String.map sanitize repo_url + end + + (* Clone a git repository to the cache directory and return the path. + If the repository already exists in the cache, reuse it. *) + fun cloneRepo (repo_url: string) : string = + let + infix + val op = System. + val cache_dir = getCacheDir () + val repo_name = repoUrlToDir repo_url + val repo_dir = cache_dir repo_name + in + if System.doesDirExist repo_dir then + (log ("reusing cached repository " ^ repo_dir); repo_dir) + else + ( log ("cloning repository " ^ repo_url ^ " to " ^ repo_dir) + ; let + val cmd = + "git clone --bare " ^ System.shellEscape repo_url ^ " " + ^ System.shellEscape repo_dir + val (status, out, err) = System.command cmd + val () = + if OS.Process.isSuccess status then () + else raise Fail ("Failed to clone " ^ repo_url ^ ": " ^ err) + in + repo_dir + end + ) + end + + (* Get the manifest from a git repository at a specific ref *) + fun getManifestFromRepo (repo_dir: string) (refe: string) : Manifest.t = + let + val () = log ("reading manifest from " ^ repo_dir ^ " at " ^ refe) + val manifest_file = Manifest.smlpkg_filename () + val cmd = + "git " ^ "--git-dir=" ^ System.shellEscape repo_dir ^ " show " + ^ System.shellEscape (refe ^ ":" ^ manifest_file) + val (status, out, err) = System.command cmd + val () = + if OS.Process.isSuccess status then + () + else + raise Fail + ("Failed to read " ^ manifest_file ^ " at " ^ refe ^ ": " ^ err) + val path = repo_dir ^ "/" ^ refe ^ "/" ^ manifest_file + in + Manifest.fromString path out + end + (* Manifest cache to avoid reading the same manifest multiple times *) val cache = - let val m : (string * Manifest.t) list ref = ref nil - in fn f => fn a => fn b => fn c => fn d => fn () => - let val s = String.concatWith "/" [a,b,c,d] - in case List.find (fn (k,_) => k=s) (!m) of - SOME (_,v) => v - | NONE => let val v = f a b c d - in m := (s,v) :: !m - ; v - end - end - end + let + val m: (string * Manifest.t) list ref = ref nil + in + fn f => + fn repo_dir => + fn refe => + fn () => + let + val s = repo_dir ^ "@" ^ refe + in + case List.find (fn (k, _) => k = s) (!m) of + SOME (_, v) => v + | NONE => + let val v = f repo_dir refe + in m := (s, v) :: !m; v + end + end + end - fun ghglLookupCommit (archive_url:string) (manifest_url:string) - (owner:string) (repo:string) (d:string) - (tag:string) (hash:string) (version_prefix:string) - : pkg_revinfo = - let val mc = cache ghglRevGetManifest manifest_url owner repo tag - val dir = repo ^ "-" ^ version_prefix ^ d - val time = Time.now() - val () = log ("zip url: " ^ archive_url) - val () = log ("zip dir: " ^ dir) - in {pkgRevZipballUrl=archive_url, - pkgRevZipballDir=dir, - pkgRevCommit=hash, - pkgRevGetManifest=mc, - pkgRevTime=time} - end + (* Create a pkg_revinfo for a specific git ref *) + fun mkRevInfo (repo_url: string) (repo_dir: string) (refe: string) + (hash: string) : pkg_revinfo = + let + val mc = cache getManifestFromRepo repo_dir refe + val time = Time.now () + val () = log ("rev info: " ^ repo_url ^ " @ " ^ refe ^ " (" ^ hash ^ ")") + in + { pkgRevRepoUrl = repo_url + , pkgRevRef = refe + , pkgRevCommit = hash + , pkgRevGetManifest = mc + , pkgRevTime = time + } + end - fun ghglPkgInfo (repo_url:string) mk_archive_url mk_manifest_url - (owner:string) (repo:string) (versions:int list) - (version_prefix:string) : pkg_info = - let val () = log ("retrieving list of tags from " ^ repo_url) - val remote_lines = gitCmd ["ls-remote", repo_url] - val remote_lines = String.tokens (fn c => c = #"\n") remote_lines - fun isHeadRef (l:string) : string option = - case String.tokens Char.isSpace l of - [hash,"HEAD"] => SOME hash - | _ => NONE - fun revInfo l : (semver * pkg_revinfo) option = - case String.tokens Char.isSpace l of - [hash,refe] => - (case String.fields (fn s => s = #"/") refe of - ["refs", "tags", t] => - if String.isPrefix "v" t then - (case SemVer.fromString(String.extract(t,1,NONE)) of - SOME v => - let val m = SemVer.major v - in if List.exists (fn i => i=m) versions then - let val pinfo = ghglLookupCommit (mk_archive_url t) (mk_manifest_url t) - owner repo (SemVer.toString v) t hash version_prefix - in SOME (v,pinfo) - end - else NONE - end - | NONE => NONE) - else NONE - | _ => NONE) - | _ => NONE - in case List.mapPartial isHeadRef remote_lines of - head_ref :: _ => - let fun def (opt:string option) : string = Option.getOpt(opt,head_ref) - val rev_info = M.fromList_eq (List.mapPartial revInfo remote_lines) - fun lookupCommit (r:string option) = - ghglLookupCommit (mk_archive_url (def r)) (mk_manifest_url (def r)) - owner repo (def r) (def r) (def r) version_prefix - in {pkgVersions=rev_info, - pkgLookupCommit=lookupCommit} - end - | _ => raise Fail ("Cannot find HEAD ref for " ^ repo_url) - end + (* Get package info from a git repository *) + fun gitPkgInfo (repo_url: string) (versions: int list) : pkg_info = + let + val () = log ("retrieving list of tags from " ^ repo_url) + (* Escape the repository URL before passing it to shell-based helpers *) + val safe_repo_url = System.shellEscape repo_url + val remote_lines = gitCmd ["ls-remote", safe_repo_url] + val remote_lines = String.tokens (fn c => c = #"\n") remote_lines - fun ghPkgInfo (owner:string) (repo:string) (versions:int list) : pkg_info = - let val repo_url = "https://github.com/" ^ owner ^ "/" ^ repo - fun mk_archive_url r = repo_url ^ "/archive/" ^ r ^ ".zip" - fun mk_manifest_url r = "https://raw.githubusercontent.com/" ^ - owner ^ "/" ^ repo ^ "/" ^ - r ^ "/" ^ Manifest.smlpkg_filename() - in ghglPkgInfo repo_url mk_archive_url mk_manifest_url owner repo versions "" - end + (* Clone the repository once for reading manifests *) + val repo_dir = cloneRepo repo_url - fun glPkgInfo (owner:string) (repo:string) (versions:int list) : pkg_info = - let val base_url = "https://gitlab.com/" ^ owner ^ "/" ^ repo - val repo_url = base_url ^ ".git" - fun mk_archive_url r = base_url ^ "/-/archive/" ^ r ^ - "/" ^ repo ^ "-" ^ r ^ ".zip" - fun mk_manifest_url r = base_url ^ "/raw/" ^ - r ^ "/" ^ Manifest.smlpkg_filename() - in ghglPkgInfo repo_url mk_archive_url mk_manifest_url owner repo versions "v" - end + fun isHeadRef (l: string) : string option = + case String.tokens Char.isSpace l of + [hash, "HEAD"] => SOME hash + | _ => NONE + + fun revInfo l : (semver * pkg_revinfo) option = + case String.tokens Char.isSpace l of + [hash, refe] => + (case String.fields (fn s => s = #"/") refe of + ["refs", "tags", t] => + if String.isPrefix "v" t then + (case SemVer.fromString (String.extract (t, 1, NONE)) of + SOME v => + let + val m = SemVer.major v + in + if List.exists (fn i => i = m) versions then + let val pinfo = mkRevInfo repo_url repo_dir t hash + in SOME (v, pinfo) + end + else + NONE + end + | NONE => NONE) + else + NONE + | _ => NONE) + | _ => NONE + in + case List.mapPartial isHeadRef remote_lines of + head_ref :: _ => + let + fun def (opt: string option) : string = + Option.getOpt (opt, head_ref) + val rev_info = M.fromList_eq (List.mapPartial revInfo remote_lines) + fun lookupCommit (r: string option) = + mkRevInfo repo_url repo_dir (def r) (def r) + in + {pkgVersions = rev_info, pkgLookupCommit = lookupCommit} + end + | _ => raise Fail ("Cannot find HEAD ref for " ^ repo_url) + end (* Retrieve information about a package based on its package path. This uses Semantic Import Versioning when interacting with @@ -175,89 +245,130 @@ struct @github.com/user/repo/v2@ will match 2.* tags, and so forth.. *) + (* Construct repository URL from package path *) + fun pkgpathToRepoUrl (p: pkgpath) : string = + let + val (p', _) = majorRevOfPkg p + val base = "https://" ^ #host p ^ "/" ^ #owner p ^ "/" ^ #repo p' + in + case #host p of + "gitlab.com" => base ^ ".git" + | _ => base (* Works for github.com and most other git hosts *) + end + (* Raw access - limited caching *) - fun pkgInfo (p:pkgpath) : pkg_info = - case #host p of - "github.com" => - let val (p',vs) = majorRevOfPkg p - in ghPkgInfo (#owner p) (#repo p') vs - end - | "gitlab.com" => - let val (p',vs) = majorRevOfPkg p - in glPkgInfo (#owner p) (#repo p') vs - end - | _ => raise Fail ("only github.com or gitlab.com\ - \ are supported as hosts.") + fun pkgInfo (p: pkgpath) : pkg_info = + let + val repo_url = pkgpathToRepoUrl p + val (_, vs) = majorRevOfPkg p + in + gitPkgInfo repo_url vs + end (* Cached access *) - local - val registry : (pkgpath,pkg_info)M.t ref = ref (M.empty_eq()) + local val registry: (pkgpath, pkg_info) M.t ref = ref (M.empty_eq ()) in - fun lookupPackage (p:pkgpath) : pkg_info = - case M.lookup (!registry) p of - SOME i => i - | NONE => let val i = pkgInfo p - in registry := M.add (p,i) (!registry) - ; i - end + fun lookupPackage (p: pkgpath) : pkg_info = + case M.lookup (!registry) p of + SOME i => i + | NONE => + let val i = pkgInfo p + in registry := M.add (p, i) (!registry); i + end - fun lookupPackageCommit (p:pkgpath) (refe:string option) : semver * pkg_revinfo = - let val pinfo = lookupPackage p - val rev_info = #pkgLookupCommit pinfo refe - val timestamp = Date.fmt "%Y%m%d%H%M%S" (Date.fromTimeLocal(pkgRevTime rev_info)) - val v = case Manifest.commitVersion timestamp (pkgRevCommit rev_info) of - NONE => raise Fail "impossible: failed to form valid commit version" - | SOME v => v - val pinfo' = {pkgLookupCommit = #pkgLookupCommit pinfo, - pkgVersions = M.add (v,rev_info) (pkgVersions pinfo)} - val () = registry := M.add (p,pinfo') (!registry) - in (v, rev_info) - end + fun lookupPackageCommit (p: pkgpath) (refe: string option) : + semver * pkg_revinfo = + let + val pinfo = lookupPackage p + val rev_info = #pkgLookupCommit pinfo refe + val timestamp = Date.fmt "%Y%m%d%H%M%S" + (Date.fromTimeLocal (pkgRevTime rev_info)) + val v = + case Manifest.commitVersion timestamp (pkgRevCommit rev_info) of + NONE => raise Fail "impossible: failed to form valid commit version" + | SOME v => v + val pinfo' = + { pkgLookupCommit = #pkgLookupCommit pinfo + , pkgVersions = M.add (v, rev_info) (pkgVersions pinfo) + } + val () = registry := M.add (p, pinfo') (!registry) + in + (v, rev_info) + end (* Look up information about a specific version of a package. *) - fun lookupPackageRev (p:pkgpath) (v:semver) : pkg_revinfo = - case Manifest.isCommitVersion v of - SOME commit => #2 (lookupPackageCommit p (SOME commit)) - | NONE => - let val pinfo = lookupPackage p - in case lookupPkgRev v pinfo of - NONE => - let val versions = - case M.keys (pkgVersions pinfo) of - [] => ("Package " ^ Manifest.pkgpathToString p ^ - " has no versions. Invalid package path?") - | ks => ("Known versions: " ^ - String.concatWith ", " (map SemVer.toString ks)) - val (_, vs) = majorRevOfPkg p - val major = - if List.exists (fn x => x = SemVer.major v) vs then "" - else ("\nFor major version " ^ Int.toString (SemVer.major v) ^ - ", use package path " ^ Manifest.pkgpathToString p - ^ "@" ^ Int.toString (SemVer.major v)) - in raise Fail ("package " ^ Manifest.pkgpathToString p ^ - " does not have a version " ^ SemVer.toString v ^ - ".\n" ^ versions ^ major) - end - | SOME v' => v' - end + fun lookupPackageRev (p: pkgpath) (v: semver) : pkg_revinfo = + case Manifest.isCommitVersion v of + SOME commit => #2 (lookupPackageCommit p (SOME commit)) + | NONE => + let + val pinfo = lookupPackage p + in + case lookupPkgRev v pinfo of + NONE => + let + val versions = + case M.keys (pkgVersions pinfo) of + [] => + ("Package " ^ Manifest.pkgpathToString p + ^ " has no versions. Invalid package path?") + | ks => + ("Known versions: " + ^ String.concatWith ", " (map SemVer.toString ks)) + val (_, vs) = majorRevOfPkg p + val major = + if List.exists (fn x => x = SemVer.major v) vs then + "" + else + ("\nFor major version " ^ Int.toString (SemVer.major v) + ^ ", use package path " ^ Manifest.pkgpathToString p + ^ "@" ^ Int.toString (SemVer.major v)) + in + raise Fail + ("package " ^ Manifest.pkgpathToString p + ^ " does not have a version " ^ SemVer.toString v ^ ".\n" + ^ versions ^ major) + end + | SOME v' => v' + end (* Find the newest version of a package. *) - fun lookupNewestRev (p:pkgpath) : semver = - let val pinfo = lookupPackage p - in case M.keys (pkgVersions pinfo) of - [] => - ( log ("package " ^ Manifest.pkgpathToString p ^ - " has no released versions. Using HEAD.") - ; #1 (lookupPackageCommit p NONE)) - | v::vs => - let fun max (v1,v2) = if SemVer.< (v1,v2) then v2 else v1 - in log "finding newest version of packages" - ; List.foldl max v vs (* memo: what about versions of - * equal priority - should we use - * foldr? *) - end - end + fun lookupNewestRev (p: pkgpath) : semver = + let + val pinfo = lookupPackage p + in + case M.keys (pkgVersions pinfo) of + [] => + ( log + ("package " ^ Manifest.pkgpathToString p + ^ " has no released versions. Using HEAD.") + ; #1 (lookupPackageCommit p NONE) + ) + | v :: vs => + let + fun max (v1, v2) = + if SemVer.< (v1, v2) then v2 else v1 + in + log "finding newest version of packages"; + List.foldl max v + vs (* memo: what about versions of + * equal priority - should we use + * foldr? *) + end + end end + + (* Cache management functions *) + fun getCachedRepo (repo_url: string) : string = cloneRepo repo_url + + fun cleanupCache () : unit = + case !cacheDir of + NONE => () + | SOME dir => + ( log ("cleaning up cache directory " ^ dir) + ; System.removePathForcibly dir + ; cacheDir := NONE + ) end diff --git a/src/util/Makefile b/src/util/Makefile index 9a99426..6a36958 100644 --- a/src/util/Makefile +++ b/src/util/Makefile @@ -3,13 +3,8 @@ MLCOMP ?= mlkit .PHONY: test test: $(MLCOMP) -output test.exe test.mlb - $(MAKE) smallclean ./test.exe -.PHONY: smallclean -smallclean: - rm -rf test_zip/lib test_zip/lib_tmp~ - .PHONY: clean -clean: smallclean +clean: rm -rf *~ MLB run *.exe diff --git a/src/util/system.sig b/src/util/system.sig index ef0230c..186b37d 100644 --- a/src/util/system.sig +++ b/src/util/system.sig @@ -12,6 +12,7 @@ signature SYSTEM = sig val writeFileBin : filepath -> Word8Vector.vector -> unit val command : string -> OS.Process.status * string * string + val shellEscape : string -> string val splitPath : path -> string list val createDirectoryIfMissing : bool -> dirpath -> unit diff --git a/src/util/system.sml b/src/util/system.sml index 15d6d91..a4aa1f7 100644 --- a/src/util/system.sml +++ b/src/util/system.sml @@ -37,6 +37,11 @@ fun writeFileBin (f:filepath) (s: Word8Vector.vector) : unit = end (* Command execution *) + +(* Escape a string for safe use in shell commands *) +fun shellEscape (s: string) : string = + "'" ^ String.translate (fn #"'" => "'\"'\"'" | c => String.str c) s ^ "'" + fun command (cmd: string) : P.status * string * string = let val stdoutFile = FS.tmpName() val stderrFile = FS.tmpName() diff --git a/src/util/test.mlb b/src/util/test.mlb index bf9fb4d..d671024 100644 --- a/src/util/test.mlb +++ b/src/util/test.mlb @@ -2,5 +2,4 @@ local $(SML_LIB)/basis/basis.mlb util.mlb in test.sml test_system.sml - test_zip.mlb end diff --git a/src/util/test_zip.mlb b/src/util/test_zip.mlb deleted file mode 100644 index 1433a8e..0000000 --- a/src/util/test_zip.mlb +++ /dev/null @@ -1,4 +0,0 @@ -local $(SML_LIB)/basis/basis.mlb - util.mlb -in test_zip.sml -end diff --git a/src/util/test_zip.sml b/src/util/test_zip.sml deleted file mode 100644 index 421d7eb..0000000 --- a/src/util/test_zip.sml +++ /dev/null @@ -1,14 +0,0 @@ - -fun println s = print (s ^ "\n") -val () = println "Testing Zip" - -fun test s f = - (if f() then println ("OK : " ^ s) - else println ("ERR: " ^ s)) - handle Fail e => println ("EXN: " ^ s ^ " raised Fail \"" ^ e ^ "\"") - -val zipfile = "test_zip/v0.1.0.zip" - -val z = Zip.fromFile zipfile - -val () = Zip.extractSubDir {log=println} z {path="segmented-0.1.0/lib", target="test_zip/lib"} diff --git a/src/util/test_zip/.gitignore b/src/util/test_zip/.gitignore deleted file mode 100644 index 7951405..0000000 --- a/src/util/test_zip/.gitignore +++ /dev/null @@ -1 +0,0 @@ -lib \ No newline at end of file diff --git a/src/util/test_zip/v0.1.0.zip b/src/util/test_zip/v0.1.0.zip deleted file mode 100644 index b6493fe..0000000 Binary files a/src/util/test_zip/v0.1.0.zip and /dev/null differ diff --git a/src/util/util.mlb b/src/util/util.mlb index 0cf1f6b..f4df3cf 100644 --- a/src/util/util.mlb +++ b/src/util/util.mlb @@ -3,5 +3,4 @@ in finmapeq.sig finmapeq.sml system.sig system.sml - zip.sml end diff --git a/src/util/zip.sml b/src/util/zip.sml deleted file mode 100644 index 2a54b42..0000000 --- a/src/util/zip.sml +++ /dev/null @@ -1,70 +0,0 @@ -signature ZIP = sig - type t (* type of archive *) - val fromFile : string -> t - val download : string -> t - val extractSubDir : {log:string->unit} -> t -> {path:string,target:string} -> unit - val delete : t -> unit -end - -structure Zip :> ZIP = struct - -type t = {zipfile:string,deleted:bool ref} - -fun fromFile (s:string) : t = - {zipfile=s,deleted=ref false} - -fun download (url:string) : t = - let val localzip = OS.FileSys.tmpName() - val (status,out,err) = System.command ("curl -L -o " ^ localzip ^ " " ^ url) - in if OS.Process.isSuccess status then - {zipfile=localzip,deleted=ref false} - else raise Fail ("failed to download " ^ url ^ ": " ^ err) - end - -fun delete ({zipfile,deleted}:t) : unit = - if !deleted then () - else ( OS.FileSys.remove zipfile - ; deleted := true ) - handle _ => raise Fail ("failed to delete " ^ zipfile) - -fun extractSubDir {log: string -> unit} ({zipfile,deleted}:t) {path:string,target:string} : unit = - if !deleted then raise Fail ("extractSubDir: " ^ zipfile ^ - " has been deleted.") - else - (* memo: check that zipfile does not contain absolute paths, that path is - not absolute and that no paths involve '..' *) - let val () = log ("creating directory " ^ target) - val () = System.createDirectoryIfMissing true target - fun cmds zipfile path target : {zipcmd:string,mvcmd:string,tmpdir:string} = - let val tmpdir = target ^ "_tmp~" - in {zipcmd = "unzip " ^ zipfile ^ " '" ^ path ^ "/**' -d " ^ tmpdir, - mvcmd = "mv " ^ tmpdir ^ "/" ^ path ^ "/* " ^ target ^ "/", - tmpdir = tmpdir} - end - val {zipcmd, mvcmd, tmpdir} = cmds zipfile path target - (* execute commands *) - - val () = log ("removing " ^ tmpdir) - val () = System.removePathForcibly tmpdir - - val () = log ("cmd: " ^ zipcmd) - val (status,out,err) = System.command zipcmd - - val () = log ("removing " ^ zipfile) - val () = System.removePathForcibly zipfile - - val () = if OS.Process.isSuccess status then () - else raise Fail ("failed to extract " ^ zipfile ^ ": " ^ err) - - val () = log ("cmd: " ^ mvcmd) - val (status,out,err) = System.command mvcmd - - val () = log ("removing " ^ tmpdir) - val () = System.removePathForcibly tmpdir - - val () = if OS.Process.isSuccess status then () - else raise Fail ("failed to move tmpdir into target: " ^ err) - in () - end - -end