Mercurial > hg > sonic-annotator
comparison vext.sml @ 317:c3a3edc6c2f0
Update Vext
author | Chris Cannam |
---|---|
date | Tue, 02 Jan 2018 10:56:52 +0000 |
parents | 9ebb9ac79bdf |
children |
comparison
equal
deleted
inserted
replaced
316:3cd337892a16 | 317:c3a3edc6c2f0 |
---|---|
36 shall not be used in advertising or otherwise to promote the sale, | 36 shall not be used in advertising or otherwise to promote the sale, |
37 use or other dealings in this Software without prior written | 37 use or other dealings in this Software without prior written |
38 authorization. | 38 authorization. |
39 *) | 39 *) |
40 | 40 |
41 val vext_version = "0.9.8" | 41 val vext_version = "0.9.92" |
42 | 42 |
43 | 43 |
44 datatype vcs = | 44 datatype vcs = |
45 HG | | 45 HG | |
46 GIT | 46 GIT | |
47 SVN | |
47 | 48 |
48 datatype source = | 49 datatype source = |
49 URL_SOURCE of string | | 50 URL_SOURCE of string | |
50 SERVICE_SOURCE of { | 51 SERVICE_SOURCE of { |
51 service : string, | 52 service : string, |
156 | 157 |
157 (** Test whether the library is at the newest revision for the | 158 (** Test whether the library is at the newest revision for the |
158 given branch. False may indicate that the branch has advanced | 159 given branch. False may indicate that the branch has advanced |
159 or that the library is not on the branch at all. This function | 160 or that the library is not on the branch at all. This function |
160 may use the network to check for new revisions *) | 161 may use the network to check for new revisions *) |
161 val is_newest : context -> libname * branch -> bool result | 162 val is_newest : context -> libname * source * branch -> bool result |
162 | 163 |
163 (** Test whether the library is at the newest revision available | 164 (** Test whether the library is at the newest revision available |
164 locally for the given branch. False may indicate that the | 165 locally for the given branch. False may indicate that the |
165 branch has advanced or that the library is not on the branch | 166 branch has advanced or that the library is not on the branch |
166 at all. This function must not use the network *) | 167 at all. This function must not use the network *) |
172 | 173 |
173 (** Check out, i.e. clone a fresh copy of, the repo for the given | 174 (** Check out, i.e. clone a fresh copy of, the repo for the given |
174 library on the given branch *) | 175 library on the given branch *) |
175 val checkout : context -> libname * source * branch -> unit result | 176 val checkout : context -> libname * source * branch -> unit result |
176 | 177 |
177 (** Update the library to the given branch tip *) | 178 (** Update the library to the given branch tip. Assumes that a |
178 val update : context -> libname * branch -> id_or_tag result | 179 local copy of the library already exists *) |
180 val update : context -> libname * source * branch -> unit result | |
179 | 181 |
180 (** Update the library to the given specific id or tag *) | 182 (** Update the library to the given specific id or tag *) |
181 val update_to : context -> libname * id_or_tag -> id_or_tag result | 183 val update_to : context -> libname * source * id_or_tag -> unit result |
184 | |
185 (** Return a URL from which the library can be cloned, given that | |
186 the local copy already exists. For a DVCS this can be the | |
187 local copy, but for a centralised VCS it will have to be the | |
188 remote repository URL. Used for archiving *) | |
189 val copy_url_for : context -> libname -> string result | |
182 end | 190 end |
183 | 191 |
184 signature LIB_CONTROL = sig | 192 signature LIB_CONTROL = sig |
185 val review : context -> libspec -> (libstate * localstate) result | 193 val review : context -> libspec -> (libstate * localstate) result |
186 val status : context -> libspec -> (libstate * localstate) result | 194 val status : context -> libspec -> (libstate * localstate) result |
187 val update : context -> libspec -> id_or_tag result | 195 val update : context -> libspec -> unit result |
188 val id_of : context -> libspec -> id_or_tag result | 196 val id_of : context -> libspec -> id_or_tag result |
189 end | 197 end |
190 | 198 |
191 structure FileBits :> sig | 199 structure FileBits :> sig |
192 val extpath : context -> string | 200 val extpath : context -> string |
193 val libpath : context -> libname -> string | 201 val libpath : context -> libname -> string |
194 val subpath : context -> libname -> string -> string | 202 val subpath : context -> libname -> string -> string |
195 val command_output : context -> libname -> string list -> string result | 203 val command_output : context -> libname -> string list -> string result |
196 val command : context -> libname -> string list -> unit result | 204 val command : context -> libname -> string list -> unit result |
205 val file_url : string -> string | |
197 val file_contents : string -> string | 206 val file_contents : string -> string |
198 val mydir : unit -> string | 207 val mydir : unit -> string |
199 val homedir : unit -> string | 208 val homedir : unit -> string |
200 val mkpath : string -> unit result | 209 val mkpath : string -> unit result |
201 val rmpath : string -> unit result | 210 val rmpath : string -> unit result |
211 val nonempty_dir_exists : string -> bool | |
202 val project_spec_path : string -> string | 212 val project_spec_path : string -> string |
203 val project_lock_path : string -> string | 213 val project_lock_path : string -> string |
204 val verbose : unit -> bool | 214 val verbose : unit -> bool |
205 end = struct | 215 end = struct |
206 | 216 |
208 case OS.Process.getEnv "VEXT_VERBOSE" of | 218 case OS.Process.getEnv "VEXT_VERBOSE" of |
209 SOME "0" => false | 219 SOME "0" => false |
210 | SOME _ => true | 220 | SOME _ => true |
211 | NONE => false | 221 | NONE => false |
212 | 222 |
223 fun split_relative path desc = | |
224 case OS.Path.fromString path of | |
225 { isAbs = true, ... } => raise Fail (desc ^ " may not be absolute") | |
226 | { arcs, ... } => arcs | |
227 | |
213 fun extpath ({ rootpath, extdir, ... } : context) = | 228 fun extpath ({ rootpath, extdir, ... } : context) = |
214 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath | 229 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath |
215 in OS.Path.toString { | 230 in OS.Path.toString { |
216 isAbs = isAbs, | 231 isAbs = isAbs, |
217 vol = vol, | 232 vol = vol, |
218 arcs = arcs @ [ extdir ] | 233 arcs = arcs @ |
234 split_relative extdir "extdir" | |
219 } | 235 } |
220 end | 236 end |
221 | 237 |
222 fun subpath ({ rootpath, extdir, ... } : context) libname remainder = | 238 fun subpath ({ rootpath, extdir, ... } : context) libname remainder = |
223 (* NB libname is allowed to be a path fragment, e.g. foo/bar *) | 239 (* NB libname is allowed to be a path fragment, e.g. foo/bar *) |
224 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath | 240 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath |
225 val split = String.fields (fn c => c = #"/") | |
226 in OS.Path.toString { | 241 in OS.Path.toString { |
227 isAbs = isAbs, | 242 isAbs = isAbs, |
228 vol = vol, | 243 vol = vol, |
229 arcs = arcs @ [ extdir ] @ split libname @ split remainder | 244 arcs = arcs @ |
245 split_relative extdir "extdir" @ | |
246 split_relative libname "library path" @ | |
247 split_relative remainder "subpath" | |
230 } | 248 } |
231 end | 249 end |
232 | 250 |
233 fun libpath context "" = | 251 fun libpath context "" = |
234 extpath context | 252 extpath context |
250 fun project_lock_path rootpath = | 268 fun project_lock_path rootpath = |
251 project_file_path rootpath (VextFilenames.project_lock_file) | 269 project_file_path rootpath (VextFilenames.project_lock_file) |
252 | 270 |
253 fun trim str = | 271 fun trim str = |
254 hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str) | 272 hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str) |
273 | |
274 fun file_url path = | |
275 let val forward_path = | |
276 String.translate (fn #"\\" => "/" | | |
277 c => Char.toString c) | |
278 (OS.Path.mkCanonical path) | |
279 in | |
280 (* Path is expected to be absolute already, but if it | |
281 starts with a drive letter, we'll need an extra slash *) | |
282 case explode forward_path of | |
283 #"/"::rest => "file:///" ^ implode rest | |
284 | _ => "file:///" ^ forward_path | |
285 end | |
255 | 286 |
256 fun file_contents filename = | 287 fun file_contents filename = |
257 let val stream = TextIO.openIn filename | 288 let val stream = TextIO.openIn filename |
258 fun read_all str acc = | 289 fun read_all str acc = |
259 case TextIO.inputLine str of | 290 case TextIO.inputLine str of |
340 fun command_output context libname cmdlist = | 371 fun command_output context libname cmdlist = |
341 let open OS | 372 let open OS |
342 val tmpFile = FileSys.tmpName () | 373 val tmpFile = FileSys.tmpName () |
343 val result = run_command context libname cmdlist (SOME tmpFile) | 374 val result = run_command context libname cmdlist (SOME tmpFile) |
344 val contents = file_contents tmpFile | 375 val contents = file_contents tmpFile |
376 val _ = if verbose () | |
377 then print ("Output was:\n\"" ^ contents ^ "\"\n") | |
378 else () | |
345 in | 379 in |
346 FileSys.remove tmpFile handle _ => (); | 380 FileSys.remove tmpFile handle _ => (); |
347 case result of | 381 case result of |
348 OK () => OK contents | 382 OK () => OK contents |
349 | ERROR e => ERROR e | 383 | ERROR e => ERROR e |
366 (SOME home, _) => home | 400 (SOME home, _) => home |
367 | (NONE, SOME home) => home | 401 | (NONE, SOME home) => home |
368 | (NONE, NONE) => | 402 | (NONE, NONE) => |
369 raise Fail "Failed to look up home directory from environment" | 403 raise Fail "Failed to look up home directory from environment" |
370 | 404 |
371 fun mkpath path = | 405 fun mkpath' path = |
372 if OS.FileSys.isDir path handle _ => false | 406 if OS.FileSys.isDir path handle _ => false |
373 then OK () | 407 then OK () |
374 else case OS.Path.fromString path of | 408 else case OS.Path.fromString path of |
375 { arcs = nil, ... } => OK () | 409 { arcs = nil, ... } => OK () |
376 | { isAbs = false, ... } => ERROR "mkpath requires absolute path" | 410 | { isAbs = false, ... } => ERROR "mkpath requires absolute path" |
377 | { isAbs, vol, arcs } => | 411 | { isAbs, vol, arcs } => |
378 case mkpath (OS.Path.toString { (* parent *) | 412 case mkpath' (OS.Path.toString { (* parent *) |
379 isAbs = isAbs, | 413 isAbs = isAbs, |
380 vol = vol, | 414 vol = vol, |
381 arcs = rev (tl (rev arcs)) }) of | 415 arcs = rev (tl (rev arcs)) }) of |
382 ERROR e => ERROR e | 416 ERROR e => ERROR e |
383 | OK () => ((OS.FileSys.mkDir path; OK ()) | 417 | OK () => ((OS.FileSys.mkDir path; OK ()) |
384 handle OS.SysErr (e, _) => | 418 handle OS.SysErr (e, _) => |
385 ERROR ("Directory creation failed: " ^ e)) | 419 ERROR ("Directory creation failed: " ^ e)) |
386 | 420 |
387 fun rmpath path = | 421 fun mkpath path = |
422 mkpath' (OS.Path.mkCanonical path) | |
423 | |
424 fun dir_contents dir = | |
388 let open OS | 425 let open OS |
389 fun files_from dirstream = | 426 fun files_from dirstream = |
390 case FileSys.readDir dirstream of | 427 case FileSys.readDir dirstream of |
391 NONE => [] | 428 NONE => [] |
392 | SOME file => | 429 | SOME file => |
393 (* readDir is supposed to filter these, | 430 (* readDir is supposed to filter these, |
394 but let's be extra cautious: *) | 431 but let's be extra cautious: *) |
395 if file = Path.parentArc orelse file = Path.currentArc | 432 if file = Path.parentArc orelse file = Path.currentArc |
396 then files_from dirstream | 433 then files_from dirstream |
397 else file :: files_from dirstream | 434 else file :: files_from dirstream |
398 fun contents dir = | 435 val stream = FileSys.openDir dir |
399 let val stream = FileSys.openDir dir | 436 val files = map (fn f => Path.joinDirFile |
400 val files = map (fn f => Path.joinDirFile | 437 { dir = dir, file = f }) |
401 { dir = dir, file = f }) | 438 (files_from stream) |
402 (files_from stream) | 439 val _ = FileSys.closeDir stream |
403 val _ = FileSys.closeDir stream | 440 in |
404 in files | 441 files |
405 end | 442 end |
443 | |
444 fun rmpath' path = | |
445 let open OS | |
406 fun remove path = | 446 fun remove path = |
407 if FileSys.isLink path (* dangling links bother isDir *) | 447 if FileSys.isLink path (* dangling links bother isDir *) |
408 then FileSys.remove path | 448 then FileSys.remove path |
409 else if FileSys.isDir path | 449 else if FileSys.isDir path |
410 then (app remove (contents path); FileSys.rmDir path) | 450 then (app remove (dir_contents path); FileSys.rmDir path) |
411 else FileSys.remove path | 451 else FileSys.remove path |
412 in | 452 in |
413 (remove path; OK ()) | 453 (remove path; OK ()) |
414 handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e) | 454 handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e) |
415 end | 455 end |
456 | |
457 fun rmpath path = | |
458 rmpath' (OS.Path.mkCanonical path) | |
459 | |
460 fun nonempty_dir_exists path = | |
461 let open OS.FileSys | |
462 in | |
463 (not (isLink path) andalso | |
464 isDir path andalso | |
465 dir_contents path <> []) | |
466 handle _ => false | |
467 end | |
468 | |
416 end | 469 end |
417 | 470 |
418 functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct | 471 functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct |
419 | 472 |
420 (* Valid states for unpinned libraries: | 473 (* Valid states for unpinned libraries: |
441 | 494 |
442 - ABSENT: Repo doesn't exist here at all. | 495 - ABSENT: Repo doesn't exist here at all. |
443 *) | 496 *) |
444 | 497 |
445 fun check with_network context | 498 fun check with_network context |
446 ({ libname, branch, project_pin, lock_pin, ... } : libspec) = | 499 ({ libname, source, branch, |
500 project_pin, lock_pin, ... } : libspec) = | |
447 let fun check_unpinned () = | 501 let fun check_unpinned () = |
448 let val is_newest = if with_network | 502 let val newest = |
449 then V.is_newest | 503 if with_network |
450 else V.is_newest_locally | 504 then V.is_newest context (libname, source, branch) |
505 else V.is_newest_locally context (libname, branch) | |
451 in | 506 in |
452 case is_newest context (libname, branch) of | 507 case newest of |
453 ERROR e => ERROR e | 508 ERROR e => ERROR e |
454 | OK true => OK CORRECT | 509 | OK true => OK CORRECT |
455 | OK false => | 510 | OK false => |
456 case V.is_on_branch context (libname, branch) of | 511 case V.is_on_branch context (libname, branch) of |
457 ERROR e => ERROR e | 512 ERROR e => ERROR e |
495 | 550 |
496 fun update context | 551 fun update context |
497 ({ libname, source, branch, | 552 ({ libname, source, branch, |
498 project_pin, lock_pin, ... } : libspec) = | 553 project_pin, lock_pin, ... } : libspec) = |
499 let fun update_unpinned () = | 554 let fun update_unpinned () = |
500 case V.is_newest context (libname, branch) of | 555 case V.is_newest context (libname, source, branch) of |
501 ERROR e => ERROR e | 556 ERROR e => ERROR e |
502 | OK true => V.id_of context libname | 557 | OK true => OK () |
503 | OK false => V.update context (libname, branch) | 558 | OK false => V.update context (libname, source, branch) |
504 fun update_pinned target = | 559 fun update_pinned target = |
505 case V.is_at context (libname, target) of | 560 case V.is_at context (libname, target) of |
506 ERROR e => ERROR e | 561 ERROR e => ERROR e |
507 | OK true => OK target | 562 | OK true => OK () |
508 | OK false => V.update_to context (libname, target) | 563 | OK false => V.update_to context (libname, source, target) |
509 fun update' () = | 564 fun update' () = |
510 case lock_pin of | 565 case lock_pin of |
511 PINNED target => update_pinned target | 566 PINNED target => update_pinned target |
512 | UNPINNED => | 567 | UNPINNED => |
513 case project_pin of | 568 case project_pin of |
1020 } | 1075 } |
1021 } | 1076 } |
1022 ] | 1077 ] |
1023 | 1078 |
1024 fun vcs_name vcs = | 1079 fun vcs_name vcs = |
1025 case vcs of GIT => "git" | | 1080 case vcs of HG => "hg" |
1026 HG => "hg" | 1081 | GIT => "git" |
1082 | SVN => "svn" | |
1027 | 1083 |
1028 fun vcs_from_name name = | 1084 fun vcs_from_name name = |
1029 case name of "git" => GIT | 1085 case name of "hg" => HG |
1030 | "hg" => HG | 1086 | "git" => GIT |
1087 | "svn" => SVN | |
1031 | other => raise Fail ("Unknown vcs name \"" ^ name ^ "\"") | 1088 | other => raise Fail ("Unknown vcs name \"" ^ name ^ "\"") |
1032 | 1089 |
1033 fun load_more_providers previously_loaded json = | 1090 fun load_more_providers previously_loaded json = |
1034 let open JsonBits | 1091 let open JsonBits |
1035 fun load pjson pname : provider = | 1092 fun load pjson pname : provider = |
1127 | 1184 |
1128 fun login_for ({ accounts, ... } : context) service = | 1185 fun login_for ({ accounts, ... } : context) service = |
1129 case List.find (fn a => service = #service a) accounts of | 1186 case List.find (fn a => service = #service a) accounts of |
1130 SOME { login, ... } => SOME login | 1187 SOME { login, ... } => SOME login |
1131 | NONE => NONE | 1188 | NONE => NONE |
1132 | 1189 |
1190 fun reponame_for path = | |
1191 case String.tokens (fn c => c = #"/") path of | |
1192 [] => raise Fail "Non-empty library path required" | |
1193 | toks => hd (rev toks) | |
1194 | |
1133 fun remote_url (context : context) vcs source libname = | 1195 fun remote_url (context : context) vcs source libname = |
1134 case source of | 1196 case source of |
1135 URL_SOURCE u => u | 1197 URL_SOURCE u => u |
1136 | SERVICE_SOURCE { service, owner, repo } => | 1198 | SERVICE_SOURCE { service, owner, repo } => |
1137 provider_url { vcs = vcs, | 1199 provider_url { vcs = vcs, |
1138 service = service, | 1200 service = service, |
1139 owner = owner, | 1201 owner = owner, |
1140 repo = case repo of | 1202 repo = case repo of |
1141 SOME r => r | 1203 SOME r => r |
1142 | NONE => libname } | 1204 | NONE => reponame_for libname } |
1143 (login_for context service) | 1205 (login_for context service) |
1144 (#providers context) | 1206 (#providers context) |
1145 end | 1207 end |
1146 | 1208 |
1147 structure HgControl :> VCS_CONTROL = struct | 1209 structure HgControl :> VCS_CONTROL = struct |
1148 | 1210 |
1211 (* Pulls always use an explicit URL, never just the default | |
1212 remote, in order to ensure we update properly if the location | |
1213 given in the project file changes. *) | |
1214 | |
1149 type vcsstate = { id: string, modified: bool, | 1215 type vcsstate = { id: string, modified: bool, |
1150 branch: string, tags: string list } | 1216 branch: string, tags: string list } |
1151 | 1217 |
1152 val hg_args = [ "--config", "ui.interactive=true" ] | 1218 val hg_args = [ "--config", "ui.interactive=true", |
1219 "--config", "ui.merge=:merge" ] | |
1153 | 1220 |
1154 fun hg_command context libname args = | 1221 fun hg_command context libname args = |
1155 FileBits.command context libname ("hg" :: hg_args @ args) | 1222 FileBits.command context libname ("hg" :: hg_args @ args) |
1156 | 1223 |
1157 fun hg_command_output context libname args = | 1224 fun hg_command_output context libname args = |
1220 fun is_newest_locally context (libname, branch) = | 1287 fun is_newest_locally context (libname, branch) = |
1221 case hg_command_output context libname | 1288 case hg_command_output context libname |
1222 ["log", "-l1", | 1289 ["log", "-l1", |
1223 "-b", branch_name branch, | 1290 "-b", branch_name branch, |
1224 "--template", "{node}"] of | 1291 "--template", "{node}"] of |
1225 ERROR e => ERROR e | 1292 ERROR e => OK false (* desired branch does not exist *) |
1226 | OK newest_in_repo => is_at context (libname, newest_in_repo) | 1293 | OK newest_in_repo => is_at context (libname, newest_in_repo) |
1227 | 1294 |
1228 fun pull context libname = | 1295 fun pull context (libname, source) = |
1229 hg_command context libname | 1296 let val url = remote_for context (libname, source) |
1230 (if FileBits.verbose () | 1297 in |
1231 then ["pull"] | 1298 hg_command context libname |
1232 else ["pull", "-q"]) | 1299 (if FileBits.verbose () |
1233 | 1300 then ["pull", url] |
1234 fun is_newest context (libname, branch) = | 1301 else ["pull", "-q", url]) |
1302 end | |
1303 | |
1304 fun is_newest context (libname, source, branch) = | |
1235 case is_newest_locally context (libname, branch) of | 1305 case is_newest_locally context (libname, branch) of |
1236 ERROR e => ERROR e | 1306 ERROR e => ERROR e |
1237 | OK false => OK false | 1307 | OK false => OK false |
1238 | OK true => | 1308 | OK true => |
1239 case pull context libname of | 1309 case pull context (libname, source) of |
1240 ERROR e => ERROR e | 1310 ERROR e => ERROR e |
1241 | _ => is_newest_locally context (libname, branch) | 1311 | _ => is_newest_locally context (libname, branch) |
1242 | 1312 |
1243 fun is_modified_locally context libname = | 1313 fun is_modified_locally context libname = |
1244 case current_state context libname of | 1314 case current_state context libname of |
1246 | OK { modified, ... } => OK modified | 1316 | OK { modified, ... } => OK modified |
1247 | 1317 |
1248 fun checkout context (libname, source, branch) = | 1318 fun checkout context (libname, source, branch) = |
1249 let val url = remote_for context (libname, source) | 1319 let val url = remote_for context (libname, source) |
1250 in | 1320 in |
1251 case FileBits.mkpath (FileBits.extpath context) of | 1321 (* make the lib dir rather than just the ext dir, since |
1322 the lib dir might be nested and hg will happily check | |
1323 out into an existing empty dir anyway *) | |
1324 case FileBits.mkpath (FileBits.libpath context libname) of | |
1252 ERROR e => ERROR e | 1325 ERROR e => ERROR e |
1253 | _ => hg_command context "" | 1326 | _ => hg_command context "" |
1254 ["clone", "-u", branch_name branch, | 1327 ["clone", "-u", branch_name branch, |
1255 url, libname] | 1328 url, libname] |
1256 end | 1329 end |
1257 | 1330 |
1258 fun update context (libname, branch) = | 1331 fun update context (libname, source, branch) = |
1259 let val pull_result = pull context libname | 1332 let val pull_result = pull context (libname, source) |
1260 in | 1333 in |
1261 case hg_command context libname ["update", branch_name branch] of | 1334 case hg_command context libname ["update", branch_name branch] of |
1262 ERROR e => ERROR e | 1335 ERROR e => ERROR e |
1263 | _ => | 1336 | _ => |
1264 case pull_result of | 1337 case pull_result of |
1265 ERROR e => ERROR e | 1338 ERROR e => ERROR e |
1266 | _ => id_of context libname | 1339 | _ => OK () |
1267 end | 1340 end |
1268 | 1341 |
1269 fun update_to context (libname, "") = | 1342 fun update_to context (libname, _, "") = |
1270 ERROR "Non-empty id (tag or revision id) required for update_to" | 1343 ERROR "Non-empty id (tag or revision id) required for update_to" |
1271 | update_to context (libname, id) = | 1344 | update_to context (libname, source, id) = |
1272 let val pull_result = pull context libname | 1345 let val pull_result = pull context (libname, source) |
1273 in | 1346 in |
1274 case hg_command context libname ["update", "-r", id] of | 1347 case hg_command context libname ["update", "-r", id] of |
1275 OK _ => id_of context libname | 1348 OK _ => OK () |
1276 | ERROR e => | 1349 | ERROR e => |
1277 case pull_result of | 1350 case pull_result of |
1278 ERROR e' => ERROR e' (* this was the ur-error *) | 1351 ERROR e' => ERROR e' (* this was the ur-error *) |
1279 | _ => ERROR e | 1352 | _ => ERROR e |
1280 end | 1353 end |
1281 | 1354 |
1355 fun copy_url_for context libname = | |
1356 OK (FileBits.file_url (FileBits.libpath context libname)) | |
1357 | |
1282 end | 1358 end |
1283 | 1359 |
1284 structure GitControl :> VCS_CONTROL = struct | 1360 structure GitControl :> VCS_CONTROL = struct |
1285 | 1361 |
1286 (* With Git repos we always operate in detached HEAD state. Even | 1362 (* With Git repos we always operate in detached HEAD state. Even |
1287 the master branch is checked out using the remote reference, | 1363 the master branch is checked out using a remote reference |
1288 origin/master. *) | 1364 (vext/master). The remote we use is always named vext, and we |
1365 update it to the expected URL each time we fetch, in order to | |
1366 ensure we update properly if the location given in the project | |
1367 file changes. The origin remote is unused. *) | |
1289 | 1368 |
1290 fun git_command context libname args = | 1369 fun git_command context libname args = |
1291 FileBits.command context libname ("git" :: args) | 1370 FileBits.command context libname ("git" :: args) |
1292 | 1371 |
1293 fun git_command_output context libname args = | 1372 fun git_command_output context libname args = |
1303 fun branch_name branch = case branch of | 1382 fun branch_name branch = case branch of |
1304 DEFAULT_BRANCH => "master" | 1383 DEFAULT_BRANCH => "master" |
1305 | BRANCH "" => "master" | 1384 | BRANCH "" => "master" |
1306 | BRANCH b => b | 1385 | BRANCH b => b |
1307 | 1386 |
1308 fun remote_branch_name branch = "origin/" ^ branch_name branch | 1387 val our_remote = "vext" |
1388 | |
1389 fun remote_branch_name branch = our_remote ^ "/" ^ branch_name branch | |
1309 | 1390 |
1310 fun checkout context (libname, source, branch) = | 1391 fun checkout context (libname, source, branch) = |
1311 let val url = remote_for context (libname, source) | 1392 let val url = remote_for context (libname, source) |
1312 in | 1393 in |
1313 case FileBits.mkpath (FileBits.extpath context) of | 1394 (* make the lib dir rather than just the ext dir, since |
1395 the lib dir might be nested and git will happily check | |
1396 out into an existing empty dir anyway *) | |
1397 case FileBits.mkpath (FileBits.libpath context libname) of | |
1314 OK () => git_command context "" | 1398 OK () => git_command context "" |
1315 ["clone", "-b", | 1399 ["clone", "--origin", our_remote, |
1316 branch_name branch, | 1400 "--branch", branch_name branch, |
1317 url, libname] | 1401 url, libname] |
1318 | ERROR e => ERROR e | 1402 | ERROR e => ERROR e |
1403 end | |
1404 | |
1405 fun add_our_remote context (libname, source) = | |
1406 (* When we do the checkout ourselves (above), we add the | |
1407 remote at the same time. But if the repo was cloned by | |
1408 someone else, we'll need to do it after the fact. Git | |
1409 doesn't seem to have a means to add a remote or change its | |
1410 url if it already exists; seems we have to do this: *) | |
1411 let val url = remote_for context (libname, source) | |
1412 in | |
1413 case git_command context libname | |
1414 ["remote", "set-url", our_remote, url] of | |
1415 OK () => OK () | |
1416 | ERROR e => git_command context libname | |
1417 ["remote", "add", "-f", our_remote, url] | |
1319 end | 1418 end |
1320 | 1419 |
1321 (* NB git rev-parse HEAD shows revision id of current checkout; | 1420 (* NB git rev-parse HEAD shows revision id of current checkout; |
1322 git rev-list -1 <tag> shows revision id of revision with that tag *) | 1421 git rev-list -1 <tag> shows revision id of revision with that tag *) |
1323 | 1422 |
1324 fun id_of context libname = | 1423 fun id_of context libname = |
1325 git_command_output context libname ["rev-parse", "HEAD"] | 1424 git_command_output context libname ["rev-parse", "HEAD"] |
1326 | 1425 |
1327 fun is_at context (libname, id_or_tag) = | 1426 fun is_at context (libname, id_or_tag) = |
1328 case id_of context libname of | 1427 case id_of context libname of |
1329 ERROR e => ERROR e | 1428 ERROR e => OK false (* HEAD nonexistent, expected in empty repo *) |
1330 | OK id => | 1429 | OK id => |
1331 if String.isPrefix id_or_tag id orelse | 1430 if String.isPrefix id_or_tag id orelse |
1332 String.isPrefix id id_or_tag | 1431 String.isPrefix id id_or_tag |
1333 then OK true | 1432 then OK true |
1334 else | 1433 else |
1335 case git_command_output context libname | 1434 case git_command_output context libname |
1336 ["show-ref", | 1435 ["show-ref", |
1337 "refs/tags/" ^ id_or_tag] of | 1436 "refs/tags/" ^ id_or_tag, |
1437 "--"] of | |
1338 OK "" => OK false | 1438 OK "" => OK false |
1339 | ERROR _ => OK false | 1439 | ERROR _ => OK false |
1340 | OK s => OK (id = hd (String.tokens (fn c => c = #" ") s)) | 1440 | OK s => OK (id = hd (String.tokens (fn c => c = #" ") s)) |
1341 | 1441 |
1342 fun branch_tip context (libname, branch) = | 1442 fun branch_tip context (libname, branch) = |
1443 (* We don't have access to the source info or the network | |
1444 here, as this is used by status (e.g. via is_on_branch) as | |
1445 well as review. It's possible the remote branch won't exist, | |
1446 e.g. if the repo was checked out by something other than | |
1447 Vext, and if that's the case, we can't add it here; we'll | |
1448 just have to fail, since checking against local branches | |
1449 instead could produce the wrong result. *) | |
1343 git_command_output context libname | 1450 git_command_output context libname |
1344 ["rev-list", "-1", | 1451 ["rev-list", "-1", |
1345 remote_branch_name branch] | 1452 remote_branch_name branch, "--"] |
1346 | 1453 |
1347 fun is_newest_locally context (libname, branch) = | 1454 fun is_newest_locally context (libname, branch) = |
1348 case branch_tip context (libname, branch) of | 1455 case branch_tip context (libname, branch) of |
1349 ERROR e => ERROR e | 1456 ERROR e => OK false |
1350 | OK rev => is_at context (libname, rev) | 1457 | OK rev => is_at context (libname, rev) |
1351 | 1458 |
1352 fun is_on_branch context (libname, branch) = | 1459 fun is_on_branch context (libname, branch) = |
1353 case branch_tip context (libname, branch) of | 1460 case branch_tip context (libname, branch) of |
1354 ERROR e => ERROR e | 1461 ERROR e => OK false |
1355 | OK rev => | 1462 | OK rev => |
1356 case is_at context (libname, rev) of | 1463 case is_at context (libname, rev) of |
1357 ERROR e => ERROR e | 1464 ERROR e => ERROR e |
1358 | OK true => OK true | 1465 | OK true => OK true |
1359 | OK false => | 1466 | OK false => |
1361 ["merge-base", "--is-ancestor", | 1468 ["merge-base", "--is-ancestor", |
1362 "HEAD", remote_branch_name branch] of | 1469 "HEAD", remote_branch_name branch] of |
1363 ERROR e => OK false (* cmd returns non-zero for no *) | 1470 ERROR e => OK false (* cmd returns non-zero for no *) |
1364 | _ => OK true | 1471 | _ => OK true |
1365 | 1472 |
1366 fun is_newest context (libname, branch) = | 1473 fun fetch context (libname, source) = |
1367 case is_newest_locally context (libname, branch) of | 1474 case add_our_remote context (libname, source) of |
1368 ERROR e => ERROR e | 1475 ERROR e => ERROR e |
1369 | OK false => OK false | 1476 | _ => git_command context libname ["fetch", our_remote] |
1370 | OK true => | 1477 |
1371 case git_command context libname ["fetch"] of | 1478 fun is_newest context (libname, source, branch) = |
1479 case add_our_remote context (libname, source) of | |
1480 ERROR e => ERROR e | |
1481 | OK () => | |
1482 case is_newest_locally context (libname, branch) of | |
1372 ERROR e => ERROR e | 1483 ERROR e => ERROR e |
1373 | _ => is_newest_locally context (libname, branch) | 1484 | OK false => OK false |
1485 | OK true => | |
1486 case fetch context (libname, source) of | |
1487 ERROR e => ERROR e | |
1488 | _ => is_newest_locally context (libname, branch) | |
1374 | 1489 |
1375 fun is_modified_locally context libname = | 1490 fun is_modified_locally context libname = |
1376 case git_command_output context libname ["status", "--porcelain"] of | 1491 case git_command_output context libname ["status", "--porcelain"] of |
1377 ERROR e => ERROR e | 1492 ERROR e => ERROR e |
1378 | OK "" => OK false | 1493 | OK "" => OK false |
1383 branch, as that will succeed even if the branch isn't up to | 1498 branch, as that will succeed even if the branch isn't up to |
1384 date. We could checkout the branch and then fetch and merge, | 1499 date. We could checkout the branch and then fetch and merge, |
1385 but it's perhaps cleaner not to maintain a local branch at all, | 1500 but it's perhaps cleaner not to maintain a local branch at all, |
1386 but instead checkout the remote branch as a detached head. *) | 1501 but instead checkout the remote branch as a detached head. *) |
1387 | 1502 |
1388 fun update context (libname, branch) = | 1503 fun update context (libname, source, branch) = |
1389 case git_command context libname ["fetch"] of | 1504 case fetch context (libname, source) of |
1390 ERROR e => ERROR e | 1505 ERROR e => ERROR e |
1391 | _ => | 1506 | _ => |
1392 case git_command context libname ["checkout", "--detach", | 1507 case git_command context libname ["checkout", "--detach", |
1393 remote_branch_name branch] of | 1508 remote_branch_name branch] of |
1394 ERROR e => ERROR e | 1509 ERROR e => ERROR e |
1395 | _ => id_of context libname | 1510 | _ => OK () |
1396 | 1511 |
1397 (* This function is dealing with a specific id or tag, so if we | 1512 (* This function is dealing with a specific id or tag, so if we |
1398 can successfully check it out (detached) then that's all we | 1513 can successfully check it out (detached) then that's all we |
1399 need to do, regardless of whether fetch succeeded or not. We do | 1514 need to do, regardless of whether fetch succeeded or not. We do |
1400 attempt the fetch first, though, purely in order to avoid ugly | 1515 attempt the fetch first, though, purely in order to avoid ugly |
1401 error messages in the common case where we're being asked to | 1516 error messages in the common case where we're being asked to |
1402 update to a new pin (from the lock file) that hasn't been | 1517 update to a new pin (from the lock file) that hasn't been |
1403 fetched yet. *) | 1518 fetched yet. *) |
1404 | 1519 |
1405 fun update_to context (libname, "") = | 1520 fun update_to context (libname, _, "") = |
1406 ERROR "Non-empty id (tag or revision id) required for update_to" | 1521 ERROR "Non-empty id (tag or revision id) required for update_to" |
1407 | update_to context (libname, id) = | 1522 | update_to context (libname, source, id) = |
1408 let val fetch_result = git_command context libname ["fetch"] | 1523 let val fetch_result = fetch context (libname, source) |
1409 in | 1524 in |
1410 case git_command context libname ["checkout", "--detach", id] of | 1525 case git_command context libname ["checkout", "--detach", id] of |
1411 OK _ => id_of context libname | 1526 OK _ => OK () |
1412 | ERROR e => | 1527 | ERROR e => |
1413 case fetch_result of | 1528 case fetch_result of |
1414 ERROR e' => ERROR e' (* this was the ur-error *) | 1529 ERROR e' => ERROR e' (* this was the ur-error *) |
1415 | _ => ERROR e | 1530 | _ => ERROR e |
1416 end | 1531 end |
1532 | |
1533 fun copy_url_for context libname = | |
1534 OK (FileBits.file_url (FileBits.libpath context libname)) | |
1417 | 1535 |
1418 end | 1536 end |
1419 | 1537 |
1538 structure SvnControl :> VCS_CONTROL = struct | |
1539 | |
1540 fun svn_command context libname args = | |
1541 FileBits.command context libname ("svn" :: args) | |
1542 | |
1543 fun svn_command_output context libname args = | |
1544 FileBits.command_output context libname ("svn" :: args) | |
1545 | |
1546 fun svn_command_lines context libname args = | |
1547 case svn_command_output context libname args of | |
1548 ERROR e => ERROR e | |
1549 | OK s => OK (String.tokens (fn c => c = #"\n" orelse c = #"\r") s) | |
1550 | |
1551 fun split_line_pair line = | |
1552 let fun strip_leading_ws str = case explode str of | |
1553 #" "::rest => implode rest | |
1554 | _ => str | |
1555 in | |
1556 case String.tokens (fn c => c = #":") line of | |
1557 [] => ("", "") | |
1558 | first::rest => | |
1559 (first, strip_leading_ws (String.concatWith ":" rest)) | |
1560 end | |
1561 | |
1562 fun svn_info_item context libname key = | |
1563 (* SVN 1.9 has info --show-item which is what we need, but at | |
1564 this point we still have 1.8 on the CI boxes so we might as | |
1565 well aim to support it *) | |
1566 case svn_command_lines context libname ["info"] of | |
1567 ERROR e => ERROR e | |
1568 | OK lines => | |
1569 case List.find (fn (k, v) => k = key) (map split_line_pair lines) of | |
1570 NONE => ERROR ("Key \"" ^ key ^ "\" not found in output") | |
1571 | SOME (_, v) => OK v | |
1572 | |
1573 fun exists context libname = | |
1574 OK (OS.FileSys.isDir (FileBits.subpath context libname ".svn")) | |
1575 handle _ => OK false | |
1576 | |
1577 fun remote_for context (libname, source) = | |
1578 Provider.remote_url context SVN source libname | |
1579 | |
1580 fun id_of context libname = | |
1581 svn_info_item context libname "Revision" (*!!! check: does svn localise this? should we ensure C locale? *) | |
1582 | |
1583 fun is_at context (libname, id_or_tag) = | |
1584 case id_of context libname of | |
1585 ERROR e => ERROR e | |
1586 | OK id => OK (id = id_or_tag) | |
1587 | |
1588 fun is_on_branch context (libname, b) = | |
1589 OK (b = DEFAULT_BRANCH) | |
1590 | |
1591 fun is_newest context (libname, source, branch) = | |
1592 case svn_command_lines context libname ["status", "--show-updates"] of | |
1593 ERROR e => ERROR e | |
1594 | OK lines => | |
1595 case rev lines of | |
1596 [] => ERROR "No result returned for server status" | |
1597 | last_line::_ => | |
1598 case rev (String.tokens (fn c => c = #" ") last_line) of | |
1599 [] => ERROR "No revision field found in server status" | |
1600 | server_id::_ => is_at context (libname, server_id) | |
1601 | |
1602 fun is_newest_locally context (libname, branch) = | |
1603 OK true (* no local history *) | |
1604 | |
1605 fun is_modified_locally context libname = | |
1606 case svn_command_output context libname ["status"] of | |
1607 ERROR e => ERROR e | |
1608 | OK "" => OK false | |
1609 | OK _ => OK true | |
1610 | |
1611 fun checkout context (libname, source, branch) = | |
1612 let val url = remote_for context (libname, source) | |
1613 val path = FileBits.libpath context libname | |
1614 in | |
1615 if FileBits.nonempty_dir_exists path | |
1616 then (* Surprisingly, SVN itself has no problem with | |
1617 this. But for consistency with other VCSes we | |
1618 don't allow it *) | |
1619 ERROR ("Refusing checkout to nonempty dir \"" ^ path ^ "\"") | |
1620 else | |
1621 (* make the lib dir rather than just the ext dir, since | |
1622 the lib dir might be nested and svn will happily check | |
1623 out into an existing empty dir anyway *) | |
1624 case FileBits.mkpath (FileBits.libpath context libname) of | |
1625 ERROR e => ERROR e | |
1626 | _ => svn_command context "" ["checkout", url, libname] | |
1627 end | |
1628 | |
1629 fun update context (libname, source, branch) = | |
1630 case svn_command context libname | |
1631 ["update", "--accept", "postpone"] of | |
1632 ERROR e => ERROR e | |
1633 | _ => OK () | |
1634 | |
1635 fun update_to context (libname, _, "") = | |
1636 ERROR "Non-empty id (tag or revision id) required for update_to" | |
1637 | update_to context (libname, source, id) = | |
1638 case svn_command context libname | |
1639 ["update", "-r", id, "--accept", "postpone"] of | |
1640 ERROR e => ERROR e | |
1641 | OK _ => OK () | |
1642 | |
1643 fun copy_url_for context libname = | |
1644 svn_info_item context libname "URL" | |
1645 | |
1646 end | |
1647 | |
1420 structure AnyLibControl :> LIB_CONTROL = struct | 1648 structure AnyLibControl :> LIB_CONTROL = struct |
1421 | 1649 |
1422 structure H = LibControlFn(HgControl) | 1650 structure H = LibControlFn(HgControl) |
1423 structure G = LibControlFn(GitControl) | 1651 structure G = LibControlFn(GitControl) |
1652 structure S = LibControlFn(SvnControl) | |
1424 | 1653 |
1425 fun review context (spec as { vcs, ... } : libspec) = | 1654 fun review context (spec as { vcs, ... } : libspec) = |
1426 (fn HG => H.review | GIT => G.review) vcs context spec | 1655 (fn HG => H.review | GIT => G.review | SVN => S.review) vcs context spec |
1427 | 1656 |
1428 fun status context (spec as { vcs, ... } : libspec) = | 1657 fun status context (spec as { vcs, ... } : libspec) = |
1429 (fn HG => H.status | GIT => G.status) vcs context spec | 1658 (fn HG => H.status | GIT => G.status | SVN => S.status) vcs context spec |
1430 | 1659 |
1431 fun update context (spec as { vcs, ... } : libspec) = | 1660 fun update context (spec as { vcs, ... } : libspec) = |
1432 (fn HG => H.update | GIT => G.update) vcs context spec | 1661 (fn HG => H.update | GIT => G.update | SVN => S.update) vcs context spec |
1433 | 1662 |
1434 fun id_of context (spec as { vcs, ... } : libspec) = | 1663 fun id_of context (spec as { vcs, ... } : libspec) = |
1435 (fn HG => H.id_of | GIT => G.id_of) vcs context spec | 1664 (fn HG => H.id_of | GIT => G.id_of | SVN => S.id_of) vcs context spec |
1665 | |
1436 end | 1666 end |
1437 | 1667 |
1438 | 1668 |
1439 type exclusions = string list | 1669 type exclusions = string list |
1440 | 1670 |
1485 does not. End users shouldn't get to see Vext) | 1715 does not. End users shouldn't get to see Vext) |
1486 | 1716 |
1487 - Clean up by deleting the new copy | 1717 - Clean up by deleting the new copy |
1488 *) | 1718 *) |
1489 | 1719 |
1490 fun project_vcs_and_id dir = | 1720 fun project_vcs_id_and_url dir = |
1491 let val context = { | 1721 let val context = { |
1492 rootpath = dir, | 1722 rootpath = dir, |
1493 extdir = ".", | 1723 extdir = ".", |
1494 providers = [], | 1724 providers = [], |
1495 accounts = [] | 1725 accounts = [] |
1496 } | 1726 } |
1497 val vcs_maybe = | 1727 val vcs_maybe = |
1498 case [HgControl.exists context ".", | 1728 case [HgControl.exists context ".", |
1499 GitControl.exists context "."] of | 1729 GitControl.exists context ".", |
1500 [OK true, OK false] => OK HG | 1730 SvnControl.exists context "."] of |
1501 | [OK false, OK true] => OK GIT | 1731 [OK true, OK false, OK false] => OK HG |
1732 | [OK false, OK true, OK false] => OK GIT | |
1733 | [OK false, OK false, OK true] => OK SVN | |
1502 | _ => ERROR ("Unable to identify VCS for directory " ^ dir) | 1734 | _ => ERROR ("Unable to identify VCS for directory " ^ dir) |
1503 in | 1735 in |
1504 case vcs_maybe of | 1736 case vcs_maybe of |
1505 ERROR e => ERROR e | 1737 ERROR e => ERROR e |
1506 | OK vcs => | 1738 | OK vcs => |
1507 case (fn HG => HgControl.id_of | GIT => GitControl.id_of) | 1739 case (fn HG => HgControl.id_of |
1740 | GIT => GitControl.id_of | |
1741 | SVN => SvnControl.id_of) | |
1508 vcs context "." of | 1742 vcs context "." of |
1509 ERROR e => ERROR ("Unable to obtain id of project repo: " | 1743 ERROR e => ERROR ("Unable to find id of project repo: " ^ e) |
1510 ^ e) | 1744 | OK id => |
1511 | OK id => OK (vcs, id) | 1745 case (fn HG => HgControl.copy_url_for |
1746 | GIT => GitControl.copy_url_for | |
1747 | SVN => SvnControl.copy_url_for) | |
1748 vcs context "." of | |
1749 ERROR e => ERROR ("Unable to find URL of project repo: " | |
1750 ^ e) | |
1751 | OK url => OK (vcs, id, url) | |
1512 end | 1752 end |
1513 | 1753 |
1514 fun make_archive_root (context : context) = | 1754 fun make_archive_root (context : context) = |
1515 let val path = OS.Path.joinDirFile { | 1755 let val path = OS.Path.joinDirFile { |
1516 dir = #rootpath context, | 1756 dir = #rootpath context, |
1532 fun check_nonexistent path = | 1772 fun check_nonexistent path = |
1533 case SOME (OS.FileSys.fileSize path) handle OS.SysErr _ => NONE of | 1773 case SOME (OS.FileSys.fileSize path) handle OS.SysErr _ => NONE of |
1534 NONE => () | 1774 NONE => () |
1535 | _ => raise Fail ("Path " ^ path ^ " exists, not overwriting") | 1775 | _ => raise Fail ("Path " ^ path ^ " exists, not overwriting") |
1536 | 1776 |
1537 fun file_url path = | 1777 fun make_archive_copy target_name (vcs, project_id, source_url) |
1538 let val forward_path = | |
1539 String.translate (fn #"\\" => "/" | | |
1540 c => Char.toString c) path | |
1541 in | |
1542 (* Path is expected to be absolute already, but if it | |
1543 starts with a drive letter, we'll need an extra slash *) | |
1544 case explode forward_path of | |
1545 #"/"::rest => "file:///" ^ implode rest | |
1546 | _ => "file:///" ^ forward_path | |
1547 end | |
1548 | |
1549 fun make_archive_copy target_name (vcs, project_id) | |
1550 ({ context, ... } : project) = | 1778 ({ context, ... } : project) = |
1551 let val archive_root = make_archive_root context | 1779 let val archive_root = make_archive_root context |
1552 val synthetic_context = { | 1780 val synthetic_context = { |
1553 rootpath = archive_root, | 1781 rootpath = archive_root, |
1554 extdir = ".", | 1782 extdir = ".", |
1556 accounts = [] | 1784 accounts = [] |
1557 } | 1785 } |
1558 val synthetic_library = { | 1786 val synthetic_library = { |
1559 libname = target_name, | 1787 libname = target_name, |
1560 vcs = vcs, | 1788 vcs = vcs, |
1561 source = URL_SOURCE (file_url (#rootpath context)), | 1789 source = URL_SOURCE source_url, |
1562 branch = DEFAULT_BRANCH, (* overridden by pinned id below *) | 1790 branch = DEFAULT_BRANCH, (* overridden by pinned id below *) |
1563 project_pin = PINNED project_id, | 1791 project_pin = PINNED project_id, |
1564 lock_pin = PINNED project_id | 1792 lock_pin = PINNED project_id |
1565 } | 1793 } |
1566 val path = archive_path archive_root target_name | 1794 val path = archive_path archive_root target_name |
1584 } | 1812 } |
1585 in | 1813 in |
1586 foldl (fn (lib, acc) => | 1814 foldl (fn (lib, acc) => |
1587 case acc of | 1815 case acc of |
1588 ERROR e => ERROR e | 1816 ERROR e => ERROR e |
1589 | OK _ => AnyLibControl.update synthetic_context lib) | 1817 | OK () => AnyLibControl.update synthetic_context lib) |
1590 (OK "") | 1818 (OK ()) |
1591 (#libs project) | 1819 (#libs project) |
1592 end | 1820 end |
1593 | 1821 |
1594 datatype packer = TAR | 1822 datatype packer = TAR |
1595 | TAR_GZ | 1823 | TAR_GZ |
1630 | TAR_BZ2 => "cjf" | 1858 | TAR_BZ2 => "cjf" |
1631 | TAR_XZ => "cJf", | 1859 | TAR_XZ => "cJf", |
1632 target_path, | 1860 target_path, |
1633 "--exclude=.hg", | 1861 "--exclude=.hg", |
1634 "--exclude=.git", | 1862 "--exclude=.git", |
1863 "--exclude=.svn", | |
1635 "--exclude=vext", | 1864 "--exclude=vext", |
1636 "--exclude=vext.sml", | 1865 "--exclude=vext.sml", |
1637 "--exclude=vext.ps1", | 1866 "--exclude=vext.ps1", |
1638 "--exclude=vext.bat", | 1867 "--exclude=vext.bat", |
1639 "--exclude=vext-project.json", | 1868 "--exclude=vext-project.json", |
1650 case packer_and_basename target_path of | 1879 case packer_and_basename target_path of |
1651 NONE => raise Fail ("Unsupported archive file extension in " | 1880 NONE => raise Fail ("Unsupported archive file extension in " |
1652 ^ target_path) | 1881 ^ target_path) |
1653 | SOME pn => pn | 1882 | SOME pn => pn |
1654 val details = | 1883 val details = |
1655 case project_vcs_and_id (#rootpath (#context project)) of | 1884 case project_vcs_id_and_url (#rootpath (#context project)) of |
1656 ERROR e => raise Fail e | 1885 ERROR e => raise Fail e |
1657 | OK details => details | 1886 | OK details => details |
1658 val archive_root = | 1887 val archive_root = |
1659 case make_archive_copy name details project of | 1888 case make_archive_copy name details project of |
1660 ERROR e => raise Fail e | 1889 ERROR e => raise Fail e |
1699 { | 1928 { |
1700 libname = libname, | 1929 libname = libname, |
1701 vcs = case vcs of | 1930 vcs = case vcs of |
1702 "hg" => HG | 1931 "hg" => HG |
1703 | "git" => GIT | 1932 | "git" => GIT |
1933 | "svn" => SVN | |
1704 | other => raise Fail ("Unknown version-control system \"" ^ | 1934 | other => raise Fail ("Unknown version-control system \"" ^ |
1705 other ^ "\""), | 1935 other ^ "\""), |
1706 source = case (url, service, owner, repo) of | 1936 source = case (url, service, owner, repo) of |
1707 (SOME u, NONE, _, _) => URL_SOURCE u | 1937 (SOME u, NONE, _, _) => URL_SOURCE u |
1708 | (NONE, SOME ss, owner, repo) => | 1938 | (NONE, SOME ss, owner, repo) => |
1710 | _ => raise Fail ("Must have exactly one of service " ^ | 1940 | _ => raise Fail ("Must have exactly one of service " ^ |
1711 "or url string"), | 1941 "or url string"), |
1712 project_pin = project_pin, | 1942 project_pin = project_pin, |
1713 lock_pin = lock_pin, | 1943 lock_pin = lock_pin, |
1714 branch = case branch of | 1944 branch = case branch of |
1715 SOME b => BRANCH b | 1945 NONE => DEFAULT_BRANCH |
1716 | NONE => DEFAULT_BRANCH | 1946 | SOME b => |
1947 case vcs of | |
1948 "svn" => raise Fail ("Branches not supported for " ^ | |
1949 "svn repositories; change " ^ | |
1950 "URL instead") | |
1951 | _ => BRANCH b | |
1717 } | 1952 } |
1718 end | 1953 end |
1719 | 1954 |
1720 fun load_userconfig () : userconfig = | 1955 fun load_userconfig () : userconfig = |
1721 let val home = FileBits.homedir () | 1956 let val home = FileBits.homedir () |
1897 fun review_project ({ context, libs } : project) = | 2132 fun review_project ({ context, libs } : project) = |
1898 return_code_for (act_and_print (AnyLibControl.review context) | 2133 return_code_for (act_and_print (AnyLibControl.review context) |
1899 print_status_header (print_status true) | 2134 print_status_header (print_status true) |
1900 libs) | 2135 libs) |
1901 | 2136 |
1902 fun update_project ({ context, libs } : project) = | |
1903 let val outcomes = act_and_print | |
1904 (AnyLibControl.update context) | |
1905 print_outcome_header print_update_outcome libs | |
1906 val locks = | |
1907 List.concat | |
1908 (map (fn (libname, result) => | |
1909 case result of | |
1910 ERROR _ => [] | |
1911 | OK id => [{ libname = libname, id_or_tag = id }]) | |
1912 outcomes) | |
1913 val return_code = return_code_for outcomes | |
1914 in | |
1915 if OS.Process.isSuccess return_code | |
1916 then save_lock_file (#rootpath context) locks | |
1917 else (); | |
1918 return_code | |
1919 end | |
1920 | |
1921 fun lock_project ({ context, libs } : project) = | 2137 fun lock_project ({ context, libs } : project) = |
1922 let val outcomes = map (fn lib => | 2138 let val _ = if FileBits.verbose () |
2139 then print ("Scanning IDs for lock file...\n") | |
2140 else () | |
2141 val outcomes = map (fn lib => | |
1923 (#libname lib, AnyLibControl.id_of context lib)) | 2142 (#libname lib, AnyLibControl.id_of context lib)) |
1924 libs | 2143 libs |
1925 val locks = | 2144 val locks = |
1926 List.concat | 2145 List.concat |
1927 (map (fn (libname, result) => | 2146 (map (fn (libname, result) => |
1934 in | 2153 in |
1935 if OS.Process.isSuccess return_code | 2154 if OS.Process.isSuccess return_code |
1936 then save_lock_file (#rootpath context) locks | 2155 then save_lock_file (#rootpath context) locks |
1937 else (); | 2156 else (); |
1938 return_code | 2157 return_code |
2158 end | |
2159 | |
2160 fun update_project (project as { context, libs }) = | |
2161 let val outcomes = act_and_print | |
2162 (AnyLibControl.update context) | |
2163 print_outcome_header print_update_outcome libs | |
2164 val _ = if List.exists (fn (_, OK _) => true | _ => false) outcomes | |
2165 then lock_project project | |
2166 else OS.Process.success | |
2167 in | |
2168 return_code_for outcomes | |
1939 end | 2169 end |
1940 | 2170 |
1941 fun load_local_project pintype = | 2171 fun load_local_project pintype = |
1942 let val userconfig = load_userconfig () | 2172 let val userconfig = load_userconfig () |
1943 val rootpath = OS.FileSys.getDir () | 2173 val rootpath = OS.FileSys.getDir () |