" ::
(if f <> ".." andalso OS.FileSys.isDir(OS.Path.concat(dirpath, f)) then
fhref (f ^ "/") r
else
fhref f r)
in
concat (pre @ foldr fmtentry post (".." :: entries))
end
(* Convert %xy to the character with hex code xy. No checks done. *)
fun xurldecode s = let
fun hexval c =
if #"0" <= c andalso c <= #"9"
then ord c - 48
else (ord c - 55) mod 32
fun loop [] acc = implode (rev acc)
| loop (#"%" :: cr) acc =
(case cr of
c1 :: c2 :: cr' =>
loop cr' (chr (16 * hexval c1 + hexval c2) :: acc)
| _ => loop cr (#"%" :: acc))
| loop (c :: cr) acc = loop cr (c :: acc)
in
loop (explode s) []
end
datatype result = String of string * string
(* a response and its MIME type *)
| File of BinIO.instream * int * string
(* instream, size, and MIME type *)
| Failure of exn
(* failure or exceptional result *)
fun htmldoc title contents =
String.concat("" :: title :: "\n"
:: "" :: title :: "\n"
:: contents :: ["\n"])
fun relativizeUrl (url:url,docroot:string) =
OS.Path.mkRelative (url,docroot)
(* dirty hack to get this to work... a more useful
* way of course would exist is OS.Path.fromUnixPath
* would friggin' exist! *)
fun isUnix () = (case SMLofNJ.SysInfo.getOSKind ()
of SMLofNJ.SysInfo.UNIX => true
| _ => false)
fun fromAbsUnixPath (s:string):string = let
fun is_sep (c:char) = (c = #"/")
in
if isUnix () then s
else OS.Path.toString {isAbs=false,
vol="",
arcs= String.tokens is_sep s}
end
fun response (docroot:string) (inp) : result = let
val _ = log (S.string (S.takel (Char.notContains "\r\n") (S.all inp)))
val (method, sus1) = S.splitl Char.isAlpha (S.all inp)
val _ = if S.string method <> "GET" then raise Notimplemented else ()
val path1 = S.string (S.trimr 1 (#1 (S.position "HTTP" (S.triml 2 sus1))))
in
if (String.isPrefix "SHUTDOWN" path1)
then raise ShutDown
else let
val path2 = xurldecode path1
(* Allow access only to docroot and its subdirectories: *)
val path3 = fromAbsUnixPath
(case #arcs(OS.Path.fromString (OS.Path.mkCanonical path2)) of
".." :: _ => raise Forbidden
| _ => OS.Path.concat(docroot, path2))
val indexes = ["index.html", "index.htm", "INDEX.HTML", "INDEX.HTM"]
open OS.FileSys
fun tryindex path idx = access (OS.Path.concat(path, idx), [])
fun exists p = if access (p, []) then () else raise Notfound
fun readbl p = if access (p, [A_READ]) then () else raise Forbidden
fun execbl p = if isUnix ()
then if access (p, [A_EXEC])
then ()
else raise Forbidden
else exists p
fun readdoc p =
(exists p; readbl p;
File (BinIO.openIn p, fileSize p, mimetype (OS.Path.ext p)))
in
if OS.FileSys.isDir (path3) (*OS.Path.file path3 = ""*) then
(execbl path3;
case List.find (tryindex path3) indexes of
SOME idx => readdoc (OS.Path.concat(path3, idx))
| NONE => String (indexdoc path3, "text/html"))
else if access(path3, []) andalso OS.FileSys.isDir path3 then
raise Directory (OS.Path.concat(path1, ""))
else
readdoc path3
end handle ShutDown => raise ShutDown
| e => Failure e
end
fun send sock vec = (Socket.sendVec(sock, { buf=vec, i=0, sz=NONE }); ())
fun sendstr sock s = send sock (Byte.stringToBytes s)
fun senddoc sock header contents =
(sendstr sock (header (size contents)); sendstr sock contents)
fun addheader sock data =
case data of
String (s, mime) => senddoc sock (okheader mime) s
| File (is, size, mime) =>
((sendstr sock (okheader mime size);
while not (BinIO.endOfStream is) do
send sock (BinIO.inputN(is, 1024)))
handle e => (BinIO.closeIn is; raise e);
BinIO.closeIn is)
| Failure (Directory newpath) => senddoc sock (movpermheader newpath)
(htmldoc "301 Moved permanently" "")
| Failure Forbidden => senddoc sock forbiddenheader
(htmldoc "403 Forbidden" "You have no access to that document.")
| Failure Notfound => senddoc sock notfoundheader
(htmldoc "404 Not found" "The requested URL was not found.")
| Failure Notimplemented => senddoc sock notimplheader
(htmldoc "501 Not implemented"
("The server could not handle your request. Contact "^
"the administrator if you think this is too bad."))
| Failure _ => senddoc sock errorheader
(htmldoc "500 Internal Server Error"
("The server encountered an internal error. Contact "^
"the administrator of the site"))
fun server {port:int,docroot:string}:unit = let
val sock = INetSock.TCP.socket ()
val buf = Word8Array.array(10000, 0w0)
fun gethttprequest sock =
let val got = Socket.recvArr(sock, {buf = buf, i=0, sz=NONE})
in
Byte.unpackString(buf, 0, SOME got)
end
fun next () = let
val (sock', a) = Socket.accept sock
val (addr,_) = INetSock.fromAddr (a)
in
log (NetHostDB.toString (addr)); log " ["; log (date()); log "] ";
(addheader sock' (response docroot (gethttprequest sock')))
handle Fail s => print ("[" ^ s ^ "]")
| ShutDown => (Socket.close sock'; raise ShutDown);
Socket.close sock';
next ()
end
val saveIntHandler = Sig.inqHandler Sig.sigINT
in
SMLofNJ.Cont.callcc
(fn (doneK) =>
(ignore (Sig.setHandler (Sig.sigINT, Sig.HANDLER (fn _ => doneK)));
Socket.bind(sock, INetSock.any port);
Socket.listen(sock, 150);
log "Starting "; log serverName; log " on port ";
log (Int.toString port); log "\n";
(next ()) handle Fail s => print s | ShutDown => log "\n"
));
ignore (Sig.setHandler (Sig.sigINT, saveIntHandler));
log "Shutting down HTTP server\n";
Socket.close sock
end handle Fail s => print ("HTTP server failed: " ^ s ^ "\n");
fun start (port:int): unit = let
val _ = SMLofNJ.Internals.GC.messages false
val current = OS.FileSys.getDir ()
val path = OS.Path.concat (current,"local_pages")
val _ = log ("Serving pages out of \""^path^"\"...\n")
in
server {port=port,docroot=path}
end
end
|