[MLton-commit] r5849
Matthew Fluet
fluet at mlton.org
Sun Aug 12 17:07:28 PDT 2007
Importing wiki tool from old cvs repository
----------------------------------------------------------------------
A tools/wiki/
A tools/wiki/.ignore
A tools/wiki/Makefile
A tools/wiki/README
A tools/wiki/TODO
A tools/wiki/main.sml
A tools/wiki/wiki.mlb
----------------------------------------------------------------------
Added: tools/wiki/.ignore
===================================================================
--- tools/wiki/.ignore 2007-08-12 23:59:22 UTC (rev 5848)
+++ tools/wiki/.ignore 2007-08-13 00:07:28 UTC (rev 5849)
@@ -0,0 +1,2 @@
+wiki
+wiki.sml
Added: tools/wiki/Makefile
===================================================================
--- tools/wiki/Makefile 2007-08-12 23:59:22 UTC (rev 5848)
+++ tools/wiki/Makefile 2007-08-13 00:07:28 UTC (rev 5849)
@@ -0,0 +1,4 @@
+all: wiki
+
+wiki: $(shell mlton -stop f wiki.mlb)
+ mlton wiki.mlb
Added: tools/wiki/README
===================================================================
--- tools/wiki/README 2007-08-12 23:59:22 UTC (rev 5848)
+++ tools/wiki/README 2007-08-13 00:07:28 UTC (rev 5849)
@@ -0,0 +1,11 @@
+wiki login http://mlton.org StephenWeeks <my password>
+wiki checkout <file> ... # checkout specific files
+wiki checkout -depth 1 <file> # checkout all files reachable
+ # in 1 step
+... edit files ...
+wiki update <file> ... # update specific files
+wiki update # update all files
+... edit files ...
+wiki commit <file> # commit specific files
+wiki commit # commit all changed files
+wiki logout
Added: tools/wiki/TODO
===================================================================
--- tools/wiki/TODO 2007-08-12 23:59:22 UTC (rev 5848)
+++ tools/wiki/TODO 2007-08-13 00:07:28 UTC (rev 5849)
@@ -0,0 +1,10 @@
+wiki attach ls <file>
+wiki diff
+
+use keepalives
+make work with SSL
+handle renames better
+
+should attach/detach change the "Last edited ..." footer?
+Currently does not, which seems to be consistent with what happens
+when attach/detach through a browser.
Added: tools/wiki/main.sml
===================================================================
--- tools/wiki/main.sml 2007-08-12 23:59:22 UTC (rev 5848)
+++ tools/wiki/main.sml 2007-08-13 00:07:28 UTC (rev 5849)
@@ -0,0 +1,665 @@
+local
+ open Http
+in
+ structure Header = Header
+ structure Post = Post
+ structure Response = Response
+ structure Status = Status
+end
+
+local
+ open Regexp
+in
+ structure Match = Match
+end
+
+local
+ open Url
+in
+ structure Scheme = Scheme
+end
+
+fun makeOptions {usage = _} =
+ []
+
+val {parse, usage} =
+ Popt.makeUsage
+ {mainUsage = "wiki <action> <arg> ...\n\
+ \\tadd <file>+\n\
+ \\tattach <file> <attachment>+\n\
+ \\tcheckout <file>+\n\
+ \\tcommit <file>*\n\
+ \\tdetach <file> <attachment>+\n\
+ \\tlogin <url> <username> <password>\n\
+ \\tlogout\n\
+ \\trename <file> <file>\n\
+ \\tremove <file>+\n\
+ \\tupdate <file>*",
+ makeOptions = makeOptions,
+ showExpert = fn () => false}
+
+val usage = fn m => (usage m; raise Fail "bug")
+
+fun printl ss = (print (concat ss); print "\n")
+
+val debug = false
+
+fun debugMessage ss = if debug then printl ss else ()
+
+val wasError = ref false
+
+fun error ss = (printl ss; wasError := true)
+
+fun warn ss = printl ss
+
+val wikiDir = ".wiki/"
+val origDir = concat [wikiDir, "orig/"]
+val () = List.foreach ([wikiDir, origDir], fn d =>
+ if Dir.doesExist d then () else Dir.make d)
+val cookieFile = concat [wikiDir, "cookie"]
+val urlFile = concat [wikiDir, "url"]
+
+val amLoggedIn = File.doesExist cookieFile
+
+val url =
+ Promise.lazy (fn () =>
+ if File.doesExist urlFile
+ then File.contents urlFile
+ else Error.bug "not logged in")
+
+fun origFile f = concat [origDir, f]
+
+local
+ val reg =
+ Promise.lazy
+ (fn () =>
+ let
+ open Regexp
+ val msg = Save.new ()
+ val r =
+ compileDFA
+ (seq [string "<div id=\"message\">",
+ spaces,
+ string "<p>", save (anys, msg), string "</p>",
+ anys, string "Clear message"])
+ in
+ (msg, r)
+ end)
+in
+ fun extractMessageOpt (s: string): string option =
+ let
+ val (msg, r) = reg ()
+ in
+ Option.map
+ (Regexp.Compiled.findShort (r, s, 0), fn m =>
+ Substring.toString (Match.lookup (m, msg)))
+ end
+ fun extractMessage s =
+ case extractMessageOpt s of
+ NONE => (print s
+ ; Error.bug "unable to extract message")
+ | SOME m => m
+end
+
+fun fetch (url, post): {headers: Header.t list,
+ result: string} =
+ let
+ val () = debugMessage ["fetch: ", Url.toString url]
+ val headers = [Header.UserAgent "wiki sweeks at sweeks.com"]
+ val headers =
+ if amLoggedIn
+ then Header.Cookie (File.contents cookieFile) :: headers
+ else headers
+ val ins =
+ Http.fetch {head = false,
+ headers = headers,
+ post = post,
+ proxy = NONE,
+ url = url}
+ in
+ case Response.input ins of
+ Result.No msg =>
+ Error.bug (concat ["invalid http response: ", msg])
+ | Result.Yes (Response.T {headers, status, ...}) =>
+ case status of
+ Status.OK =>
+ let
+ val () =
+ if debug
+ then List.foreach (headers, fn h =>
+ printl [Header.toString h])
+ else ()
+ val result = In.withClose (ins, In.inputAll)
+ in
+ {headers = headers,
+ result = result}
+ end
+ | _ => Error.bug (concat ["http response: ", Status.reason status])
+ end
+
+fun fileUrl (file: string): Url.t =
+ case Url.fromString (concat [url (), file]) of
+ NONE => usage "invalid url"
+ | SOME url => url
+
+fun fetchRaw (file: string): string =
+ #result (fetch (Url.addQuery (fileUrl file, "action=raw"), NONE))
+
+val fetchRaw = String.memoize fetchRaw
+
+fun origExists file = File.doesExist (origFile file)
+
+fun remoteExists file = "" <> fetchRaw file
+
+fun locallyModified file =
+ not (File.sameContents (file, origFile file))
+
+fun remotelyModified file =
+ fetchRaw file <> File.contents (origFile file)
+
+structure Condition =
+ struct
+ datatype t =
+ Exists
+ | NotModified
+ | OrigExists
+ | RemoteExists
+
+ fun disprove (c: t, file: string): string option =
+ let
+ val (test, expl) =
+ case c of
+ Exists => (File.doesExist file, "does not exist.")
+ | NotModified =>
+ (File.sameContents (file, origFile file),
+ "has been modified.")
+ | OrigExists => (origExists file, "is not locally in the wiki.")
+ | RemoteExists =>
+ (remoteExists file, "does not exist on server.")
+ in
+ if test then NONE else SOME (concat [file, " ", expl])
+ end
+ end
+
+datatype z = datatype Condition.t
+
+fun ensure (f: string, c: Condition.t list, continue: unit -> unit): unit =
+ case List.peekMap (c, fn c => Condition.disprove (c, f)) of
+ NONE => continue ()
+ | SOME s => printl [s]
+
+local
+ val reg =
+ Promise.lazy
+ (fn () =>
+ let
+ open Regexp
+ val page = Save.new ()
+ val r =
+ compileDFA (seq [string "<a href=", dquote, string "/",
+ save (star (isChar
+ (fn c =>
+ case c of
+ #"?" => false
+ | #"\"" => false
+ | _ => true)),
+ page),
+ dquote])
+ in
+ (page, r)
+ end)
+in
+ fun links (file: string): string list =
+ let
+ val html = #result (fetch (fileUrl file, NONE))
+ val (page, r) = reg ()
+ fun loop (start, ac) =
+ case Regexp.Compiled.findShort (r, html, start) of
+ NONE => rev ac
+ | SOME m =>
+ let
+ val ss = Match.lookup (m, page)
+ val link = Substring.toString ss
+ val ac =
+ if String.hasSubstring (link,
+ {substring = "attachments"})
+ then ac
+ else link :: ac
+ in
+ loop (Substring.endOf ss, ac)
+ end
+ in
+ case String.findSubstring (html, {substring = "<body"}) of
+ NONE => Error.bug "couldn't find body"
+ | SOME i => loop (i, [])
+ end
+end
+
+fun updateOne (file: string): unit =
+ let
+ fun doit () =
+ (printl ["U ", file]
+ ; File.withOut (file, fn out => Out.output (out, fetchRaw file))
+ ; File.copy (file, origFile file))
+ in
+ case (File.doesExist file, origExists file, remoteExists file) of
+ (false, false, false) => error ["I know nothing about ", file, "."]
+ | (false, false, true) => doit ()
+ | (false, true, false) => (File.copy (origFile file, file)
+ ; printl ["A ", file])
+ | (false, true, true) => doit ()
+ | (true, false, _) => printl ["? ", file]
+ | (true, true, false) => printl ["A ", file]
+ | (true, true, true) =>
+ case (locallyModified file, remotelyModified file) of
+ (false, false) => ()
+ | (false, true) => doit ()
+ | (true, false) => printl ["M ", file]
+ | (true, true) =>
+ if fetchRaw file = File.contents file
+ then File.copy (file, origFile file)
+ else
+ (File.withOut (concat [file, ".remote"], fn out =>
+ Out.output (out, fetchRaw file))
+ ; printl ["C ", file])
+ end
+
+fun commitOne file =
+ ensure
+ (file, [Exists, OrigExists], fn () =>
+ if not (locallyModified file)
+ then warn ["Skipped ", file, " because it is unchanged."]
+ else
+ let
+ val url = fileUrl file
+ val {result = edit, ...} =
+ fetch (Url.addQuery (url, "action=edit"), NONE)
+ fun doit () =
+ if remoteExists file andalso remotelyModified file
+ then error ["Skipped ", file, " because it is in conflict."]
+ else
+ let
+ val datestamp =
+ let
+ open Regexp
+ val ds = Save.new ()
+ val mo =
+ Compiled.findShort
+ (compileNFA
+ (seq [string "name=\"datestamp\" value=\"",
+ save (digits, ds),
+ dquote]),
+ edit, 0)
+ in
+ case mo of
+ NONE => Error.bug "no datestamp"
+ | SOME m => Substring.toString (Match.lookup (m, ds))
+ end
+ val () = debugMessage ["datestamp is ", datestamp]
+ val post =
+ Post.T
+ {encoding = Post.Encoding.Url,
+ fields =
+ let
+ val string = Post.Value.string
+ in
+ [{name = "action", value = string "savepage"},
+ {name = "button_save", value = string "Save Changes"},
+ {name = "datestamp", value = string datestamp},
+ {name = "savetext", value = Post.Value.file file}]
+ end}
+ val {result, ...} = fetch (url, SOME post)
+ val message = extractMessage result
+ in
+ if String.hasPrefix
+ (message, {prefix = "Thank you for your changes."})
+ then (File.copy (file, origFile file)
+ ; warn ["Committed ", file, "."])
+ else (error ["Skipped ", file, ". ", message])
+ end
+ in
+ case extractMessageOpt edit of
+ NONE => doit ()
+ | SOME m =>
+ if String.hasSubstring (m, {substring = "not allowed"})
+ then error [m]
+ else doit ()
+ end)
+
+fun foreachWikiFile (command: string -> unit): unit =
+ List.foreach
+ (Dir.lsFiles (Dir.current ()), fn f =>
+ if origExists f
+ then command f
+ else ())
+
+fun addOne file =
+ ensure
+ (file, [Exists], fn () =>
+ if origExists file
+ then warn ["Skipping ", file, " because it has already been added."]
+ else File.withOut (origFile file, fn _ => ()))
+
+fun add args =
+ if List.isEmpty args
+ then usage "wiki add <file> ..."
+ else List.foreach (args, addOne)
+
+fun attach args =
+ let
+ fun bad () = usage "wiki attach <file> <attachment> ..."
+ in
+ case args of
+ [] => bad ()
+ | file :: attachments =>
+ if List.isEmpty attachments
+ then bad ()
+ else
+ ensure
+ (file, [RemoteExists], fn () =>
+ let
+ val url = fileUrl file
+ in
+ List.foreach
+ (attachments, fn attachment =>
+ let
+ val string = Post.Value.string
+ val fields =
+ [{name = "action", value = string "AttachFile"},
+ {name = "file", value = Post.Value.file attachment},
+ {name = "do", value = string "upload"}]
+ val {result, ...} =
+ fetch (url,
+ SOME (Post.T {encoding = Post.Encoding.Multipart,
+ fields = fields}))
+ val message = extractMessage result
+ in
+ if String.hasSuffix (message, {suffix = "saved."})
+ then (warn ["Attached ", attachment, " to ", file, "."])
+ else error [message]
+ end)
+ end)
+ end
+
+fun detach args =
+ let
+ fun bad () = usage "wiki detach <file> <attachment> ..."
+ in
+ case args of
+ [] => bad ()
+ | file :: attachments =>
+ if List.isEmpty attachments
+ then bad ()
+ else
+ ensure
+ (file, [RemoteExists], fn () =>
+ let
+ val url = fileUrl file
+ in
+ List.foreach
+ (attachments, fn attachment =>
+ let
+ val string = Post.Value.string
+ val fields =
+ [{name = "action", value = string "AttachFile"},
+ {name = "do", value = string "del"},
+ {name = "target", value = string attachment}]
+ val {result, ...} =
+ fetch (url,
+ SOME (Post.T {encoding = Post.Encoding.Multipart,
+ fields = fields}))
+ val message = extractMessage result
+ in
+ if String.hasSuffix (message, {suffix = "deleted."})
+ then (warn ["Detached ", attachment, " from ", file, "."])
+ else error [message]
+ end)
+ end)
+ end
+
+fun checkout args =
+ let
+ val depth = ref 0
+ open Popt
+ fun makeOptions {usage = _} =
+ List.map
+ ([(Normal, "depth", " <n>", " recursion depth",
+ Int (fn i => depth := i))],
+ fn (style, name, arg, desc, opt) =>
+ {arg = arg, desc = desc, name = name, opt = opt, style = style})
+ val {parse, usage} =
+ makeUsage {mainUsage = "wiki checkout [options] <file> ...",
+ makeOptions = makeOptions,
+ showExpert = fn () => false}
+ in
+ case parse args of
+ Result.No msg => usage msg
+ | Result.Yes rest =>
+ if List.isEmpty rest
+ then usage "must supply a file"
+ else
+ let
+ val depth = !depth
+ val seen = String.memoize (fn _ => ref false)
+ fun maybeAdd (q, files, depth) =
+ List.fold
+ (files, q, fn (f, q) =>
+ let
+ val r = seen f
+ in
+ if !r
+ then q
+ else (r := true; Queue.enque (q, (f, depth)))
+ end)
+ fun loop todo =
+ case Queue.deque todo of
+ NONE => ()
+ | SOME (todo, (file, depth)) =>
+ let
+ val () = updateOne file
+ in
+ loop (if 0 = depth
+ then todo
+ else maybeAdd (todo, links file, depth - 1))
+ end
+ in
+ loop (maybeAdd (Queue.empty (), rest, depth))
+ end
+ end
+
+fun ensureLoggedIn (f: unit -> unit): unit =
+ if amLoggedIn
+ then f ()
+ else error ["You are not logged in."]
+
+fun commit args =
+ ensureLoggedIn
+ (fn () =>
+ if List.isEmpty args
+ then foreachWikiFile commitOne
+ else List.foreach (args, commitOne))
+
+fun login (args: string list): unit =
+ case args of
+ [url, user, password] =>
+ let
+ val url =
+ if #"/" = String.last url then url else String.concat [url, "/"]
+ in
+ case Url.fromString url of
+ NONE => usage "invalid url"
+ | SOME url =>
+ let
+ val () =
+ if amLoggedIn
+ then Error.bug "You are already logged in."
+ else ()
+ val post =
+ Post.T
+ {encoding = Post.Encoding.Url,
+ fields =
+ let
+ val string = Post.Value.string
+ in
+ [{name = "action", value = string "userform"},
+ {name = "login", value = string "Login"},
+ {name = "password", value = string password},
+ {name = "username", value = string user}]
+ end}
+ val {headers, result} = fetch (url, SOME post)
+ in
+ case List.peek (headers, fn h =>
+ case h of
+ Header.Extension {name, ...} =>
+ name = "set-cookie"
+ | _ => false) of
+ SOME (Header.Extension {value, ...}) =>
+ (case String.fields (value, fn c => c = #";") of
+ [cookie, _, _] =>
+ (File.withOut (cookieFile, fn out =>
+ Out.output (out, cookie))
+ ; File.withOut (urlFile, fn out =>
+ Out.output (out, Url.toString url)))
+ | _ => Error.bug "server returned strange cookie")
+ | _ => error [extractMessage result]
+ end
+ end
+ | _ => usage "login <url> <user> <password>"
+
+fun logout args =
+ case args of
+ [] => ensureLoggedIn (fn () => File.remove cookieFile)
+ | _ => usage "logout"
+
+local
+ val reg =
+ Promise.lazy
+ (fn () =>
+ let
+ open Regexp
+ val ticket = Save.new ()
+ val r =
+ Regexp.compileDFA
+ (seq [string "name=\"ticket\" value=\"",
+ save (anys, ticket),
+ dquote])
+ in
+ (ticket, r)
+ end)
+in
+ fun ticketedAction {action: string,
+ button: string,
+ doit: unit -> unit,
+ extra: string,
+ file: string} =
+ let
+ val {result, ...} =
+ fetch (Url.addQuery (fileUrl file, concat ["action=", action]), NONE)
+ val message = extractMessage result
+ val (ticket, r) = reg ()
+ in
+ case Regexp.Compiled.findShort (r, message, 0) of
+ NONE => error [message]
+ | SOME m =>
+ let
+ val query =
+ concat
+ ["action=", action, "&button=", button, "&ticket=",
+ Substring.toString (Match.lookup (m, ticket)),
+ extra]
+ val {result, ...} =
+ fetch (Url.addQuery (fileUrl file, query), NONE)
+ val message = extractMessage result
+ in
+ if String.hasSubstring (message, {substring = "successfully"})
+ then doit ()
+ else error [message]
+ end
+ end
+end
+
+fun remove args =
+ if List.isEmpty args
+ then usage "remove <file> ..."
+ else
+ ensureLoggedIn
+ (fn () =>
+ List.foreach
+ (args, fn f =>
+ ensure
+ (f, [Exists, OrigExists], fn () =>
+ let
+ fun doit () = (File.remove f; File.remove (origFile f))
+ in
+ if not (remoteExists f)
+ then doit ()
+ else
+ ticketedAction
+ {action = "DeletePage",
+ button = "Delete",
+ doit = doit,
+ extra = "",
+ file = f}
+ end)))
+
+fun rename (args: string list): unit =
+ case args of
+ [old, new] =>
+ ensureLoggedIn
+ (fn () =>
+ if File.doesExist new
+ then error [new, " already exists."]
+ else
+ let
+ fun doit () =
+ (File.move {from = old, to = new}
+ ; Dir.inDir (origDir, fn () =>
+ File.move {from = old, to = new}))
+ in
+ ticketedAction
+ {action = "RenamePage",
+ button = "Rename",
+ doit = doit,
+ extra = concat ["&newpagename=", new],
+ file = old}
+ end)
+ | _ => usage "rename <old> <new>"
+
+fun update args =
+ if List.isEmpty args
+ then List.foreach (Dir.lsFiles origDir, updateOne)
+ else List.foreach (args, updateOne)
+
+val commands =
+ [("add", add),
+ ("attach", attach),
+ ("checkout", checkout),
+ ("commit", commit),
+ ("detach", detach),
+ ("login", login),
+ ("logout", logout),
+ ("rename", rename),
+ ("remove", remove),
+ ("update", update)]
+
+fun main args =
+ case parse args of
+ Result.No msg => usage msg
+ | Result.Yes rest =>
+ case rest of
+ [] => usage "missing action"
+ | action :: args =>
+ let
+ val possible =
+ List.keepAll (commands, fn (a, _) =>
+ String.hasPrefix (a, {prefix = action}))
+ in
+ case possible of
+ [] => usage (concat ["unknown action: ", action])
+ | [(_, command)] => command args
+ | _ => usage (concat ["ambiguous action: ", action])
+ end
+
+val status = Process.makeCommandLine main (CommandLine.arguments ())
+val status = if !wasError then OS.Process.failure else status
+val () = OS.Process.exit status
Added: tools/wiki/wiki.mlb
===================================================================
--- tools/wiki/wiki.mlb 2007-08-12 23:59:22 UTC (rev 5848)
+++ tools/wiki/wiki.mlb 2007-08-13 00:07:28 UTC (rev 5849)
@@ -0,0 +1,9 @@
+$(MLTON_SRC_LIB)/sources.mlb
+$(MLTON_SRC_LIB)/basic/http.mlb
+
+ann
+ "sequenceUnit true"
+ "warnUnused true"
+in
+ main.sml
+end
More information about the MLton-commit
mailing list