├── .gitignore ├── LICENSE ├── README.md ├── barebones ├── .gitignore ├── chiral.sml ├── main.sml ├── test.cm ├── test.mlb └── test.sml ├── chiralml ├── .gitignore ├── chiralml.cm ├── chiralml.mlb ├── condvar.sig ├── condvar.sml ├── config.sig ├── config.sml ├── introspector │ ├── introspector.cm │ ├── introspector.sml │ └── thread-list.html ├── json-http.sml ├── reactorcore.sig ├── reactorcore.sml ├── sigpipe-mlton.sml ├── sigpipe-smlnj.sml ├── simplehttp.sml ├── sock-util.sml ├── socket.sig ├── socket.sml ├── test.mlb ├── test.sml ├── thread.sig ├── thread.sml ├── threadbase-mlton.sml ├── threadbase-smlnj.sml ├── weak-mlton.sml └── weak-smlnj.sml ├── curl ├── README ├── curl.mlb ├── curl.sig ├── curl.sml └── curl_supereasy.c ├── db ├── .gitignore ├── libmysqlclient │ ├── Makefile │ ├── README │ ├── libmysqlclient-mlton.sml │ ├── libmysqlclient.cm │ ├── libmysqlclient.mlb │ ├── libmysqlclient.sig │ ├── libmysqlclient.sml │ ├── library.sml │ ├── mysql.h │ ├── uchar-mlton.sml │ └── uchar-smlnj.sml ├── sqlite │ ├── Makefile │ ├── library.sml │ ├── sqlite-smlnj.sml │ ├── sqlite.cm │ ├── sqlite.h │ ├── sqlite.mlb │ ├── sqlite.sig │ └── sqlite.sml └── squall │ ├── .gitignore │ ├── Makefile │ ├── README │ ├── cm.sml │ ├── example.squall │ ├── input.grm │ ├── input.lex │ ├── input.sml │ ├── squall-mysql.sml │ ├── squall-sqlite.sml │ ├── squall-standalone.sml │ ├── squall-tool.cm │ ├── squall.cm │ ├── squall.mk │ ├── squall.mlb │ ├── squall.sh │ └── squall.sml ├── hello ├── hello.cm ├── hello.mlb ├── hello.sml ├── lighttpd.conf ├── main.sml └── templates │ ├── hello.html │ └── templates.cm ├── mlmusic ├── .gitignore ├── Makefile ├── browser │ ├── browser.sml │ └── mfbrowser.sml ├── cache.sml ├── chiral.sml ├── clibrowser.sml ├── clisonginfo.sml ├── conf.sml ├── db.sml ├── index │ ├── .gitignore │ ├── Makefile │ ├── format.txt │ ├── index-sqlite.squall │ ├── index.cm │ ├── index.mlb │ ├── index.sml │ ├── index.squall │ ├── pack-compat.sml │ └── search.sml ├── jsonrpc.sml ├── lighttpd.conf ├── main.sml ├── mlton-static-libgmp ├── music-nobrowse.mlb ├── music.cm ├── music.mlb ├── music.sml ├── music.squall ├── music2.cm ├── mysql-mods.sql ├── pagebar.sml ├── request.sml ├── search.sml ├── sing-wrapper.sh ├── squeezecenter │ ├── cli.sml │ ├── command.sml │ ├── player.sml │ └── playercache.sml ├── startup.sml ├── static │ ├── .htaccess │ ├── blank.html │ ├── css │ │ ├── sing-browse.css │ │ ├── sing.css │ │ └── sing2a.css │ ├── home.html │ ├── images │ │ ├── b_add.gif │ │ ├── b_play.gif │ │ ├── background.png │ │ ├── browse.gif │ │ ├── controls.gif │ │ ├── handle.gif │ │ ├── handle2.psd │ │ ├── icns.png │ │ ├── icns.psd │ │ └── volume_levels.gif │ └── js │ │ ├── .gitignore │ │ ├── Makefile │ │ ├── jquery-1.2.6.min.js │ │ ├── jquery-ui-personalized-1.5.2.js │ │ ├── jsmin.py │ │ └── sing.js ├── templates │ ├── index.html │ ├── item.html │ ├── list.html │ ├── playlist.html │ ├── search.html │ ├── song.html │ ├── templates.cm │ └── templates.mlb └── templates2 │ ├── .gitignore │ ├── albumitem.html │ ├── artistitem.html │ ├── buttons.html │ ├── folderitem.html │ ├── index.html │ ├── item.html │ ├── list.html │ ├── playlist.html │ ├── search.html │ ├── topbar.html │ └── trackitem.html ├── smelt ├── .gitignore ├── Makefile ├── README ├── cm.sml ├── example.html ├── smelt-standalone.sml ├── smelt-tool.cm ├── smelt.cm ├── smelt.mk ├── smelt.mlb ├── smelt.sh ├── smelt.sml ├── templateattr.sig ├── templateattr.sml ├── templatecompiler.sig ├── templatecompiler.sml ├── templategen.sig ├── templategen.sml └── tinyxml │ ├── .gitignore │ ├── nqx.lex │ ├── tinyxml.cm │ ├── tinyxml.mlb │ ├── tinyxml.sml │ ├── tinyxml_parser.sig │ └── tinyxml_parser.sml ├── util ├── .gitignore ├── gc-mlton.sml ├── gc-smlnj.sml ├── json.sml ├── linereader.sml ├── rope.cm ├── rope.sig ├── rope.sml ├── stream.sml ├── timer.sml ├── unicode-util.sml └── wrapper.c ├── web ├── .gitignore ├── README ├── form.sig ├── form.sml ├── http-date.sml ├── pack-compat.sml ├── server │ ├── .gitignore │ ├── cgi.sml │ ├── fastcgi-common.sml │ ├── fastcgi-mlton.sml │ ├── fastcgi-server.sml │ ├── http-handler-fn.sml │ ├── http-server-fn.sml │ ├── http-server.sml │ └── scgi-server.sml ├── static-server.sml ├── web-util.sig ├── web-util.sml ├── web.cm ├── web.mlb └── web.sml └── wiki ├── .gitignore ├── chiral.sml ├── lighttpd.conf ├── main.sml ├── templates ├── edit.html ├── page.html └── templates.cm ├── wiki-mysql.ddl ├── wiki-sqlite.ddl ├── wiki.cm ├── wiki.mlb ├── wiki.sml └── wiki.squall /.gitignore: -------------------------------------------------------------------------------- 1 | *.html.sml 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008 - 2010, Jacob Potter 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | - Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | - Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | - Ihe name of the author may not be used to endorse or promote products derived 13 | from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 19 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 22 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | SML On Stilts 2 | ============= 3 | 4 | Stilts is a framework for robust web development based on multistage 5 | programming. Rather than performing extensive introspection and processing at 6 | runtime, Stilts compiles portions of the application together in multiple 7 | passes to ensure strict correctness between components. For example, templates 8 | are never parsed on the fly; instead, they are pre-serialized as much as 9 | possible into code. Type-checking all invocations of the template ensures that 10 | the application always passes templates the parameters they expect. Similarly, 11 | SQL statements are wrapped together with their input and output types, and 12 | escaping code inserted automatically. 13 | 14 | The framework is written in [Standard ML](http://en.wikipedia.org/wiki/Standard_ML). Both 15 | [SML/NJ](http://www.smlnj.org/) and [MLton](http://mlton.org) are supported, with parallel CM 16 | and ML Basis build systems. 17 | 18 | Components 19 | ---------- 20 | - Core Web application types, signatures, and utility functions. 21 | - A high-performance userspace threading system. 22 | - Server implementations of FastCGI, SCGI, and HTTP, allowing Stilts applications to be invoked from a variety of front-end Web servers or as a standalone daemon. 23 | - Smelt, an HTML / XML templating system. 24 | - Squall, a SQL query wrapper function generator. 25 | - Infrastructure for interfacing with MySQL and SQLite. 26 | - A simple Wiki, as a demo application. 27 | 28 | See each component's README file for more documentation. 29 | 30 | Installation 31 | ------------ 32 | Some notes: 33 | 34 | - On debian, you will need to install the following packages in addition to smlnj: 35 | libckit-smlnj libmlnlffi-smlnj ml-nlffigen ml-lex ml-yacc ml-lpt 36 | 37 | - ml-yacc may fail like so: 38 | 39 | Usage: ml-yacc filename 40 | ../db/squall/squall.cm:5.2-5.11 Error: tool "ML-Yacc" failed: "/usr/lib/smlnj/bin/ml-yacc" "" "input.grm" 41 | 42 | Run ml-yacc filename by hand. (Argh, SML/NJ.) 43 | -------------------------------------------------------------------------------- /barebones/.gitignore: -------------------------------------------------------------------------------- 1 | .cm 2 | -------------------------------------------------------------------------------- /barebones/chiral.sml: -------------------------------------------------------------------------------- 1 | structure TH = Thread (structure T = ThreadBase 2 | structure RC = SelectReactorCore 3 | structure C = ConfigPrintEverything) 4 | 5 | structure CV = CondVar(TH) 6 | structure CS = ChiralSocketFn(TH) 7 | structure SU = ChiralSockUtil(CS) 8 | structure LR = LineReader(CS.Socket) 9 | 10 | structure CHTTPServer = HTTPServerFn(structure CS = CS structure T = TH) 11 | 12 | -------------------------------------------------------------------------------- /barebones/main.sml: -------------------------------------------------------------------------------- 1 | val _ = Test.main () 2 | -------------------------------------------------------------------------------- /barebones/test.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/basis.cm 3 | $/regexp-lib.cm 4 | 5 | ../web/web.cm 6 | 7 | ../chiralml/chiralml.cm 8 | ../web/server/http-server-fn.sml 9 | chiral.sml 10 | 11 | ../chiralml/introspector/introspector.cm 12 | 13 | test.sml 14 | -------------------------------------------------------------------------------- /barebones/test.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | 3 | ../smelt/tinyxml/tinyxml.mlb 4 | ../web/web.mlb 5 | 6 | ../chiralml/chiralml.mlb 7 | ../web/server/http-server-fn.sml 8 | chiral.sml 9 | 10 | ../chiralml/introspector/thread-list.html.sml 11 | ../chiralml/introspector/introspector.sml 12 | 13 | test.sml 14 | main.sml 15 | -------------------------------------------------------------------------------- /barebones/test.sml: -------------------------------------------------------------------------------- 1 | structure Test = struct 2 | 3 | structure U = WebUtil 4 | 5 | structure I = Introspector(structure T = TH) 6 | 7 | fun handler (req: Web.request) = (case U.postpath req of 8 | 9 | nil => U.resp "text/plain" "lol" 10 | | [ "" ] => U.resp "text/plain" "lol" 11 | 12 | | [ "introspector", "" ] => I.app req 13 | 14 | | _ => raise U.notFound 15 | ) 16 | 17 | val app = U.dumpRequestWrapper print (U.exnWrapper handler) 18 | 19 | fun main _ = let 20 | val () = print "Listening...\n" 21 | val serverthread = CHTTPServer.spawn_server (INetSock.any 5124) app 22 | in 23 | TH.run (); 24 | 0 25 | end 26 | 27 | end 28 | 29 | 30 | structure FHandler = HTTPHandlerFn(structure S = CS.Socket val can_keep_alive = true val server_name = "f") 31 | 32 | val s = HTTPServer.serve 33 | -------------------------------------------------------------------------------- /chiralml/.gitignore: -------------------------------------------------------------------------------- 1 | .cm 2 | -------------------------------------------------------------------------------- /chiralml/chiralml.cm: -------------------------------------------------------------------------------- 1 | Library 2 | signature THREAD_CONFIG 3 | structure ConfigPrintEverything 4 | structure ConfigNoPrint 5 | 6 | structure ChiralCommon 7 | signature THREAD_COMMON 8 | signature THREAD 9 | 10 | structure ThreadBase 11 | 12 | signature REACTOR_CORE 13 | structure SelectReactorCore 14 | 15 | structure SIGPIPE 16 | structure Weak 17 | 18 | functor Thread 19 | 20 | signature CHIRAL_SOCKET 21 | functor ChiralSocketFn 22 | functor ChiralSockUtil 23 | 24 | signature CONDVAR 25 | functor CondVar 26 | is 27 | $/basis.cm 28 | $/smlnj-lib.cm 29 | $/inet-lib.cm 30 | config.sig 31 | config.sml 32 | thread.sig 33 | threadbase-smlnj.sml 34 | reactorcore.sig 35 | reactorcore.sml 36 | sigpipe-smlnj.sml 37 | weak-smlnj.sml 38 | thread.sml 39 | socket.sig 40 | socket.sml 41 | sock-util.sml 42 | condvar.sig 43 | condvar.sml 44 | -------------------------------------------------------------------------------- /chiralml/chiralml.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | $(SML_LIB)/basis/mlton.mlb 3 | $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb 4 | $(SML_LIB)/smlnj-lib/INet/inet-lib.mlb 5 | 6 | config.sig 7 | config.sml 8 | thread.sig 9 | threadbase-mlton.sml 10 | reactorcore.sig 11 | reactorcore.sml 12 | sigpipe-mlton.sml 13 | weak-mlton.sml 14 | thread.sml 15 | socket.sig 16 | socket.sml 17 | sock-util.sml 18 | condvar.sig 19 | condvar.sml 20 | ../util/linereader.sml 21 | -------------------------------------------------------------------------------- /chiralml/condvar.sig: -------------------------------------------------------------------------------- 1 | signature CONDVAR = sig 2 | 3 | type t 4 | 5 | val new: unit -> t 6 | 7 | val wait: t -> unit 8 | val signal: t -> bool 9 | val broadcast: t -> int 10 | 11 | end 12 | -------------------------------------------------------------------------------- /chiralml/condvar.sml: -------------------------------------------------------------------------------- 1 | functor CondVar(T: THREAD) :> CONDVAR = struct 2 | 3 | type t = T.thread Fifo.fifo ref 4 | 5 | fun new () = ref Fifo.empty 6 | 7 | fun wait cv = (cv := Fifo.enqueue (!cv, T.self ()); 8 | T.deschedule ()) 9 | 10 | fun signal cv = 11 | case Fifo.next (!cv) of NONE => false 12 | | SOME (t', cv') => (cv := cv'; 13 | T.make_runnable t'; 14 | true) 15 | 16 | fun broadcast cv = 17 | Fifo.foldl (fn (t, num) => (T.make_runnable t; num + 1)) 0 (!cv) 18 | before cv := Fifo.empty 19 | 20 | end 21 | -------------------------------------------------------------------------------- /chiralml/config.sig: -------------------------------------------------------------------------------- 1 | signature THREAD_CONFIG = sig 2 | datatype tracetype = REACTOR | THREAD | SCHEDULE | ERROR 3 | val trace : tracetype -> (unit -> string) -> unit 4 | end 5 | -------------------------------------------------------------------------------- /chiralml/config.sml: -------------------------------------------------------------------------------- 1 | structure ConfigPrintEverything :> THREAD_CONFIG = struct 2 | datatype tracetype = REACTOR | THREAD | SCHEDULE | ERROR 3 | fun trace REACTOR f = print ("Reactor: " ^ f () ^ "\n") 4 | | trace THREAD f = print ("Thread: " ^ f () ^ "\n") 5 | | trace SCHEDULE f = print ("Schedule: " ^ f () ^ "\n") 6 | | trace ERROR f = print ("Error: " ^ f () ^ "\n") 7 | end 8 | 9 | structure ConfigNoPrint :> THREAD_CONFIG = struct 10 | datatype tracetype = REACTOR | THREAD | SCHEDULE | ERROR 11 | fun trace _ _ = () 12 | end 13 | -------------------------------------------------------------------------------- /chiralml/introspector/introspector.cm: -------------------------------------------------------------------------------- 1 | Library 2 | functor Introspector 3 | is 4 | $/basis.cm 5 | $/smlnj-lib.cm 6 | 7 | ../../web/web.cm 8 | ../chiralml.cm 9 | 10 | ../../smelt/smelt-tool.cm : tool 11 | thread-list.html 12 | 13 | introspector.sml 14 | -------------------------------------------------------------------------------- /chiralml/introspector/introspector.sml: -------------------------------------------------------------------------------- 1 | functor Introspector( 2 | structure T: THREAD 3 | ) :> sig 4 | val app : Web.app 5 | end = 6 | struct 7 | 8 | fun app req = let 9 | val threads = T.get_threads () 10 | 11 | fun map_thread thr = ( 12 | T.get_id thr, 13 | T.get_state thr 14 | ) 15 | in 16 | WebUtil.htmlResp ( 17 | IntrospectorThreadList.render { threads = map map_thread threads } 18 | ) 19 | end 20 | 21 | end 22 | -------------------------------------------------------------------------------- /chiralml/introspector/thread-list.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Chiral Introspector 5 | 6 | 7 |

Chiral Introspector

8 |

Threads:

9 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /chiralml/json-http.sml: -------------------------------------------------------------------------------- 1 | structure J = JSON 2 | 3 | val test = J.Object (foldl J.Map.insert' J.Map.empty [ 4 | ("channel", J.String "/meta/handshake"), 5 | ("version", J.String "1.0"), 6 | ("supportedConnectionTypes", J.Array [ J.String "streaming" ]) 7 | ]) 8 | 9 | 10 | val test2 = J.Object (foldl J.Map.insert' J.Map.empty [ 11 | ("id", J.Number 1), 12 | ("method", J.String "slim.request"), 13 | ("params", J.Array [ 14 | J.String "00:04:20:1e:00:50", 15 | J.Array [ 16 | J.String "status", 17 | J.String "-", 18 | J.Number 1, 19 | J.String "tags:uB", 20 | J.String "menu:menu" 21 | ] 22 | ]) 23 | ]) 24 | 25 | val test2 = J.Object (foldl J.Map.insert' J.Map.empty [ 26 | ("id", J.Number 1), 27 | ("method", J.String "slim.request"), 28 | ("params", J.Array [ 29 | J.String "00:04:20:1e:00:50", 30 | J.Array [ 31 | J.String "artists", 32 | J.Number 0, 33 | J.Number 1000, 34 | J.String "menu:album" 35 | ] 36 | ]) 37 | ]) 38 | 39 | (* 40 | structure T = Thread (structure T = ThreadBase 41 | structure RC = SelectReactorCore) 42 | structure CS = ChiralSocketFn(T) 43 | *) 44 | structure HC = SimpleHTTPConnection(structure Socket = Socket structure INetSock = INetSock) 45 | 46 | val conn = HC.new "blackbox.res.cmu.edu:9000" 47 | 48 | 49 | fun cometd_request conn reqs = let 50 | val body = HC.request conn ("/cometd", 51 | [("Content-Type", "text/json")], 52 | SOME (J.fmt (J.Array reqs))) 53 | val rjson = case JSON.fromString body of 54 | NONE => raise Fail "response not json" 55 | | SOME json => json 56 | in 57 | case rjson of JSON.Array arr => arr 58 | | _ => raise Fail "expected json array result" 59 | end 60 | 61 | 62 | (* val res = cometd_request conn [ test ] 63 | *) 64 | 65 | val response : string ref = ref "" 66 | fun rpc_request conn req = let 67 | val timer = PrettyTimer.start () 68 | val body = HC.request conn ("/jsonrpc.js", 69 | [("Content-Type", "text/json")], 70 | SOME (J.fmt req)) 71 | val () = print ("JSONRPC: request " ^ PrettyTimer.print timer ^ "; " 72 | ^ Int.toString (size body) ^ " bytes\n") 73 | val timer = PrettyTimer.start () 74 | val () = response := body 75 | val rjson = case JSON.fromString body of 76 | NONE => raise Fail "response not json" 77 | | SOME json => json 78 | val () = print ("JSONRPC: JSON parse " ^ PrettyTimer.print timer ^ "\n") 79 | in 80 | rjson 81 | end 82 | val () = print (J.fmt test2) 83 | val res2 = rpc_request conn test2 84 | (* 85 | 86 | val i = case res2 of J.Object m => J.Map.listItemsi m 87 | 88 | val res = case res2 of J.Object m => J.Map.find (m, "result") 89 | 90 | val resitems = case res of SOME (J.Object m) => J.Map.listItemsi m 91 | *) 92 | -------------------------------------------------------------------------------- /chiralml/reactorcore.sig: -------------------------------------------------------------------------------- 1 | (* Chiral/ML, Copyright (c) 2008 Jacob Potter. 2 | * 3 | * signature REACTOR_CORE 4 | * 5 | * This is the interface for reactor backends, using a system-specific socket 6 | * polling primitive such as select(). The Reactor functor receives a suitable 7 | * reactor core inplementation as input. 8 | * 9 | * Since this is largely an OS-interface structure, it is imperative; the 10 | * add_sock and wait functions take an 'a state and mutate it as necessary. 11 | * 12 | *) 13 | signature REACTOR_CORE = sig 14 | 15 | type 'a state 16 | 17 | val init: unit -> 'a state 18 | (* 19 | * Create a new, empty state with no sockets registered. 20 | *) 21 | 22 | val add_sock: 'a state -> 'a * ChiralCommon.block_cond * Socket.sock_desc 23 | -> unit 24 | (* 25 | * Register interest in a socket. The next call to 'wait' will include the 26 | * given socket in the list of sockets to be monitored. The socket stays 27 | * registered until its block condition has been triggered. 28 | * 29 | * A given socket should not be registered more than once with the same 30 | * wait condition. 31 | *) 32 | 33 | val wait: 'a state -> Time.time option -> 'a list option 34 | (* 35 | * Wait for socket activity or for a timeout. 36 | * 37 | * If the timeout is NONE, and no sockets are currently registered for event 38 | * handling, this will immediately return NONE (rather than waiting forever, 39 | * which would otherwise occur). 40 | * 41 | * Otherwise, the function blocks until either (a) activity occurs on a 42 | * socket which was registered with add_sock, or (b) the timeout passes (if 43 | * not NONE). Then, SOME alphalist is returned; the values passed back are 44 | * those which were originally given to add_sock for the corresponding 45 | * sockets. 46 | * 47 | * If the timeout passes with no socket activity, wait will return SOME nil. 48 | *) 49 | 50 | end 51 | 52 | -------------------------------------------------------------------------------- /chiralml/reactorcore.sml: -------------------------------------------------------------------------------- 1 | structure SelectReactorCore :> REACTOR_CORE = struct 2 | 3 | structure CC = ChiralCommon 4 | 5 | type 'a sock_block_info = 'a * CC.block_cond * Socket.sock_desc 6 | type 'a state = 'a sock_block_info list ref 7 | 8 | fun init () = ref nil 9 | 10 | fun add_sock state (e, cond, desc) = 11 | state := (e, cond, desc) :: !state 12 | 13 | fun rdwr_fold ((_, CC.BLOCK_RD, sock), (rd, wr)) = (sock :: rd, wr) 14 | | rdwr_fold ((_, CC.BLOCK_WR, sock), (rd, wr)) = (rd, sock :: wr) 15 | 16 | fun wait (ref nil) NONE = NONE 17 | | wait state timeout = let 18 | 19 | val bt = !state 20 | 21 | val (rd, wr) = foldl rdwr_fold (nil, nil) bt 22 | 23 | val tstr = case timeout of 24 | NONE => "no" 25 | | SOME t => IntInf.toString (Time.toMilliseconds t) ^ " ms" 26 | 27 | val () = print (" select(): waiting on " ^ Int.toString (length rd) 28 | ^ " read, " ^ Int.toString (length wr) ^ " write, " 29 | ^ tstr ^ " timeout.\n"); 30 | 31 | val sparam = { rds = rev rd, wrs = rev wr, 32 | exs = nil, timeout = timeout } 33 | 34 | val { rds, wrs, exs } = (Socket.select sparam 35 | handle e => raise e) 36 | 37 | val () = print (" select(): returned " ^ Int.toString (length rds) 38 | ^ " read, " ^ Int.toString (length wrs) ^ " write\n"); 39 | 40 | fun res_fold (i as (ent, CC.BLOCK_RD, sock), (nil, wrs, out, rem)) = 41 | (nil, wrs, out, i :: rem) 42 | | res_fold (i as (ent, CC.BLOCK_RD, sock), (r::rds, wrs, out, rem)) = 43 | if Socket.sameDesc (sock, r) 44 | then (rds, wrs, ent::out, rem) 45 | else (r::rds, wrs, out, i :: rem) 46 | | res_fold (i as (ent, CC.BLOCK_WR, sock), (rds, nil, out, rem)) = 47 | (rds, nil, out, i :: rem) 48 | | res_fold (i as (ent, CC.BLOCK_WR, sock), (rds, w::wrs, out, rem)) = 49 | if Socket.sameDesc (sock, w) 50 | then (rds, wrs, ent::out, rem) 51 | else (rds, w::wrs, out, i :: rem) 52 | val (urds, uwrs, out, rem) = foldl res_fold (rds, wrs, nil, nil) bt 53 | 54 | val () = case (urds, uwrs) of (nil, nil) => () 55 | | _ => raise Fail "unmatched select result" 56 | 57 | val () = state := rev rem 58 | in 59 | SOME out 60 | end 61 | 62 | end 63 | -------------------------------------------------------------------------------- /chiralml/sigpipe-mlton.sml: -------------------------------------------------------------------------------- 1 | structure SIGPIPE = struct 2 | fun ignore () = (MLton.Signal.setHandler (Posix.Signal.pipe, 3 | MLton.Signal.Handler.ignore); 4 | ()) 5 | end 6 | -------------------------------------------------------------------------------- /chiralml/sigpipe-smlnj.sml: -------------------------------------------------------------------------------- 1 | structure SIGPIPE = struct 2 | fun ignore () = (Signals.setHandler (UnixSignals.sigPIPE, Signals.IGNORE); 3 | ()) 4 | end 5 | -------------------------------------------------------------------------------- /chiralml/simplehttp.sml: -------------------------------------------------------------------------------- 1 | functor SimpleHTTPConnection (CS : CHIRAL_SOCKET) :> sig 2 | type t 3 | val new: string -> t 4 | val new': INetSock.inet Socket.sock_addr -> t 5 | val request: t -> string * (string * string) list * string option -> string 6 | end 7 | = struct 8 | structure S = CS.Socket 9 | structure SU = ChiralSockUtil(CS) 10 | structure INS = CS.INetSock 11 | structure LR = LineReader(S) 12 | 13 | type t = S.active INS.stream_sock * LR.reader 14 | 15 | fun new' target = let 16 | val sock = INS.TCP.socket () 17 | val () = S.connect (sock, target) 18 | in 19 | (sock, LR.new (sock, { increment = 8192, stripCR = true })) 20 | end 21 | 22 | fun new target = let 23 | val hp = case SockUtil.addrFromString target of 24 | NONE => raise Fail "unable to parse address" 25 | | SOME hp => hp 26 | 27 | val { addr, port, ... } = SockUtil.resolveAddr hp 28 | val port = case port of SOME p => p 29 | | NONE => raise Fail "port required" 30 | in 31 | new' (INS.toAddr (addr, port)) 32 | end 33 | 34 | 35 | fun format_header (k, v) = k ^ ": " ^ v ^ "\r\n" 36 | 37 | fun format_get headers path = 38 | "GET " ^ path ^ " HTTP/1.0\r\nUser-Agent: ChiralML/0.0\r\n" 39 | ^ headers ^ "\r\n" 40 | 41 | fun format_post headers path pdata = 42 | "POST " ^ path ^ " HTTP/1.0\r\nUser-Agent: ChiralML/0.0\r\n" 43 | ^ "Content-Length: " ^ Int.toString (size pdata) ^ "\r\n" ^ headers 44 | ^ "\r\n" ^ pdata 45 | 46 | fun request (conn, lr) (path, headers, postdata) = let 47 | val headers' = String.concat (map format_header headers) 48 | 49 | val req = case postdata of NONE => format_get headers' path 50 | | SOME pd => format_post headers' path pd 51 | 52 | val () = SU.sendVec (conn, Byte.stringToBytes req) 53 | 54 | val content_length : string option ref = ref NONE 55 | 56 | fun read_headers acc = ( 57 | case Byte.bytesToString (LR.readline lr) of 58 | "" => acc 59 | | line => let 60 | val (sk, sv) = Substring.splitl (fn c => c <> #":") 61 | (Substring.full line) 62 | fun dropf #":" = true 63 | | dropf c = Char.isSpace c 64 | val k = Substring.string sk 65 | val v = Substring.string (Substring.dropl dropf sv) 66 | in 67 | ( case String.map Char.toUpper k of 68 | "CONTENT-LENGTH" => content_length := SOME v 69 | | _ => ()); 70 | read_headers ((k, v) :: acc) 71 | end) 72 | 73 | val headers = rev (read_headers nil) 74 | 75 | val content = case !content_length of 76 | NONE => raise Fail "expected content-length" 77 | | SOME lengthstr => case Int.fromString lengthstr of 78 | NONE => raise Fail "invalid content-length" 79 | | SOME length => Byte.bytesToString (LR.readbytes lr length) 80 | 81 | in 82 | content 83 | end 84 | end 85 | -------------------------------------------------------------------------------- /chiralml/sock-util.sml: -------------------------------------------------------------------------------- 1 | (* ChiralSockUtil 2 | * 3 | * Based on sock-util.sml from SML/NJ distribution. 4 | * 5 | * COPYRIGHT (c) 1996 AT&T Research. 6 | * 7 | * Various utility functions for programming with sockets. 8 | *) 9 | 10 | functor ChiralSockUtil (S: CHIRAL_SOCKET) :> sig 11 | 12 | datatype port = PortNumber of int | ServName of string 13 | datatype hostname = HostName of string | HostAddr of NetHostDB.in_addr 14 | val scanAddr : (char, 'a) StringCvt.reader 15 | -> ({host : hostname, port : port option}, 'a) StringCvt.reader 16 | val addrFromString : string -> {host : hostname, port : port option} option 17 | exception BadAddr of string 18 | val resolveAddr : {host : hostname, port : port option} 19 | -> {host : string, addr : NetHostDB.in_addr, port : int option} 20 | type 'a stream_sock = ('a, S.Socket.active S.Socket.stream) S.Socket.sock 21 | val connectINetStrm : {addr : NetHostDB.in_addr, port : int} 22 | -> S.INetSock.inet stream_sock 23 | val recvVec : ('a stream_sock * int) -> Word8Vector.vector 24 | val recvStr : ('a stream_sock * int) -> string 25 | val sendVec : ('a stream_sock * Word8Vector.vector) -> unit 26 | val sendStr : ('a stream_sock * string) -> unit 27 | val sendArr : ('a stream_sock * Word8Array.array) -> unit 28 | 29 | end = struct 30 | 31 | datatype port = datatype SockUtil.port 32 | datatype hostname = datatype SockUtil.hostname 33 | val scanAddr = SockUtil.scanAddr 34 | val addrFromString = SockUtil.addrFromString 35 | exception BadAddr = SockUtil.BadAddr 36 | val resolveAddr = SockUtil.resolveAddr 37 | type 'a stream_sock = ('a, S.Socket.active S.Socket.stream) S.Socket.sock 38 | 39 | (* establish a client-side connection to a INET domain stream socket *) 40 | fun connectINetStrm {addr, port} = let 41 | val sock = S.INetSock.TCP.socket () 42 | in 43 | S.Socket.connect (sock, S.INetSock.toAddr (addr, port)); 44 | sock 45 | end 46 | 47 | (** If the server closes the connection, do we get 0 bytes or an error??? **) 48 | (* read exactly n bytes from a stream socket *) 49 | fun recvVec (sock, n) = let 50 | fun get (0, data) = Word8Vector.concat(rev data) 51 | | get (n, data) = let 52 | val v = S.Socket.recvVec (sock, n) 53 | in 54 | if (Word8Vector.length v = 0) 55 | then raise OS.SysErr("closed socket", NONE) 56 | else get (n - Word8Vector.length v, v::data) 57 | end 58 | in 59 | if (n < 0) then raise Size else get (n, []) 60 | end 61 | 62 | fun recvStr arg = Byte.bytesToString (recvVec arg) 63 | 64 | (* send the complete contents of a vector *) 65 | fun sendVec (sock, vec) = let 66 | val len = Word8Vector.length vec 67 | fun send i = S.Socket.sendVec (sock, 68 | Word8VectorSlice.slice (vec, i, NONE)) 69 | fun put i = if (i < len) 70 | then put(i + send i) 71 | else () 72 | in 73 | put 0 74 | end 75 | 76 | fun sendStr (sock, str) = sendVec (sock, Byte.stringToBytes str) 77 | 78 | (* send the complete contents of an array *) 79 | fun sendArr (sock, arr) = let 80 | val len = Word8Array.length arr 81 | fun send i = S.Socket.sendArr (sock, 82 | Word8ArraySlice.slice (arr, i, NONE)) 83 | fun put i = if (i < len) 84 | then put(i + send i) 85 | else () 86 | in 87 | put 0 88 | end 89 | 90 | end 91 | -------------------------------------------------------------------------------- /chiralml/socket.sig: -------------------------------------------------------------------------------- 1 | signature CHIRAL_SOCKET = sig 2 | 3 | structure Socket : SOCKET 4 | where type 'af sock_addr = 'af Socket.sock_addr 5 | 6 | structure INetSock : sig 7 | type inet = INetSock.inet 8 | type 'sock_type sock = (inet, 'sock_type) Socket.sock 9 | type 'mode stream_sock = 'mode Socket.stream sock 10 | type dgram_sock = Socket.dgram sock 11 | type sock_addr = inet Socket.sock_addr 12 | val inetAF : Socket.AF.addr_family 13 | val toAddr : NetHostDB.in_addr * int -> sock_addr 14 | val fromAddr : sock_addr -> NetHostDB.in_addr * int 15 | val any : int -> sock_addr 16 | structure UDP : sig 17 | val socket : unit -> dgram_sock 18 | val socket' : int -> dgram_sock 19 | end 20 | structure TCP : sig 21 | val socket : unit -> 'mode stream_sock 22 | val socket' : int -> 'mode stream_sock 23 | val getNODELAY : 'mode stream_sock -> bool 24 | val setNODELAY : 'mode stream_sock * bool -> unit 25 | end 26 | end 27 | 28 | end 29 | -------------------------------------------------------------------------------- /chiralml/test.mlb: -------------------------------------------------------------------------------- 1 | chiralml.mlb 2 | test.sml 3 | -------------------------------------------------------------------------------- /chiralml/test.sml: -------------------------------------------------------------------------------- 1 | structure T = Thread (structure T = ThreadBase 2 | structure RC = SelectReactorCore) 3 | 4 | fun blarg str () = (print str; T.sleep (Time.fromMilliseconds 1000); blarg str ()) 5 | (* 6 | val mudt = T.new (blarg "Mud\n") 7 | val kipt = T.new (fn () => (T.sleep (Time.fromMilliseconds 500); blarg "Kip\n" ())) 8 | 9 | *) 10 | (* 11 | val bthr : T.thread option ref = ref NONE 12 | 13 | fun afun () = (print "Arg\n"; 14 | T.make_runnable (Option.valOf (!bthr)) 15 | handle T.AlreadyRunnable => (print "Already Blarg?\n"; ()); 16 | T.deschedule (); 17 | afun ()) 18 | 19 | val athr = T.new afun 20 | 21 | fun bfun () = (print "Blarg\n"; 22 | T.make_runnable athr 23 | handle T.AlreadyRunnable => (print "Already Arg?\n"; ()); 24 | T.deschedule (); 25 | bfun ()) 26 | 27 | val () = bthr := SOME (T.new bfun); 28 | 29 | val _ = T.run () 30 | *) 31 | 32 | 33 | 34 | structure CS = ChiralSocketFn(T) 35 | structure SU = ChiralSockUtil(CS) 36 | structure LR = LineReader(CS.Socket) 37 | 38 | fun serveConn (conn, conn_addr) () = let 39 | val r = LR.new (conn, { increment = 1024, stripCR = true }) 40 | fun lineLoop () = let 41 | val () = print "T: reading line\n" 42 | val line = LR.readline r 43 | (* 44 | val () = print "T: read line; sleeping\n" 45 | val () = T.sleep (Time.fromMilliseconds 200) 46 | *) 47 | val () = print "T: slept; sending\n" 48 | val () = SU.sendVec (conn, line) 49 | val () = print "T: slept; sending newline\n" 50 | val () = SU.sendVec (conn, Byte.stringToBytes "\n") 51 | handle e => (print "aw shiiiiiiit\n"; raise e) 52 | val () = print "T: done\n" 53 | in 54 | lineLoop () 55 | end 56 | in 57 | lineLoop () 58 | end 59 | 60 | fun serve addr () = 61 | let 62 | val listener = CS.INetSock.TCP.socket () 63 | 64 | val (server_host, server_port) = INetSock.fromAddr addr 65 | val sbind = (NetHostDB.toString server_host, server_port) 66 | 67 | fun accept () = let 68 | val conn = CS.Socket.accept listener 69 | in 70 | T.new (serveConn conn); 71 | accept () 72 | end 73 | in 74 | ( 75 | CS.Socket.Ctl.setREUSEADDR (listener, true); 76 | CS.Socket.bind (listener, addr); 77 | CS.Socket.listen (listener, 9); 78 | accept () 79 | ) handle x => (CS.Socket.close listener; raise x) 80 | end 81 | 82 | val listent = T.new (serve (INetSock.any 1234)) 83 | val _ = T.run(); 84 | 85 | -------------------------------------------------------------------------------- /chiralml/thread.sig: -------------------------------------------------------------------------------- 1 | structure ChiralCommon = struct 2 | 3 | datatype block_cond = BLOCK_RD | BLOCK_WR 4 | 5 | datatype state = RUNNING 6 | | RUNNABLE 7 | | DESCHEDULED of string 8 | | BLOCKED of block_cond 9 | | SLEEPING of Time.time 10 | | FINISHED 11 | | FAILED of exn 12 | 13 | fun condToStr BLOCK_RD = "read" 14 | | condToStr BLOCK_WR = "write" 15 | 16 | fun stateToStr (RUNNABLE) = "runnable" 17 | | stateToStr (RUNNING) = "running" 18 | | stateToStr (DESCHEDULED str) = "descheduled on " ^ str 19 | | stateToStr (BLOCKED cond) = "blocked on socket " ^ condToStr cond 20 | | stateToStr (SLEEPING t) = "sleeping for " ^ Time.toString (Time.- (t, Time.now ())) ^ " s" 21 | | stateToStr (FINISHED) = "finished" 22 | | stateToStr (FAILED e) = "failed with " ^ General.exnMessage e 23 | 24 | end 25 | 26 | signature THREAD_COMMON = sig 27 | 28 | type 'a t 29 | type 'a runnable 30 | 31 | val new: ('a -> unit) -> 'a t 32 | val prepare: 'a t * 'a -> 'a runnable 33 | val switch: ('a t -> 'a runnable) -> 'a 34 | 35 | end 36 | 37 | signature THREAD = sig 38 | 39 | exception NotRunning 40 | exception BadState of ChiralCommon.state 41 | 42 | type thread 43 | 44 | val block: ('af, 't) Socket.sock * ChiralCommon.block_cond -> unit 45 | val sleep: Time.time -> unit 46 | val wake: thread -> unit 47 | 48 | val new: (unit -> unit) -> thread 49 | val kill: thread -> exn -> unit 50 | 51 | val deschedule: unit -> unit 52 | val make_runnable: thread -> unit 53 | val self: unit -> thread 54 | 55 | val run: unit -> unit 56 | 57 | val get_threads: unit -> thread list 58 | val get_thread: int -> thread option 59 | val get_id: thread -> int 60 | val get_state: thread -> ChiralCommon.state 61 | 62 | end 63 | -------------------------------------------------------------------------------- /chiralml/threadbase-mlton.sml: -------------------------------------------------------------------------------- 1 | structure ThreadBase :> THREAD_COMMON = struct 2 | 3 | type 'a t = 'a MLton.Thread.t 4 | type 'a runnable = MLton.Thread.Runnable.t 5 | val new = MLton.Thread.new 6 | val prepare = MLton.Thread.prepare 7 | val switch = MLton.Thread.switch 8 | 9 | end 10 | -------------------------------------------------------------------------------- /chiralml/threadbase-smlnj.sml: -------------------------------------------------------------------------------- 1 | structure ThreadBase :> THREAD_COMMON = struct 2 | 3 | type 'a t = 'a SMLofNJ.Cont.cont 4 | type 'a runnable = 'a 5 | val new = SMLofNJ.Cont.isolate 6 | fun prepare (thread, arg) = SMLofNJ.Cont.throw thread arg 7 | val switch = SMLofNJ.Cont.callcc 8 | 9 | end 10 | -------------------------------------------------------------------------------- /chiralml/weak-mlton.sml: -------------------------------------------------------------------------------- 1 | structure Weak = MLton.Weak 2 | -------------------------------------------------------------------------------- /chiralml/weak-smlnj.sml: -------------------------------------------------------------------------------- 1 | structure Weak = struct 2 | type 'a t = 'a SMLofNJ.Weak.weak 3 | val new = SMLofNJ.Weak.weak 4 | val get = SMLofNJ.Weak.strong 5 | end 6 | -------------------------------------------------------------------------------- /curl/README: -------------------------------------------------------------------------------- 1 | This attempts to be a very simple interface to libcurl. Pass in your URL, get the data at that URL back. 2 | 3 | Because MLton's build system is half-assed, in order to use this lib you must: 4 | - add "-link-opt -lcurl" to your mlton command line parameters 5 | - add ".../stilts/curl/curl_supereasy.c" after your mlb file on the mlton command line 6 | -------------------------------------------------------------------------------- /curl/curl.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "allowFFI true" 3 | in 4 | $(SML_LIB)/basis/basis.mlb 5 | $(SML_LIB)/basis/mlton.mlb 6 | $(SML_LIB)/basis/c-types.mlb 7 | curl.sig 8 | curl.sml 9 | end 10 | -------------------------------------------------------------------------------- /curl/curl.sig: -------------------------------------------------------------------------------- 1 | signature CURL = sig 2 | val curl : string -> string 3 | end 4 | -------------------------------------------------------------------------------- /curl/curl.sml: -------------------------------------------------------------------------------- 1 | structure Curl :> CURL = struct 2 | 3 | type ptr = MLton.Pointer.t 4 | 5 | fun read_bytes (p, n) = 6 | Word8Vector.tabulate (n, fn i => MLton.Pointer.getWord8 (p, i)) 7 | 8 | fun curl url = 9 | let 10 | val p = 11 | (_import "curl_supereasy" : string -> ptr;) 12 | (url) 13 | 14 | val len = 15 | (_import "curl_supereasy_len" : ptr -> int;) 16 | (p) 17 | 18 | val data = 19 | (_import "curl_supereasy_data" : ptr -> ptr;) 20 | (p) 21 | 22 | val ret = Byte.bytesToString (read_bytes (data, len)) 23 | 24 | val _ = 25 | (_import "curl_supereasy_cleanup" : ptr -> unit;) 26 | (p) 27 | in 28 | ret 29 | end 30 | 31 | end 32 | -------------------------------------------------------------------------------- /curl/curl_supereasy.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | typedef struct 6 | { 7 | char *data; 8 | size_t len; 9 | } 10 | curl_supereasy_data_t; 11 | 12 | size_t curl_supereasy_callback( 13 | void *buffer, 14 | size_t size, 15 | size_t nmemb, 16 | curl_supereasy_data_t *datat) 17 | { 18 | size_t old_len = datat->len; 19 | size_t additional_len = size*nmemb; 20 | 21 | datat->data = realloc(datat->data, old_len + additional_len); 22 | datat->len = old_len + additional_len; 23 | 24 | memcpy(datat->data + old_len, buffer, additional_len); 25 | 26 | return additional_len; 27 | } 28 | 29 | curl_supereasy_data_t* curl_supereasy(char *url) 30 | { 31 | curl_supereasy_data_t *datat = malloc(sizeof(curl_supereasy_data_t)); 32 | datat->data = NULL; 33 | datat->len = 0; 34 | 35 | CURL *curl = curl_easy_init(); 36 | curl_easy_setopt(curl, CURLOPT_URL, url); 37 | curl_easy_setopt(curl, CURLOPT_WRITEFUNCTION, curl_supereasy_callback); 38 | curl_easy_setopt(curl, CURLOPT_WRITEDATA, datat); 39 | curl_easy_perform(curl); 40 | curl_easy_cleanup(curl); 41 | 42 | return datat; 43 | } 44 | 45 | char* curl_supereasy_data(curl_supereasy_data_t *datat) 46 | { 47 | return datat->data; 48 | } 49 | 50 | size_t curl_supereasy_len(curl_supereasy_data_t *datat) 51 | { 52 | return datat->len; 53 | } 54 | 55 | void curl_supereasy_cleanup(curl_supereasy_data_t *datat) 56 | { 57 | free(datat->data); 58 | free(datat); 59 | } 60 | -------------------------------------------------------------------------------- /db/.gitignore: -------------------------------------------------------------------------------- 1 | */.cm 2 | */FFI-* 3 | squall/squall 4 | -------------------------------------------------------------------------------- /db/libmysqlclient/Makefile: -------------------------------------------------------------------------------- 1 | default: FFI-mlton/ffi.mlb 2 | 3 | FFI-mlton/ffi.mlb: mysql.h 4 | mlnlffigen -include ../library.sml -dir FFI-mlton -mlbfile ffi.mlb $^ 5 | 6 | FFI-smlnj/ffi.cm: mysql.h 7 | ml-nlffigen -include ../library.sml -dir FFI-smlnj -cmfile ffi.cm $^ 8 | 9 | clean: 10 | rm -rf FFI-mlton FFI-smlnj .cm libmysqlclient 11 | -------------------------------------------------------------------------------- /db/libmysqlclient/README: -------------------------------------------------------------------------------- 1 | This is a wrapper for accessing MySQL from SML/NJ or MLton. It uses ML-NLFFI 2 | to load the libmysqlclient dynamic library, and then wraps most libmysqlclient 3 | functions as directly as possible. 4 | 5 | Some notes: 6 | 7 | - Although the details of the FFI are not exposed outside of the MySQLClient 8 | structure, it is not entirely memory-safe. Specifically, failing to call 9 | close (on a connection) and free_result (on a result) will result in leaked 10 | memory. In most cases, another layer of wrapper code will be used (i.e. 11 | Squall) which ensures proper cleanup, so this is not a large concern. 12 | 13 | - This uses a clone of the real mysql.h, partially because mysql.h on OS X 14 | on OS X includes system headers with GCC extensions which cause ml-nlffigen 15 | to fail with parse errors. Additionally, the substitute mysql.h allows the 16 | following workaround. 17 | 18 | - SML/NJ's code generator does not directly support 64-bit arithmetic, and 19 | its code generator cannot handle the C calling convention for 64-bit values 20 | on a 32-bit architecture. This is worked around as such: 21 | - mysql_data_seek(), which takes a my_ulonglong parameter, raies Fail. 22 | - The local mysql.h defines a typdef unsigned long my_ulonglong_returned; 23 | mysql_affected_rows(), mysql_insert_id(), and mysql_num_rows() return this. 24 | Although this is essentially an ABI mismatch, the effect (at least on x86) 25 | is that the upper 32 bits will be truncated. Better than nothing. 26 | 27 | - SML/NJ's Compilation Manager will automatically invoke ml-nlffigen (via make) 28 | if necessary. Before using libmysqlclient.mlb with MLton, you must invoke 29 | 'make' in the libmysqlclient directory to generate the bindings. 30 | 31 | 32 | An implementation using MLton's native FFI should be written. It would avoid 33 | the 64-bit incompatibilities with SML/NJ, bypass the massively inelegant need 34 | for a local, modified mysql.h, and be significantly more efficient due to the 35 | design of ML-NLFFI. 36 | 37 | -------------------------------------------------------------------------------- /db/libmysqlclient/libmysqlclient.cm: -------------------------------------------------------------------------------- 1 | Library 2 | signature MYSQLCLIENT 3 | structure MySQLClient 4 | is 5 | $/basis.cm 6 | $c/c.cm 7 | FFI-smlnj/ffi.cm : make () 8 | libmysqlclient.sig 9 | uchar-smlnj.sml 10 | libmysqlclient.sml 11 | -------------------------------------------------------------------------------- /db/libmysqlclient/libmysqlclient.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "allowFFI true" 3 | in 4 | local 5 | $(SML_LIB)/basis/basis.mlb 6 | $(SML_LIB)/basis/mlton.mlb 7 | $(SML_LIB)/basis/unsafe.mlb 8 | $(SML_LIB)/basis/c-types.mlb 9 | libmysqlclient.sig 10 | libmysqlclient-mlton.sml 11 | in 12 | signature MYSQLCLIENT 13 | structure MySQLClient 14 | end 15 | end 16 | -------------------------------------------------------------------------------- /db/libmysqlclient/libmysqlclient.sig: -------------------------------------------------------------------------------- 1 | signature MYSQLCLIENT = sig 2 | 3 | (* This is a fairly direct translation of the MySQL C API. Note that 4 | * functions not used by Squall may be untested. 5 | * 6 | * The function "query_and_result" is an added helper. It performs a query, 7 | * retrieves all the results, and then frees the result set; this uses 8 | * real_query, store_result, and free_result. If the query returned no result 9 | * set (store_result returns NONE), query_and_result returns nil. 10 | *) 11 | 12 | type conn 13 | type result 14 | type row_offset 15 | 16 | type my_ulonglong = Word64.word 17 | 18 | type field = { name: string, 19 | org_name: string, 20 | table: string, 21 | org_table: string, 22 | db: string, 23 | catalog: string, 24 | def: string option, 25 | length: Word32.word, 26 | max_length: Word32.word, 27 | flags: Word32.word, 28 | decimals: Word32.word, 29 | charsetnr: Word32.word } 30 | 31 | type connect_info = { host: string option, 32 | user: string option, 33 | password: string option, 34 | db: string option, 35 | port: Word32.word, 36 | unix_socket: string option } 37 | 38 | exception MySQLException of Word32.word * string 39 | exception MySQLClosed 40 | 41 | val my_init: unit -> unit 42 | 43 | val affected_rows: conn -> my_ulonglong 44 | val autocommit: conn -> bool -> unit 45 | val change_user: conn -> { user: string, 46 | password: string, 47 | db: string option } -> unit 48 | val character_set_name: conn -> string 49 | val close: conn -> unit 50 | val commit: conn -> unit 51 | val data_seek: result -> my_ulonglong -> unit 52 | val debug: string -> unit 53 | val dump_debug_info: conn -> unit 54 | val errno: conn -> Word32.word 55 | val error: conn -> string 56 | val fetch_field: result -> field option 57 | val fetch_field_direct: result -> int -> field 58 | val fetch_lengths: result -> Word32.word list 59 | val fetch_row: result -> string option list option 60 | val field_seek: result -> int -> int 61 | val field_tell: result -> int 62 | val free_result: result -> unit 63 | val info: conn -> string 64 | val init: unit -> conn 65 | val insert_id: conn -> my_ulonglong 66 | val num_fields: result -> int 67 | val num_rows: result -> my_ulonglong 68 | val ping: conn -> unit 69 | val real_connect: conn -> connect_info -> unit 70 | val real_escape_string: conn -> string -> string 71 | val real_query: conn -> string -> unit 72 | val rollback: conn -> unit 73 | val row_seek: result -> row_offset -> row_offset 74 | val row_tell: result -> row_offset 75 | val select_db: conn -> string -> unit 76 | val set_character_set: conn -> string -> unit 77 | val sqlstate: conn -> string 78 | val ssl_set: conn -> { key: string option, 79 | cert: string option, 80 | ca: string option, 81 | capath: string option, 82 | cipher: string option } -> unit 83 | val stat: conn -> string 84 | val store_result: conn -> result option 85 | val thread_id: conn -> Word32.word 86 | val use_result: conn -> result option 87 | 88 | val set_reconnect: conn -> bool -> unit 89 | 90 | val query_and_result: conn * string -> string option list list 91 | 92 | end 93 | -------------------------------------------------------------------------------- /db/libmysqlclient/library.sml: -------------------------------------------------------------------------------- 1 | (* The ML-NLFFI generated code depends on this structure. It dynamically loads 2 | libmysqlclient on program startup, and provides hooks for the generated code 3 | to look up functions. 4 | *) 5 | 6 | structure Library = struct 7 | local 8 | val libs = [ "libmysqlclient.so", "libmysqlclient.so.15", "libmysqlclient.dylib" ] 9 | 10 | fun tryLib nil = raise Fail ("could not load any of " 11 | ^ (String.concatWith ", " libs)) 12 | | tryLib (lib :: rest) = DynLinkage.open_lib { name = lib, global = true, 13 | lazy = true } 14 | handle x => tryLib rest 15 | 16 | val libHandle = tryLib libs 17 | 18 | in 19 | fun libh sym = let 20 | val symHandle = DynLinkage.lib_symbol (libHandle, sym) 21 | in 22 | fn () => DynLinkage.addr symHandle 23 | end 24 | end 25 | end 26 | -------------------------------------------------------------------------------- /db/libmysqlclient/uchar-mlton.sml: -------------------------------------------------------------------------------- 1 | structure UCharUtil = struct 2 | val toWord8 = fn x => x 3 | end 4 | -------------------------------------------------------------------------------- /db/libmysqlclient/uchar-smlnj.sml: -------------------------------------------------------------------------------- 1 | structure UCharUtil = struct 2 | val toWord8 = Word8.fromLargeWord 3 | end 4 | -------------------------------------------------------------------------------- /db/sqlite/Makefile: -------------------------------------------------------------------------------- 1 | FFI-smlnj/ffi.cm: sqlite.h 2 | ml-nlffigen -include ../library.sml -dir FFI-smlnj -cmfile ffi.cm $^ 3 | 4 | clean: 5 | rm -rf FFI-smlnj .cm 6 | -------------------------------------------------------------------------------- /db/sqlite/library.sml: -------------------------------------------------------------------------------- 1 | (* The ML-NLFFI generated code depends on this structure. It dynamically loads 2 | libsqlite3 on program startup, and provides hooks for the generated code 3 | to look up functions. 4 | *) 5 | 6 | structure Library = struct 7 | local 8 | val libs = [ "libsqlite3.so", "libsqlite3.so.0", "libsqlite3.dylib" ] 9 | 10 | fun tryLib nil = raise Fail ("could not load any of " 11 | ^ (String.concatWith ", " libs)) 12 | | tryLib (lib :: rest) = DynLinkage.open_lib { name = lib, global = true, 13 | lazy = true } 14 | handle x => tryLib rest 15 | 16 | val libHandle = tryLib libs 17 | 18 | in 19 | fun libh sym = let 20 | val symHandle = DynLinkage.lib_symbol (libHandle, sym) 21 | in 22 | fn () => DynLinkage.addr symHandle 23 | end 24 | end 25 | end 26 | -------------------------------------------------------------------------------- /db/sqlite/sqlite.cm: -------------------------------------------------------------------------------- 1 | Library 2 | signature SQLITE 3 | structure SQLite 4 | is 5 | $/basis.cm 6 | $c/c.cm 7 | FFI-smlnj/ffi.cm : make () 8 | sqlite.sig 9 | sqlite-smlnj.sml 10 | -------------------------------------------------------------------------------- /db/sqlite/sqlite.h: -------------------------------------------------------------------------------- 1 | /* This is a standalone version of the real sqlite.h, since the real one 2 | icludes system header files which use GCC extensions. Ick. */ 3 | 4 | typedef unsigned long long sqlite3_uint64; 5 | typedef signed long long sqlite3_int64; 6 | 7 | typedef struct sqlite3 sqlite3; 8 | typedef struct sqlite3_stmt sqlite3_stmt; 9 | typedef struct sqlite3_value sqlite3_value; 10 | 11 | const char *sqlite3_errmsg(sqlite3*); 12 | int sqlite3_errcode(sqlite3 *db); 13 | int sqlite3_extended_errcode(sqlite3 *db); 14 | 15 | int sqlite3_open( 16 | const char *filename, /* Database filename (UTF-8) */ 17 | sqlite3 **ppDb /* OUT: SQLite db handle */ 18 | ); 19 | 20 | int sqlite3_open_v2( 21 | const char *filename, /* Database filename (UTF-8) */ 22 | sqlite3 **ppDb, /* OUT: SQLite db handle */ 23 | int flags, /* Flags */ 24 | const char *zVfs /* Name of VFS module to use */ 25 | ); 26 | 27 | int sqlite3_close(sqlite3 *); 28 | 29 | int sqlite3_prepare( 30 | sqlite3 *db, /* Database handle */ 31 | const char *zSql, /* SQL statement, UTF-8 encoded */ 32 | int nByte, /* Maximum length of zSql in bytes. */ 33 | sqlite3_stmt **ppStmt, /* OUT: Statement handle */ 34 | const char **pzTail /* OUT: Pointer to unused portion of zSql */ 35 | ); 36 | 37 | int sqlite3_prepare_v2( 38 | sqlite3 *db, /* Database handle */ 39 | const char *zSql, /* SQL statement, UTF-8 encoded */ 40 | int nByte, /* Maximum length of zSql in bytes. */ 41 | sqlite3_stmt **ppStmt, /* OUT: Statement handle */ 42 | const char **pzTail /* OUT: Pointer to unused portion of zSql */ 43 | ); 44 | 45 | int sqlite3_reset(sqlite3_stmt *pStmt); 46 | int sqlite3_finalize(sqlite3_stmt *pStmt); 47 | 48 | int sqlite3_bind_blob(sqlite3_stmt*, int, const void*, int n, void *); 49 | int sqlite3_bind_double(sqlite3_stmt*, int, double); 50 | int sqlite3_bind_int(sqlite3_stmt*, int, int); 51 | int sqlite3_bind_int64(sqlite3_stmt*, int, sqlite3_int64); 52 | int sqlite3_bind_null(sqlite3_stmt*, int); 53 | int sqlite3_bind_text(sqlite3_stmt*, int, const char*, int n, void *); 54 | int sqlite3_bind_text16(sqlite3_stmt*, int, const void*, int, void *); 55 | int sqlite3_bind_value(sqlite3_stmt*, int, const sqlite3_value*); 56 | int sqlite3_bind_zeroblob(sqlite3_stmt*, int, int n); 57 | 58 | int sqlite3_step(sqlite3_stmt*); 59 | 60 | const void *sqlite3_column_blob(sqlite3_stmt*, int iCol); 61 | int sqlite3_column_bytes(sqlite3_stmt*, int iCol); 62 | int sqlite3_column_bytes16(sqlite3_stmt*, int iCol); 63 | double sqlite3_column_double(sqlite3_stmt*, int iCol); 64 | int sqlite3_column_int(sqlite3_stmt*, int iCol); 65 | sqlite3_int64 sqlite3_column_int64(sqlite3_stmt*, int iCol); 66 | const unsigned char *sqlite3_column_text(sqlite3_stmt*, int iCol); 67 | const void *sqlite3_column_text16(sqlite3_stmt*, int iCol); 68 | int sqlite3_column_type(sqlite3_stmt*, int iCol); 69 | sqlite3_value *sqlite3_column_value(sqlite3_stmt*, int iCol); 70 | 71 | 72 | /*sqlite3_int64 sqlite3_last_insert_rowid(sqlite3*);*/ 73 | /* XXX: this is super wrong. but will probably work. */ 74 | /* Woooooo relying on platform ABI details. */ 75 | int sqlite3_last_insert_rowid(sqlite3*); 76 | int sqlite3_changes(sqlite3*); 77 | -------------------------------------------------------------------------------- /db/sqlite/sqlite.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "allowFFI true" 3 | in 4 | local 5 | $(SML_LIB)/basis/basis.mlb 6 | $(SML_LIB)/basis/mlton.mlb 7 | $(SML_LIB)/basis/unsafe.mlb 8 | $(SML_LIB)/basis/c-types.mlb 9 | sqlite.sig 10 | sqlite.sml 11 | in 12 | signature SQLITE 13 | structure SQLite 14 | end 15 | end 16 | -------------------------------------------------------------------------------- /db/sqlite/sqlite.sig: -------------------------------------------------------------------------------- 1 | signature SQLITE = sig 2 | 3 | type db 4 | type stmt 5 | 6 | datatype column_type = INTEGER | FLOAT | TEXT | BLOB | NULL | UNKNOWN of int 7 | 8 | exception SQLiteClosed 9 | exception SQLiteError of string * int * string 10 | 11 | val errmsg : db -> string 12 | val errcode : db -> int 13 | 14 | val opendb : string -> db 15 | val close : db -> unit 16 | 17 | val last_insert_rowid : db -> Int32.int 18 | val changes : db -> Int32.int 19 | 20 | val prepare : db * string -> stmt 21 | val reset : stmt -> unit 22 | val finalize : stmt -> unit 23 | 24 | val bind_blob : stmt * int * Word8Vector.vector -> int 25 | val bind_double : stmt * int * Real64.real -> int 26 | val bind_int : stmt * int * Int32.int -> int 27 | val bind_int64 : stmt * int * Int64.int -> int 28 | val bind_null : stmt * int -> int 29 | val bind_text : stmt * int * string -> int 30 | 31 | val step : stmt -> int 32 | 33 | val column_blob : stmt * int -> Word8Vector.vector option 34 | val column_double : stmt * int -> Real64.real 35 | val column_int : stmt * int -> Int32.int 36 | val column_int64 : stmt * int -> Int64.int 37 | val column_text : stmt * int -> string option 38 | 39 | val column_type : stmt * int -> column_type 40 | 41 | end 42 | -------------------------------------------------------------------------------- /db/squall/.gitignore: -------------------------------------------------------------------------------- 1 | .cm 2 | input.grm.sig 3 | input.grm.sml 4 | input.lex.sml 5 | -------------------------------------------------------------------------------- /db/squall/Makefile: -------------------------------------------------------------------------------- 1 | squall: input.sml input.lex input.grm squall-sqlite.sml squall-standalone.sml squall.mlb 2 | mllex input.lex 3 | mlyacc input.grm 4 | mlton squall.mlb 5 | 6 | heap: 7 | ml-build squall.cm Squall.main heap 8 | 9 | clean: 10 | rm -rf input.lex.sml input.grm.sig input.grm.sml squall heap.* .cm 11 | -------------------------------------------------------------------------------- /db/squall/README: -------------------------------------------------------------------------------- 1 | Squall 2 | ------ 3 | 4 | Squall is a preprocessor that builds well-typed SML wrappers for SQL queries 5 | and statements. It reads a description file containing a list of statements 6 | with associated type information, and produces source for an SML structure with 7 | one function for each statement. 8 | 9 | Each declaration has the following form: 10 | 11 | --- funcname: intype -> outype 12 | SELECT ... from ... ? ... 13 | 14 | Any query supported by the database engine can be used. Squall does not parse 15 | the SQL template except, under certain circumstances, to determine the frst 16 | keyword; see below. When the generated function is run, each question mark 17 | character ("?") in the provided SQL will be replaced by its positionally- 18 | corresponding input parameter. The SQL must contain the correct number of ? 19 | symbols for the specified parameters. 20 | 21 | The syntax for specifying input and output types is deliberately very close to 22 | that of SML. The input type can be one of the following: 23 | 24 | unit No input; no ? substitutions in the SQL. 25 | typ (* typ * ...) Single value or tuple of values. 26 | { foo: typ; ...} Record. Since SML records are not ordered, the order in 27 | which fields are listed in the Squall description file 28 | is the order in which they will be mapped. 29 | 30 | Defined output types are: 31 | 32 | unit No output. The wrapper checks to ensure that the query 33 | returns no rows. 34 | typ (* typ * ...) The query must return a single row; its columns are 35 | returned as a tuple of the given types. 36 | { foo: typ; ... } As above, but columns are mapped to fields in the record 37 | according to their order in the description field. 38 | ... list Either of the above two options may be speciied as a 39 | list. In this case, all rows are eager-loaded (using 40 | mysql_store_result) into a normal SML list. 41 | ... array/vector As with list; rows are then converted to an array/vector. 42 | ... option As above; the query must return either zero rows or one 43 | row, which correspond to NONE or SOME (rowtype). 44 | affected_rows Special. Functions declared as "-> affected_rows" must 45 | return no result set, as with return type unit; the 46 | wrapper function then returns the result of calling 47 | mysql_affected_rows(). 48 | insert_id Analogous to affected_rows, but for mysql_insert_id(). 49 | 50 | Note that list is the "native" version; arrays and vectors are converted from 51 | a list. This is included largely for completeness' sake. 52 | 53 | Currently, Squall supports the following column types: 54 | 55 | string String. For MySQL, this is escaped using 56 | mysql_real_escape_string, quoted, and substituted. 57 | int Int.int. Encoded with Int.toString; decoded with 58 | Int.fromString. 59 | word LargeWord.word. Encoded with LargeWord.toString; decoded 60 | with LargeWord.fromString. 61 | ... option Any of the above may also be an option; NULL values will 62 | be represented as NONE. 63 | 64 | As implemented, Squall uses the standard libmysqlclient functions, rather than 65 | its prepared statement API. This means that the database and libmysqlclient 66 | convert all returned values to strings, regarldess of their type according to 67 | the DB engine. Squall then produces code to convert each field back to the 68 | appropriate type. 69 | 70 | Future work: 71 | - Lazy loading from the database (mysql_use_result()) 72 | - Use prepared statements 73 | -------------------------------------------------------------------------------- /db/squall/cm.sml: -------------------------------------------------------------------------------- 1 | (* This is an SML/NJ CM tool that will automatically produce SML from .squall 2 | * files. 3 | *) 4 | 5 | structure SquallTool = struct 6 | 7 | fun squallRule { spec as { name, mkpath, class, opts, derived }, 8 | native2pathmaker, context, defaultClassOf, sysinfo } = 9 | let 10 | val srcpath = Tools.srcpath (mkpath ()) 11 | val srcFile = (Tools.nativeSpec srcpath) 12 | val outputFile = srcFile ^ ".sml" 13 | 14 | val partial_expansion = ( 15 | { smlfiles = nil, 16 | cmfiles = nil, 17 | sources = [ (srcpath, { class = "squall", derived = false }) ] }, 18 | [ { name = outputFile : string, 19 | mkpath = native2pathmaker outputFile, 20 | class = SOME "sml", 21 | opts = NONE, 22 | derived = true } ] 23 | ) 24 | 25 | fun rulefun () = ( 26 | if Tools.outdated "squall" ([ outputFile ], srcFile) 27 | then (Tools.vsay [ "[squall: compiling ", srcFile, "]\n" ]; 28 | Squall.process_and_write NONE srcFile) 29 | else (); 30 | partial_expansion 31 | ) 32 | in 33 | context rulefun 34 | end 35 | 36 | val _ = Tools.registerClass ("squall", squallRule) 37 | 38 | val _ = Tools.registerClassifier (Tools.SFX_CLASSIFIER (fn "squall" => SOME "squall" 39 | | _ => NONE)) 40 | 41 | end 42 | -------------------------------------------------------------------------------- /db/squall/example.squall: -------------------------------------------------------------------------------- 1 | --- getById: int -> { id: int, value: string } option 2 | 3 | select id, value from foo_table where id = ? 4 | 5 | --- x: int -> unit 6 | 7 | update fnord set frobbed = 1 where id = ? 8 | 9 | --- foo: unit -> unit 10 | 11 | update xyzzy set wut = 1 12 | 13 | --- bar: { x: string } -> unit 14 | 15 | insert into blort (zot) values (?) 16 | -------------------------------------------------------------------------------- /db/squall/input.grm: -------------------------------------------------------------------------------- 1 | open SquallInput 2 | 3 | exception ParseError of string 4 | 5 | fun type_lookup "string" = String 6 | | type_lookup "int" = Int 7 | | type_lookup "blob" = Blob 8 | | type_lookup t = raise ParseError ("Unknown type: \"" ^ t ^ "\"") 9 | 10 | fun engine_lookup s = 11 | case String.map Char.toLower s of 12 | "sqlite" => SQLite 13 | | "mysql" => MySQL 14 | | _ => raise ParseError ("Unknown engine: \"" ^ s ^ "\"") 15 | 16 | %% 17 | 18 | %term TOKEN of string 19 | | STAR 20 | | ARROW 21 | | COLON 22 | | LBRACE 23 | | RBRACE 24 | | LPAREN 25 | | RPAREN 26 | | COMMA 27 | | LIST 28 | | OPTION 29 | | ARRAY 30 | | VECTOR 31 | | FOLD 32 | | UNIT 33 | | AFFECTED_ROWS 34 | | INSERT_ID 35 | | ENGINE 36 | | EOF 37 | | SQLDATA of string 38 | 39 | %eop EOF 40 | %noshift EOF 41 | 42 | %nonterm START of engine option * sqlfunc list 43 | | ITEMS of sqlfunc list 44 | | ITEM of sqlfunc 45 | | engine of engine 46 | | itype of inbinding 47 | | otype of outbinding 48 | | reptype of reptype 49 | | tupleitems of varspec list 50 | | recorditems of (string * varspec) list 51 | | sqlseq of string 52 | | varspec of varspec 53 | 54 | %pos int 55 | 56 | %name Squall 57 | 58 | %% 59 | 60 | START: engine ITEMS ((SOME engine, ITEMS)) 61 | | ITEMS ((NONE, ITEMS)) 62 | 63 | engine: ENGINE COLON TOKEN (engine_lookup TOKEN) 64 | 65 | ITEMS: ITEM ITEMS (ITEM :: ITEMS) 66 | | ITEM (ITEM :: nil) 67 | 68 | ITEM: TOKEN COLON itype ARROW otype sqlseq 69 | ({ name = TOKEN1, inb = itype, outb = otype, sql = sqlseq }) 70 | 71 | itype: LPAREN tupleitems RPAREN (IBtuple tupleitems) 72 | | tupleitems (IBtuple tupleitems) 73 | | LBRACE recorditems RBRACE (IBrecord recorditems) 74 | | UNIT (IBunit) 75 | 76 | otype: LPAREN tupleitems RPAREN (OBtuple (Rsingle, tupleitems)) 77 | | LPAREN tupleitems RPAREN reptype (OBtuple (reptype, tupleitems)) 78 | | tupleitems (OBtuple (Rsingle, tupleitems)) 79 | | LBRACE recorditems RBRACE (OBrecord (Rsingle, recorditems)) 80 | | LBRACE recorditems RBRACE reptype (OBrecord (reptype, recorditems)) 81 | | UNIT (OBunit) 82 | | INSERT_ID (OBinsertId) 83 | | AFFECTED_ROWS (OBaffectedRows) 84 | 85 | reptype: LIST (Rlist) 86 | | OPTION (Roption) 87 | | ARRAY (Rarray) 88 | | VECTOR (Rvector) 89 | | FOLD (Rfold) 90 | 91 | tupleitems: varspec STAR tupleitems (varspec :: tupleitems) 92 | | varspec (varspec :: nil) 93 | 94 | recorditems: TOKEN COLON varspec COMMA recorditems ((TOKEN, varspec) :: recorditems) 95 | | TOKEN COLON varspec ((TOKEN, varspec) :: nil) 96 | 97 | varspec: TOKEN OPTION (Voption (type_lookup TOKEN)) 98 | | TOKEN LIST (Vlist (type_lookup TOKEN)) 99 | | TOKEN (Vrequired (type_lookup TOKEN)) 100 | 101 | sqlseq: SQLDATA sqlseq (SQLDATA ^ sqlseq) 102 | | SQLDATA (SQLDATA) 103 | -------------------------------------------------------------------------------- /db/squall/input.lex: -------------------------------------------------------------------------------- 1 | structure Tokens = Tokens 2 | type pos = int 3 | type svalue = Tokens.svalue 4 | type ('a,'b) token = ('a,'b) Tokens.token 5 | type lexresult = (svalue,pos) token 6 | 7 | open Tokens 8 | 9 | val lineNum = ref 0 10 | fun lines n = lineNum := (!lineNum + n) 11 | fun eof () = EOF (!lineNum, !lineNum) 12 | 13 | %% 14 | 15 | %header (functor SquallLexFun(structure Tokens : Squall_TOKENS)); 16 | 17 | %s HEADER SQL ; 18 | 19 | whitespace = [\ \t]; 20 | token = [a-zA-Z_']; 21 | sqlline = ([^-\n] .* "\n") 22 | | ("-" ([^-\n] .* "\n" | "\n")) 23 | | ("--" ([^-\n] .* "\n" | "\n")); 24 | 25 | %% 26 | 27 | ^ "#" .* => ( lines 1; continue () ); 28 | ^ "---" => ( YYBEGIN HEADER; lex () ); 29 | ^ "engine" => ( YYBEGIN HEADER; ENGINE (!lineNum, !lineNum) ); 30 | 31 |
"*" => ( STAR (!lineNum, !lineNum) ); 32 |
"list" => ( LIST (!lineNum, !lineNum) ); 33 |
"fold" => ( FOLD (!lineNum, !lineNum) ); 34 |
"option" => ( OPTION (!lineNum, !lineNum) ); 35 |
"array" => ( ARRAY (!lineNum, !lineNum) ); 36 |
"vector" => ( VECTOR (!lineNum, !lineNum) ); 37 |
"unit" => ( UNIT (!lineNum, !lineNum) ); 38 |
"insert_id" => ( INSERT_ID (!lineNum, !lineNum) ); 39 |
"affected_rows" => ( AFFECTED_ROWS (!lineNum, !lineNum) ); 40 |
"->" => ( ARROW (!lineNum, !lineNum) ); 41 |
"->" => ( ARROW (!lineNum, !lineNum) ); 42 |
":" => ( COLON (!lineNum, !lineNum) ); 43 |
"{" => ( LBRACE (!lineNum, !lineNum) ); 44 |
"}" => ( RBRACE (!lineNum, !lineNum) ); 45 |
"(" => ( LPAREN (!lineNum, !lineNum) ); 46 |
")" => ( RPAREN (!lineNum, !lineNum) ); 47 |
"," => ( COMMA (!lineNum, !lineNum) ); 48 |
"\n" => ( lines 1; YYBEGIN SQL; continue () ); 49 |
{token}+ => ( TOKEN (yytext, !lineNum, !lineNum) ); 50 |
{whitespace}+ => ( lex () ); 51 | 52 | ^ "#" .* "\n" => ( lines 1; continue () ); 53 | ^ "---" => ( YYBEGIN HEADER; lex () ); 54 | ^ {sqlline} => ( lines 1; SQLDATA (yytext, !lineNum, !lineNum) ); 55 | "\n" => ( lines 1; lex () ); 56 | -------------------------------------------------------------------------------- /db/squall/input.sml: -------------------------------------------------------------------------------- 1 | structure SquallInput = struct 2 | 3 | datatype engine = SQLite | MySQL 4 | 5 | datatype vartype = String | Int | Blob 6 | 7 | datatype varspec = Vrequired of vartype | Voption of vartype | Vlist of vartype 8 | 9 | datatype reptype = Rlist | Rarray | Rvector | Rsingle | Roption | Rfold 10 | 11 | datatype inbinding = IBtuple of varspec list 12 | | IBrecord of (string * varspec) list 13 | | IBunit 14 | 15 | datatype outbinding = OBtuple of reptype * varspec list 16 | | OBrecord of reptype * (string * varspec) list 17 | | OBunit 18 | | OBinsertId 19 | | OBaffectedRows 20 | 21 | type sqlfunc = { name: string, 22 | inb: inbinding, 23 | outb: outbinding, 24 | sql: string } 25 | 26 | end 27 | -------------------------------------------------------------------------------- /db/squall/squall-standalone.sml: -------------------------------------------------------------------------------- 1 | val _ = OS.Process.exit (Squall.main ()); 2 | -------------------------------------------------------------------------------- /db/squall/squall-tool.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $smlnj/cm/tools.cm 3 | squall.cm 4 | cm.sml 5 | -------------------------------------------------------------------------------- /db/squall/squall.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/basis.cm 3 | $/ml-yacc-lib.cm 4 | input.sml 5 | input.grm 6 | input.lex 7 | squall-sqlite.sml 8 | squall-mysql.sml 9 | squall.sml 10 | -------------------------------------------------------------------------------- /db/squall/squall.mk: -------------------------------------------------------------------------------- 1 | SQUALL_DEPS = $(shell $(MLTON) -stop f $(SQUALL_PATH)/squall.mlb) 2 | 3 | %.grm.sig %.grm.sml: %.grm 4 | mlyacc $< 5 | 6 | %.lex.sml: %.lex 7 | mllex $< 8 | 9 | $(SQUALL_PATH)/squall: $(SQUALL_DEPS) 10 | $(MLTON) $(SQUALL_PATH)/squall.mlb 11 | 12 | %.squall.sml: %.squall $(SQUALL_PATH)/squall 13 | $(SQUALL_PATH)/squall $< 14 | -------------------------------------------------------------------------------- /db/squall/squall.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb 3 | input.sml 4 | input.grm.sig 5 | input.grm.sml 6 | input.lex.sml 7 | squall-sqlite.sml 8 | squall-mysql.sml 9 | squall.sml 10 | squall-standalone.sml 11 | -------------------------------------------------------------------------------- /db/squall/squall.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Squall wrapper script. 4 | dn="`dirname $0`" 5 | 6 | if [ -e "$dn/squall" ] 7 | then 8 | exec "$dn/squall" $* 9 | fi 10 | 11 | sml @SMLcmdname=$0 "@SMLload=$dn/heap" $* 12 | -------------------------------------------------------------------------------- /db/squall/squall.sml: -------------------------------------------------------------------------------- 1 | structure Squall :> sig 2 | 3 | type parsed_file = SquallInput.engine option * SquallInput.sqlfunc list 4 | 5 | val parse : string -> parsed_file 6 | val convert : SquallInput.engine option -> parsed_file -> string 7 | val process : SquallInput.engine option -> string -> string 8 | val process_and_write: SquallInput.engine option -> string -> unit 9 | val main: 'a -> OS.Process.status 10 | 11 | end = struct 12 | 13 | structure SquallLrVals = SquallLrValsFun(structure Token = LrParser.Token) 14 | structure SquallLex = SquallLexFun(structure Tokens = SquallLrVals.Tokens) 15 | structure SquallParser = Join(structure Lex = SquallLex 16 | structure LrParser = LrParser 17 | structure ParserData = SquallLrVals.ParserData) 18 | 19 | structure SI = SquallInput 20 | 21 | type parsed_file = SquallInput.engine option * SquallInput.sqlfunc list 22 | 23 | (* val parse: string -> SI.sqlfunc list 24 | * 25 | * Load and parse the specified file. 26 | *) 27 | fun parse s = 28 | let val dev = TextIO.openIn s 29 | val stream = SquallParser.makeLexer(fn i => TextIO.inputN(dev, i)) 30 | fun error (e, i:int, _) = 31 | TextIO.output(TextIO.stdOut, s ^ "," ^ " line " ^ (Int.toString i) 32 | ^ ", Error: " ^ e ^ "\n") 33 | val () = SquallLex.UserDeclarations.lineNum := 1 34 | val (res, _) = SquallParser.parse(30,stream,error,()) 35 | val () = TextIO.closeIn dev 36 | in res 37 | end 38 | 39 | 40 | fun convertWith SI.SQLite funcs = SquallSQLite.convert funcs 41 | | convertWith SI.MySQL funcs = SquallMySQL.convert funcs 42 | 43 | fun convert (SOME e) (NONE, funcs) = convertWith e funcs 44 | | convert NONE (SOME e, funcs) = convertWith e funcs 45 | | convert NONE (NONE, funcs) = raise Fail "Must specify an engine." 46 | | convert (SOME e1) (SOME e2, funcs) = if e1 = e2 then convertWith e1 funcs 47 | else raise Fail "Conflicting engines in command line and file." 48 | 49 | (* val process: string -> string 50 | * 51 | * Load definitions from a file and process them as above. 52 | *) 53 | fun process engine filename = convert engine (parse filename) 54 | 55 | 56 | fun err msg = TextIO.output(TextIO.stdErr, String.concat msg) 57 | 58 | fun process_and_write engine filename = let 59 | val result = process engine filename 60 | val outfile = TextIO.openOut (filename ^ ".sml") 61 | in 62 | TextIO.output (outfile, result); 63 | TextIO.closeOut outfile 64 | end 65 | 66 | (* val main: 'a -> OS.process.status 67 | * 68 | * Main function. 69 | *) 70 | 71 | fun main _ = (case CommandLine.arguments () of 72 | [ filename ] => (process_and_write NONE filename; 73 | OS.Process.success) 74 | | [ "--sqlite", filename ] => (process_and_write (SOME SI.SQLite) filename; 75 | OS.Process.success) 76 | | [ "--mysql", filename ] => (process_and_write (SOME SI.MySQL) filename; 77 | OS.Process.success) 78 | | _ => ( 79 | print ("Usage: " ^ (CommandLine.name ()) ^ " [--sqlite | --mysql] squallfile\n"); 80 | OS.Process.failure 81 | )) 82 | 83 | handle e => (err [ CommandLine.name(), ": uncaught exception ", 84 | General.exnMessage e, "\n"]; 85 | OS.Process.failure) 86 | end 87 | -------------------------------------------------------------------------------- /hello/hello.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/basis.cm 3 | $/regexp-lib.cm 4 | 5 | ../db/libmysqlclient/libmysqlclient.cm 6 | ../db/squall/squall-tool.cm : tool 7 | wiki.squall 8 | 9 | ../web/web.cm 10 | 11 | templates/templates.cm 12 | wiki.sml 13 | -------------------------------------------------------------------------------- /hello/hello.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | ../smelt/tinyxml/tinyxml.mlb 3 | ../web/web.mlb 4 | templates/hello.html.sml 5 | hello.sml 6 | main.sml 7 | -------------------------------------------------------------------------------- /hello/hello.sml: -------------------------------------------------------------------------------- 1 | structure Hello = struct 2 | 3 | structure U = WebUtil 4 | 5 | fun handler (req: Web.request) = (case U.postpath req of 6 | 7 | nil => 8 | raise U.redirectPostpath req [ "hello" ] 9 | 10 | | [ "" ] => 11 | raise U.redirectPostpath req [ "hello" ] 12 | 13 | | [ "hello" ] => U.htmlResp ( 14 | THello.render { blort = "world" } 15 | ) 16 | 17 | | _ => raise U.notFound 18 | ) 19 | 20 | val app = U.dumpRequestWrapper print (U.exnWrapper handler) 21 | 22 | fun main _ = let 23 | val () = print "Listening...\n" 24 | val () = HTTPServer.serve (INetSock.any 8888) app 25 | in 26 | 0 27 | end 28 | 29 | end 30 | -------------------------------------------------------------------------------- /hello/lighttpd.conf: -------------------------------------------------------------------------------- 1 | server.modules = ( "mod_access", 2 | "mod_fastcgi", 3 | "mod_accesslog", 4 | "mod_rewrite", 5 | "mod_staticfile" ) 6 | 7 | server.document-root = "/Library/WebServer/Documents" 8 | server.event-handler = "freebsd-kqueue" # on Mac OS X or FreeBSD 9 | 10 | # server.errorlog = "/tmp/lighttpd.error.log" 11 | accesslog.filename = "/tmp/access.log" 12 | 13 | fastcgi.server = ( "" => 14 | ( "127.0.0.1" => 15 | ( 16 | "host" => "127.0.0.1", 17 | "port" => 5124, 18 | "check-local" => "disable", 19 | "disable-time" => 1, 20 | ) 21 | ) 22 | ) 23 | 24 | server.port = 8080 25 | -------------------------------------------------------------------------------- /hello/main.sml: -------------------------------------------------------------------------------- 1 | val _ = Hello.main () 2 | -------------------------------------------------------------------------------- /hello/templates/hello.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Hello, ${blort}! 5 | 6 | 7 |

Hello, ${blort}!

8 |

This is a simple Stilts test.

9 | 10 | 11 | -------------------------------------------------------------------------------- /hello/templates/templates.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/basis.cm 3 | ../../smelt/smelt-tool.cm : tool 4 | ../../web/web.cm 5 | hello.html 6 | -------------------------------------------------------------------------------- /mlmusic/.gitignore: -------------------------------------------------------------------------------- 1 | .cm 2 | music.squall.sml 3 | searchdb.idx 4 | -------------------------------------------------------------------------------- /mlmusic/Makefile: -------------------------------------------------------------------------------- 1 | MLB = music.mlb 2 | OUTPUT = sing 3 | 4 | MLTON = mlton 5 | 6 | SQUALL_PATH = ../../stilts/db/squall 7 | MYSQL_PATH = ../../stilts/db/libmysqlclient 8 | SMELT_PATH = ../../stilts/smelt 9 | 10 | DATE=$(shell date +%Y%m%d) 11 | 12 | # --- 13 | 14 | all: $(OUTPUT) 15 | 16 | DEPS = $(shell $(MLTON) -stop f $(MLB)) 17 | 18 | default: $(OUTPUT) 19 | 20 | include $(SQUALL_PATH)/squall.mk 21 | include $(SMELT_PATH)/smelt.mk 22 | 23 | $(OUTPUT): $(MYSQL_PATH)/FFI-mlton/ffi.mlb $(DEPS) $(MLB) 24 | mlton -link-opt -lmysqlclient -output $@ $(MLB) 25 | 26 | $(OUTPUT)-arm: $(DEPS) $(MLB) 27 | ./mlton-static-libgmp -target arm-poky-linux-gnueabi -cc ~/bin2/arm-poky-linux-gnueabi-gcc -link-opt -lsqlite3 -verbose 2 -output $@ $(MLB) 28 | ~/bin/arm-poky-linux-gnueabi-strip $@ 29 | 30 | dist: sing-$(DATE) 31 | 32 | sing-$(DATE): all 33 | rm -rf $@ 34 | mkdir $@ 35 | cp -a sing index/index mysql-mods.sql lighttpd.conf $@/ 36 | strip $@/index 37 | strip $@/sing 38 | svn export static $@/static 39 | tar czf $@.tar.gz $@ 40 | du -hs $@ $@.tar.gz 41 | 42 | dist-arm: sing-arm-$(DATE) 43 | 44 | sing-arm-$(DATE): sing-arm 45 | rm -rf $@ 46 | mkdir $@ 47 | cp -a sing-arm $@/ 48 | svn export static $@/static 49 | make -C $@/static/js dist 50 | tar czf $@.tar.gz $@ 51 | du -hs $@ $@.tar.gz 52 | -------------------------------------------------------------------------------- /mlmusic/browser/mfbrowser.sml: -------------------------------------------------------------------------------- 1 | structure MFBrowser :> sig val browseApp: Web.app end = struct 2 | 3 | structure U = WebUtil 4 | structure J = JSON 5 | 6 | val pageLen = 50 7 | 8 | (* val pairs: 'a list -> ('a * 'a) list 9 | * 10 | * Combine a list of even length into pairs of adjacent elements: 11 | * [ a, b, c, d, e, f ] ==> [ (a, b), (c, d), (e, f) ] 12 | * 13 | * A trailing element, if present, will be ignored. 14 | *) 15 | fun pairs [] = nil 16 | | pairs [_] = nil 17 | | pairs (a::b::r) = (a, b)::(pairs r) 18 | 19 | 20 | fun getString obj key = case J.Map.find (obj, key) of 21 | SOME (J.String s) => SOME s 22 | | _ => NONE 23 | 24 | 25 | fun browseApp (req: Web.request) = let 26 | val path = U.postpath req 27 | val form = Form.load req 28 | val header_info = Request.get_header req 29 | val base = String.concatWith "/" ("" :: U.prepath req) 30 | 31 | (* Assert that the path ends with a trailing / *) 32 | val () = case rev path of ""::_ => () | _ => raise U.notFound 33 | 34 | val pathPairsRev = rev (pairs path) 35 | 36 | (* Generate breadcrumb links *) 37 | fun makeLinks (nil, acc) = acc 38 | | makeLinks (p as ((id, name)::rest), acc) = let 39 | val () = case Int.fromString id of NONE => raise U.notFound 40 | | _ => () 41 | val url = base ^ "/" 42 | ^ String.concatWith "/" (map 43 | (fn (i, n) => i ^ "/" ^ n) 44 | (rev p)) 45 | ^ "/" 46 | in 47 | makeLinks (rest, (name, url)::acc) 48 | end 49 | 50 | val backlinks = ("Music Folder", base ^ "/") 51 | :: makeLinks (pathPairsRev, nil) 52 | 53 | val start = Option.getOpt 54 | (Option.mapPartial IntInf.fromString (Form.get form "start"), 0) 55 | 56 | (* Produce the actual request *) 57 | val req = J.String "musicfolder" 58 | :: J.Number start 59 | :: J.Number (IntInf.fromInt pageLen) 60 | :: (case pathPairsRev of 61 | ((id, _)::_) => [ J.String ("folder_id:" ^ id) ] 62 | | _ => nil) 63 | 64 | val resp = JSONRPC.request req 65 | val list = JSONRPC.unpack "folder_loop" "filename" resp 66 | 67 | fun page i = (i * pageLen, pageLen, 0, Int.toString (i + 1)) 68 | fun makePagebar count = 69 | if count < pageLen then NONE 70 | else SOME (List.tabulate ((count - 1) div pageLen + 1, page)) 71 | 72 | val pb = case resp of 73 | J.Object m => ( 74 | case J.Map.find (m, "count") of 75 | SOME (J.String s) => 76 | Option.mapPartial makePagebar (Int.fromString s) 77 | | SOME (J.Number i) => makePagebar (Int.fromLarge i) 78 | | _ => NONE) 79 | | _ => NONE 80 | 81 | fun renderItem { id, map, name } = (case getString map "type" of 82 | SOME "folder" => 83 | TFolderItem.render { id = id, filename = name } 84 | | SOME "track" => 85 | TTrackItem.render NONE { 86 | id = id, 87 | tracknum = NONE, 88 | title = Option.getOpt (getString map "title", name), 89 | artists = nil, album = NONE, lossless = NONE, bitrate = NONE, ct = NONE 90 | } 91 | | _ => Web.HTML "" 92 | ) 93 | in 94 | U.xhtmlResp (TList.render { 95 | all = NONE, 96 | path = backlinks, 97 | title = #1 (hd (rev backlinks)), 98 | list = list, 99 | pb = pb, 100 | start = Int.fromLarge start, 101 | perItem = renderItem 102 | } header_info) 103 | end 104 | end 105 | -------------------------------------------------------------------------------- /mlmusic/cache.sml: -------------------------------------------------------------------------------- 1 | structure Cache :> sig 2 | 3 | type 'a cached 4 | 5 | val mk: (unit -> 'a) -> 'a cached 6 | 7 | val get: 'a cached -> 'a 8 | 9 | val resetAll: unit -> unit 10 | 11 | end = struct 12 | 13 | type 'a cached = 'a option ref * (unit -> 'a) 14 | 15 | val resetList : (unit -> unit) list ref = ref nil 16 | 17 | fun mk f = let 18 | val cell = ref NONE 19 | fun reset () = (cell := NONE) 20 | in 21 | resetList := (reset :: !resetList); 22 | (cell, f) 23 | end 24 | 25 | fun get (cell, f) = 26 | case !cell of SOME value => value 27 | | NONE => let 28 | val v = f () 29 | in 30 | cell := SOME v; 31 | v 32 | end 33 | 34 | fun resetAll () = (app (fn c => c ()) (!resetList); 35 | resetList := nil) 36 | 37 | end 38 | -------------------------------------------------------------------------------- /mlmusic/chiral.sml: -------------------------------------------------------------------------------- 1 | structure T = Thread (structure T = ThreadBase 2 | structure RC = SelectReactorCore 3 | structure C = ConfigPrintEverything) 4 | 5 | structure CV = CondVar(T) 6 | structure CS = ChiralSocketFn(T) 7 | structure SU = ChiralSockUtil(CS) 8 | structure LR = LineReader(CS.Socket) 9 | 10 | structure HTTPServer = HTTPServerFn(structure CS = CS structure T = T) 11 | 12 | -------------------------------------------------------------------------------- /mlmusic/clisonginfo.sml: -------------------------------------------------------------------------------- 1 | structure CLISongInfo :> sig 2 | 3 | type track = { 4 | id: int, tracknum: int option, title: string, 5 | albumId: int option, albumTitle: string option, 6 | artistId: int option, artistName: string option } 7 | 8 | val songInfo: int -> track option 9 | val songInfoMulti: int list -> track list 10 | 11 | end 12 | = struct 13 | 14 | type track = { 15 | id: int, tracknum: int option, title: string, 16 | albumId: int option, albumTitle: string option, 17 | artistId: int option, artistName: string option } 18 | 19 | structure J = JSON 20 | 21 | fun songInfo song = let 22 | val res = JSONRPC.request [ 23 | J.String "songinfo", 24 | J.Number 0, 25 | J.Number 99999, 26 | J.String "tags:elast", 27 | J.String ("track_id:" ^ Int.toString song) 28 | ] 29 | 30 | val objArr = case res of 31 | J.Object obj => (case J.Map.find (obj, "songinfo_loop") of 32 | SOME (J.Array arr) => arr 33 | | _ => nil) 34 | | _ => nil 35 | 36 | fun processObj (J.Object obj, acc) = 37 | J.Map.foldli (fn (k, v, acc) => J.Map.insert (acc, k, v)) acc obj 38 | | processObj (_, acc) = acc 39 | 40 | val objs = foldl processObj J.Map.empty objArr 41 | 42 | fun getString key = case J.Map.find (objs, key) of 43 | SOME (J.String s) => SOME s 44 | | SOME (J.Number n) => SOME (IntInf.toString n) 45 | | _ => NONE 46 | 47 | fun getNumber key = case J.Map.find (objs, key) of 48 | SOME (J.String s) => Int.fromString s 49 | | SOME (J.Number n) => SOME (IntInf.toInt n) 50 | | _ => NONE 51 | in 52 | case (getNumber "id", getString "title") of 53 | (SOME id, SOME title) => SOME { 54 | id = id, 55 | title = title, 56 | tracknum = getNumber "tracknum", 57 | albumId = getNumber "album_id", 58 | albumTitle = getString "album", 59 | artistId = getNumber "artist_id", 60 | artistName = getString "artist" 61 | } 62 | | _ => NONE 63 | end 64 | 65 | val songInfoMulti = List.mapPartial songInfo 66 | 67 | end 68 | -------------------------------------------------------------------------------- /mlmusic/conf.sml: -------------------------------------------------------------------------------- 1 | structure Conf = struct 2 | 3 | val static = "/static" 4 | 5 | end 6 | -------------------------------------------------------------------------------- /mlmusic/db.sml: -------------------------------------------------------------------------------- 1 | structure DB = struct 2 | 3 | (* 4 | val conn_info_root : MySQLClient.connect_info = { 5 | host = SOME "localhost", port = 0w0, unix_socket = NONE, 6 | user = SOME "root", password = NONE, db = SOME "slimserver" 7 | } 8 | 9 | val conn_info_sock : MySQLClient.connect_info = { 10 | host = NONE, port = 0w0, unix_socket = SOME "/var/lib/squeezecenter/cache/squeezecenter-mysql.sock", 11 | user = SOME "root", password = NONE, db = SOME "slimserver" 12 | } 13 | *) 14 | 15 | fun fold_tracks res = let 16 | fun processSingle { id: string, tracknum, title, lossless, albumId, albumTitle, 17 | artistId, artistName, bitrate, ct } = 18 | { id = id, tracknum = tracknum, title = title, lossless = lossless, 19 | bitrate = bitrate, ct = ct, 20 | album = case (albumId, albumTitle) of 21 | (SOME i, SOME t) => SOME { id = i, name = t } 22 | | _ => NONE, 23 | artists = case (artistId, artistName) of 24 | (SOME i, SOME n) => [ { id = i, name = n } ] 25 | | _ => nil } 26 | 27 | fun process (item, nil) = [ processSingle item ] 28 | | process (item as { id, artistId, artistName, ... }, 29 | (prev as { id = pId, tracknum = pNum, title = pTitle, lossless = pLossless, ct = pct, bitrate = pBitrate, 30 | album = pAlbum, artists = pArtists }) :: rest) = 31 | if id = pId 32 | then { id = pId, tracknum = pNum, title = pTitle, lossless = pLossless, ct = pct, bitrate = pBitrate, album = pAlbum, 33 | artists = case (artistId, artistName) of 34 | (SOME i, SOME n) => { id = i, name = n } :: pArtists 35 | | _ => pArtists } :: rest 36 | else (processSingle item) :: prev :: rest 37 | in 38 | rev (foldl process nil res) 39 | end 40 | 41 | 42 | end 43 | -------------------------------------------------------------------------------- /mlmusic/index/.gitignore: -------------------------------------------------------------------------------- 1 | index.squall.sml 2 | -------------------------------------------------------------------------------- /mlmusic/index/Makefile: -------------------------------------------------------------------------------- 1 | MLB = index.mlb 2 | 3 | OUTPUT = index 4 | 5 | MLTON = mlton 6 | 7 | SQUALL_PATH = ../../../stilts/db/squall 8 | 9 | # --- 10 | 11 | DEPS = $(shell $(MLTON) -stop f $(MLB)) 12 | 13 | default: $(OUTPUT) 14 | 15 | include $(SQUALL_PATH)/squall.mk 16 | 17 | $(OUTPUT): $(DEPS) $(MLB) 18 | mlton -link-opt -lsqlite3 $(MLB) 19 | 20 | $(OUTPUT)-arm: $(DEPS) $(MLB) 21 | mlton -target arm-poky-linux-gnueabi -cc ~/bin2/arm-poky-linux-gnueabi-gcc -link-opt -lsqlite3 -verbose 2 -output $@ $(MLB) 22 | ~/bin/arm-poky-linux-gnueabi-strip $@ 23 | -------------------------------------------------------------------------------- /mlmusic/index/format.txt: -------------------------------------------------------------------------------- 1 | Index Format 2 | 3 | The output file contains the following: 4 | 5 | - Magic: "SearchDB" 6 | - Version number: one byte, 3 7 | - Endianness tag: one byte, 0 for little-endian, 1 for big-endian 8 | - Number of subindexes: one byte 9 | - Reserved: one byte 10 | - Jump table length: four byte integer, number of _bytes_ 11 | - Data segment length: four byte integer, number of _bytes_ 12 | - Reserved: four bytes, all zeroes 13 | 14 | - Jump table: N fields of: four bytes of string prefix; 15 | four bytes of byte offset into data segment 16 | - Data segment N fields of: 17 | - Four byte total length 18 | - Four byte string length 19 | - String, null-terminated, padded to be a multiple of four bytes 20 | - For each of the subindexes: 21 | - Four byte number of IDs 22 | - IDs 23 | 24 | -------------------------------------------------------------------------------- /mlmusic/index/index-sqlite.squall: -------------------------------------------------------------------------------- 1 | engine: sqlite 2 | 3 | --- tracksTitle: unit -> (int * string) fold 4 | 5 | select id, titlesearch from tracks 6 | where tracks.audio = 1 and tracks.titlesearch is not null 7 | 8 | --- tracksTitleAlbum: unit -> (int * string) fold 9 | 10 | select tracks.id, tracks.titlesearch || " " || ifnull(albums.titlesearch, "") as ta 11 | from tracks 12 | left join albums on tracks.album = albums.id 13 | where tracks.audio = 1 and tracks.titlesearch is not null 14 | 15 | --- tracksTitleArtist: unit -> (int * string) fold 16 | 17 | select tracks.id, tracks.titlesearch || " " || 18 | ifnull(group_concat(contributors.namesearch, " "), "") as ta 19 | from tracks 20 | left outer join contributor_track ct on (ct.track = tracks.id and ct.role in (1, 5, 6)) 21 | left outer join contributors on contributors.id = ct.contributor 22 | where tracks.audio = 1 and tracks.titlesearch is not null 23 | group by tracks.id 24 | 25 | --- tracksTitleAlbumArtist: unit -> (int * string) fold 26 | 27 | select tracks.id, tracks.titlesearch || " " || 28 | ifnull(albums.titlesearch, "") || " " || 29 | ifnull(group_concat(contributors.namesearch, " "), "") as ta 30 | from tracks 31 | left outer join contributor_track ct on (ct.track = tracks.id and ct.role in (1, 5, 6)) 32 | left outer join contributors on contributors.id = ct.contributor 33 | left outer join albums on tracks.album = albums.id 34 | where tracks.audio = 1 and tracks.titlesearch is not null 35 | group by tracks.id 36 | 37 | --- artists: unit -> (int * string) fold 38 | 39 | select distinct id, namesearch from contributors 40 | left join contributor_album ca on (ca.contributor = contributors.id) 41 | where ca.role in (1, 5, 6) 42 | 43 | --- albums: unit -> (int * string) fold 44 | 45 | select id, titlesearch from albums 46 | where titlesearch is not null 47 | 48 | --- albumsArtist: unit -> (int * string) fold 49 | 50 | select albums.id, albums.titlesearch || " " || contributors.namesearch ta 51 | from albums 52 | left join contributors on contributors.id = albums.contributor 53 | where albums.contributor is not null and albums.titlesearch is not null 54 | 55 | 56 | -------------------------------------------------------------------------------- /mlmusic/index/index.cm: -------------------------------------------------------------------------------- 1 | Library 2 | structure Index 3 | is 4 | $/basis.cm 5 | $/smlnj-lib.cm 6 | 7 | ../../../stilts/db/libmysqlclient/libmysqlclient.cm 8 | ../../../stilts/db/squall/squall-tool.cm : tool 9 | ../db.sml 10 | index.squall 11 | 12 | #if (SMLNJ_VERSION = 110) andalso (SMLNJ_MINOR_VERSION < 57) 13 | pack-compat.sml 14 | #endif 15 | 16 | index.sml 17 | -------------------------------------------------------------------------------- /mlmusic/index/index.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb 3 | $(SML_LIB)/smlnj-lib/INet/inet-lib.mlb 4 | ../../util/linereader.sml 5 | ../../util/timer.sml 6 | ../../../stilts/db/sqlite/sqlite.mlb 7 | index-sqlite.squall.sml 8 | ../cli.sml 9 | ../command.sml 10 | ../startup.sml 11 | index.sml 12 | run.sml 13 | -------------------------------------------------------------------------------- /mlmusic/index/index.squall: -------------------------------------------------------------------------------- 1 | engine: mysql 2 | 3 | --- tracksTitle: unit -> (int * string) fold 4 | 5 | select id, titlesearch from tracks 6 | where tracks.audio = 1 and tracks.titlesearch is not null 7 | 8 | --- tracksTitleAlbum: unit -> (int * string) fold 9 | 10 | select tracks.id, concat(tracks.titlesearch, " ", ifnull(albums.titlesearch, "")) as ta 11 | from tracks 12 | left join albums on tracks.album = albums.id 13 | where tracks.audio = 1 and tracks.titlesearch is not null 14 | 15 | --- tracksTitleArtist: unit -> (int * string) fold 16 | 17 | select tracks.id, concat(tracks.titlesearch, " ", 18 | ifnull(group_concat(contributors.namesearch separator " "), "")) as ta 19 | from tracks 20 | left outer join contributor_track ct on (ct.track = tracks.id and ct.role in (1, 5, 6)) 21 | left outer join contributors on contributors.id = ct.contributor 22 | where tracks.audio = 1 and tracks.titlesearch is not null 23 | group by tracks.id 24 | 25 | --- tracksTitleAlbumArtist: unit -> (int * string) fold 26 | 27 | select tracks.id, concat(tracks.titlesearch, " ", 28 | ifnull(albums.titlesearch, ""), " ", 29 | ifnull(group_concat(contributors.namesearch separator " "), "")) as ta 30 | from tracks 31 | left outer join contributor_track ct on (ct.track = tracks.id and ct.role in (1, 5, 6)) 32 | left outer join contributors on contributors.id = ct.contributor 33 | left outer join albums on tracks.album = albums.id 34 | where tracks.audio = 1 and tracks.titlesearch is not null 35 | group by tracks.id 36 | 37 | --- artists: unit -> (int * string) fold 38 | 39 | select distinct id, namesearch from contributors 40 | left join contributor_album ca on (ca.contributor = contributors.id) 41 | where ca.role in (1, 5, 6) 42 | 43 | --- albums: unit -> (int * string) fold 44 | 45 | select id, titlesearch from albums 46 | where titlesearch is not null 47 | 48 | --- albumsArtist: unit -> (int * string) fold 49 | 50 | select albums.id, concat(albums.titlesearch, " ", contributors.namesearch) ta 51 | from albums 52 | left join contributors on contributors.id = albums.contributor 53 | where albums.contributor is not null and albums.titlesearch is not null 54 | 55 | -------------------------------------------------------------------------------- /mlmusic/index/pack-compat.sml: -------------------------------------------------------------------------------- 1 | structure PackWord16Little = Pack16Little 2 | structure PackWord32Little = Pack32Little 3 | structure PackWord16Big = Pack16Big 4 | structure PackWord32Big = Pack32Big 5 | -------------------------------------------------------------------------------- /mlmusic/jsonrpc.sml: -------------------------------------------------------------------------------- 1 | structure JSONRPC :> sig 2 | val request: JSON.json list -> JSON.json 3 | val unpack: string -> string -> JSON.json 4 | -> { id: string, name: string, map: JSON.json JSON.Map.map } list 5 | end 6 | = struct 7 | 8 | structure J = JSON 9 | structure HC = SimpleHTTPConnection(structure Socket = Socket 10 | structure INetSock = INetSock) 11 | 12 | val id = ref 1 : IntInf.int ref 13 | 14 | fun browseReq req = 15 | J.Object (foldl J.Map.insert' J.Map.empty [ 16 | ("id", J.Number (!id)), 17 | ("method", J.String "slim.request"), 18 | ("params", J.Array [ J.String "", J.Array req ]) 19 | ]) 20 | before id := (!id + 1) 21 | 22 | fun rpc_request conn req = let 23 | val timer = PrettyTimer.start () 24 | val body = HC.request conn ("/jsonrpc.js", 25 | [("Content-Type", "text/json")], 26 | SOME (J.fmt req)) 27 | val () = print ("JSONRPC: request " ^ PrettyTimer.print timer ^ "; " 28 | ^ Int.toString (size body) ^ " bytes\n") 29 | val timer = PrettyTimer.start () 30 | val rjson = case JSON.fromString body of 31 | NONE => (print body; raise Fail "response not json") 32 | | SOME json => json 33 | val () = print ("JSONRPC: JSON parse " ^ PrettyTimer.print timer ^ "\n") 34 | val robj = case rjson of J.Object m => m 35 | | _ => raise Fail "response not a json object" 36 | in 37 | case J.Map.find (robj, "result") of SOME res => res 38 | | _ => raise Fail "no result" 39 | end 40 | 41 | fun request rlist = let 42 | val conn = HC.new "127.0.0.1:9000" 43 | in 44 | rpc_request conn (browseReq rlist) 45 | end 46 | 47 | fun unpack loopkey namekey (J.Object m) = ( 48 | case J.Map.find (m, loopkey) of 49 | SOME (J.Array items) => List.mapPartial ( 50 | fn (J.Object om) => ( 51 | case (J.Map.find (om, "id"), J.Map.find (om, namekey)) of 52 | (SOME (J.String id), SOME (J.String name)) => 53 | SOME { id=id, name=name, map=om } 54 | | (SOME (J.Number id), SOME (J.String name)) => 55 | SOME { id=IntInf.toString id, name=name, map=om } 56 | | _ => NONE) 57 | | _ => NONE) items 58 | | _ => nil) 59 | | unpack _ _ _ = nil 60 | 61 | end 62 | -------------------------------------------------------------------------------- /mlmusic/lighttpd.conf: -------------------------------------------------------------------------------- 1 | server.modules = ( "mod_access", 2 | "mod_fastcgi", 3 | "mod_accesslog", 4 | "mod_rewrite", 5 | "mod_expire", 6 | "mod_staticfile" ) 7 | 8 | server.document-root = "/home/jacob/stilts/mlmusic" 9 | 10 | server.errorlog = "/tmp/sing-error.log" 11 | accesslog.filename = "/tmp/sing-access.log" 12 | 13 | $HTTP["url"] !~ "^/static" { 14 | fastcgi.server = ( "" => 15 | ( "127.0.0.1" => 16 | ( 17 | "host" => "127.0.0.1", 18 | "port" => 5124, 19 | "check-local" => "disable", 20 | "disable-time" => 1, 21 | ) 22 | ) 23 | ) 24 | } 25 | 26 | $HTTP["url"] =~ "^/static" { 27 | expire.url = ( "" => "access 1 years" ) 28 | } 29 | 30 | url.rewrite-once = ( "^/static/v[0-9]+/(.*)" => "/static/$1" ) 31 | 32 | mimetype.assign = ( 33 | ".html" => "text/html", 34 | ".gif" => "image/gif", 35 | ".jpg" => "image/jpeg", 36 | ".png" => "image/png", 37 | ".css" => "text/css", 38 | ".js" => "text/javascript" 39 | ) 40 | 41 | server.port = 8082 42 | -------------------------------------------------------------------------------- /mlmusic/main.sml: -------------------------------------------------------------------------------- 1 | val _ = Music.main () 2 | -------------------------------------------------------------------------------- /mlmusic/mlton-static-libgmp: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # This script calls MLton. 4 | 5 | set -e 6 | 7 | dir=`dirname "$0"` 8 | lib='/usr/lib/mlton' 9 | eval `"$lib/platform"` 10 | gcc='gcc' 11 | case "$HOST_OS" in 12 | mingw) 13 | exe='.exe' 14 | ;; 15 | *) 16 | exe='' 17 | ;; 18 | esac 19 | mlton="$lib/mlton-compile$exe" 20 | world="$lib/world.mlton" 21 | nj='sml' 22 | # Try to use the SML/NJ .arch-n-opsys 23 | if .arch-n-opsys >/dev/null 2>&1; then 24 | eval `.arch-n-opsys` 25 | njHeap="$lib/mlton.$HEAP_SUFFIX" 26 | unset `.arch-n-opsys | sed 's#=[^ ]*##g'` 27 | else 28 | njHeap="$lib/mlton.$HOST_ARCH-$HOST_OS" 29 | fi 30 | 31 | declare -a rargs 32 | case "$1" in 33 | @MLton) 34 | shift 35 | while [ "$#" -gt 0 -a "$1" != "--" ]; do 36 | rargs[${#rargs[@]}]="$1" 37 | shift 38 | done 39 | if [ "$#" -gt 0 -a "$1" == "--" ]; then 40 | shift 41 | else 42 | echo '@MLton missing --' 43 | exit 1 44 | fi 45 | ;; 46 | esac 47 | 48 | # If $mlton is executable and $world exists and is not older than 49 | # $njHeap (which exists), then use MLton, otherwise use SML/NJ. 50 | doit () { 51 | if [ -x "$mlton" -a -s "$world" -a ! "$njHeap" -nt "$world" ]; then 52 | exec "$mlton" @MLton load-world "$world" ram-slop 0.5 "${rargs[@]}" -- "$@" 53 | elif [ -s "$njHeap" ]; then 54 | exec "$nj" @SMLload="$njHeap" "$@" 55 | fi 56 | echo 'Unable to run MLton. Check that lib is set properly.' >&2 57 | exit 1 58 | } 59 | 60 | # For align-{functions,jumps,loops}, we use -m for now instead of 61 | # -f because old gcc's will barf on -f, while newer ones only warn 62 | # about -m. Someday, when we think we won't run into older gcc's, 63 | # these should be changed to -f. 64 | 65 | # You may need to add a line with -cc-opt 'I/path/to/gmp.h' so the 66 | # C compiler can find gmp.h 67 | # You may need to add a line with -link-opt '-L/path/to/libgmp' so 68 | # that the linker can find libgmp. 69 | 70 | # The darwin linker complains (loudly) about non-existent library 71 | # search paths. 72 | darwinLinkOpts='' 73 | if [ -d '/opt/local/lib' ]; then 74 | darwinLinkOpts="$darwinLinkOpts -L/opt/local/lib" 75 | fi 76 | if [ -d '/sw/lib' ]; then 77 | darwinLinkOpts="$darwinLinkOpts -L/sw/lib" 78 | fi 79 | 80 | doit "$lib" \ 81 | -cc "$gcc" \ 82 | -cc-opt-quote "-I$lib/include" \ 83 | -cc-opt '-Os' \ 84 | -cc-opt '-fno-strict-aliasing -fomit-frame-pointer -w' \ 85 | -link-opt '-lgdtoa -lm libgmp-arm.a' \ 86 | -mlb-path-map "$lib/mlb-path-map" \ 87 | -target-as-opt amd64 '-m64' \ 88 | -target-cc-opt amd64 '-m64' \ 89 | -target-cc-opt darwin \ 90 | '-I/opt/local/include -I/sw/include' \ 91 | -target-cc-opt freebsd '-I/usr/local/include' \ 92 | -target-cc-opt netbsd '-I/usr/pkg/include' \ 93 | -target-cc-opt openbsd '-I/usr/local/include' \ 94 | -target-cc-opt sparc '-m32 -mcpu=v8 -Wa,-xarch=v8plusa' \ 95 | -target-cc-opt x86 \ 96 | '-fno-strength-reduce 97 | -fschedule-insns 98 | -fschedule-insns2 99 | -malign-functions=5 100 | -malign-jumps=2 101 | -malign-loops=2' \ 102 | -target-link-opt amd64 '-m64' \ 103 | -target-link-opt darwin "$darwinLinkOpts" \ 104 | -target-link-opt freebsd '-L/usr/local/lib/' \ 105 | -target-link-opt mingw \ 106 | '-lws2_32 -lkernel32 -lpsapi -lnetapi32' \ 107 | -target-link-opt netbsd \ 108 | '-Wl,-R/usr/pkg/lib -L/usr/pkg/lib/' \ 109 | -target-link-opt openbsd '-L/usr/local/lib/' \ 110 | -target-link-opt solaris '-lnsl -lsocket -lrt' \ 111 | -profile-exclude '\$\(SML_LIB\)' \ 112 | "$@" 113 | -------------------------------------------------------------------------------- /mlmusic/music-nobrowse.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | $(SML_LIB)/smlnj-lib/RegExp/regexp-lib.mlb 3 | 4 | ann 5 | "sequenceNonUnit warn" 6 | in 7 | conf.sml 8 | ../../stilts/smelt/tinyxml/tinyxml.mlb 9 | ../../stilts/web/web.mlb 10 | ../util/linereader.sml 11 | ../util/timer.sml 12 | 13 | templates/templates.mlb 14 | 15 | ../util/json.sml 16 | ../chiralml/socket.sig 17 | ../chiralml/sock-util.sml 18 | ../chiralml/simplehttp.sml 19 | 20 | pagebar.sml 21 | clibrowser.sml 22 | cli.sml 23 | command.sml 24 | templates/playlist.html.sml 25 | player.sml 26 | music.sml 27 | main.sml 28 | end 29 | -------------------------------------------------------------------------------- /mlmusic/music.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $(SML_LIB)/basis.cm 3 | $(SML_LIB)/regexp-lib.cm 4 | $(SML_LIB)/inet-lib.cm 5 | $(SML_LIB)/smlnj-lib.cm 6 | 7 | ../../stilts/db/libmysqlclient/libmysqlclient.cm 8 | ../../stilts/db/squall/squall-tool.cm : tool 9 | music.squall 10 | 11 | ../../stilts/web/web.cm 12 | 13 | db.sml 14 | conf.sml 15 | 16 | ../util/timer.sml 17 | ../util/gc-smlnj.sml 18 | 19 | cli.sml 20 | command.sml 21 | 22 | ../../stilts/smelt/smelt-tool.cm : tool 23 | templates/index.html 24 | templates/item.html 25 | templates/list.html 26 | templates/song.html 27 | templates/search.html 28 | templates/search2.html 29 | templates/playlist.html 30 | 31 | ../util/json.sml 32 | ../chiralml/socket.sig 33 | ../chiralml/sock-util.sml 34 | ../chiralml/simplehttp.sml 35 | 36 | index/index.cm 37 | 38 | jsonrpc.sml 39 | 40 | clibrowser.sml 41 | clisonginfo.sml 42 | 43 | startup.sml 44 | 45 | pagebar.sml 46 | browser.sml 47 | search.sml 48 | player.sml 49 | music.sml 50 | 51 | index/search.sml 52 | -------------------------------------------------------------------------------- /mlmusic/music.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | $(SML_LIB)/smlnj-lib/RegExp/regexp-lib.mlb 3 | ../../stilts/db/libmysqlclient/libmysqlclient.mlb 4 | 5 | $(SML_LIB)/basis/mlton.mlb 6 | $(SML_LIB)/smlnj-lib/INet/inet-lib.mlb 7 | $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb 8 | 9 | ann 10 | "sequenceNonUnit warn" 11 | in 12 | conf.sml 13 | ../../stilts/smelt/tinyxml/tinyxml.mlb 14 | ../../stilts/web/web.mlb 15 | ../util/linereader.sml 16 | ../util/timer.sml 17 | ../util/gc-mlton.sml 18 | ../util/json.sml 19 | 20 | ../chiralml/chiralml.mlb 21 | ../chiralml/simplehttp.sml 22 | ../web/server/http-server-fn.sml 23 | chiral.sml 24 | 25 | index/index.squall.sml 26 | index/index.sml 27 | 28 | music.squall.sml 29 | 30 | squeezecenter/cli.sml 31 | squeezecenter/command.sml 32 | 33 | templates2/buttons.html.sml 34 | templates2/topbar.html.sml 35 | 36 | templates2/albumitem.html.sml 37 | templates2/artistitem.html.sml 38 | templates2/folderitem.html.sml 39 | templates2/trackitem.html.sml 40 | templates2/item.html.sml 41 | 42 | templates2/list.html.sml 43 | templates2/playlist.html.sml 44 | templates2/search.html.sml 45 | 46 | templates2/index.html.sml 47 | templates/song.html.sml 48 | 49 | squeezecenter/playercache.sml 50 | squeezecenter/player.sml 51 | 52 | jsonrpc.sml 53 | pagebar.sml 54 | db.sml 55 | request.sml 56 | 57 | browser/browser.sml 58 | browser/mfbrowser.sml 59 | 60 | clisonginfo.sml 61 | 62 | index/search.sml 63 | search.sml 64 | 65 | startup.sml 66 | music.sml 67 | main.sml 68 | end 69 | -------------------------------------------------------------------------------- /mlmusic/music.sml: -------------------------------------------------------------------------------- 1 | structure Music = struct 2 | 3 | structure U = WebUtil 4 | 5 | val escapeNQ = String.translate (fn #"<" => "<" 6 | | #"&" => "&" 7 | | c => String.str c) 8 | 9 | fun getCookie req cname = let 10 | val cookieStr = case U.http_header "HTTP_COOKIE" req of SOME s => s 11 | | NONE => "" 12 | fun isSep c = c = #" " orelse c = #";" 13 | val cookies = String.fields isSep cookieStr 14 | 15 | val cookie = List.find (String.isPrefix (cname ^ "=")) cookies 16 | in 17 | case cookie of 18 | SOME c => SOME (String.extract (c, size cname + 1, NONE)) 19 | | NONE => NONE 20 | end 21 | 22 | fun get_player_info req = let 23 | val desiredPlayer = Option.map U.urldecode (getCookie req "SqueezeCenter-player") 24 | 25 | (* Go through the cached player list doing two things: 26 | * - Find the player that the user wants; if they didn't specify one, 27 | * take the first one we find 28 | * - Assemble a list of { id, name } for all players 29 | *) 30 | fun plFolder (item : PlayerCache.player_item, (foundPlayer, acc)) = ( 31 | case (desiredPlayer, foundPlayer) of 32 | (SOME desired, SOME prev) => if (#id item = desired) then SOME item else SOME prev 33 | | (NONE, SOME prev) => SOME prev 34 | | _ => SOME item, 35 | { id = #id item, name = #name (!(#info item)) } :: acc 36 | ) 37 | 38 | val (player, playerList) = Command.Map.foldl plFolder (NONE, nil) (!PlayerCache.player_cache) 39 | 40 | (* Add a 'cur' field to indicate whether the player is selected *) 41 | val players = map (fn { id, name } => { 42 | id = id, name = name, 43 | cur = case player of SOME p => (id = #id p) | NONE => false 44 | }) playerList 45 | 46 | in 47 | (players, player) 48 | end 49 | 50 | fun index req = let 51 | 52 | val (players, player) = get_player_info req 53 | val () = print ("Player: " ^ (case player of SOME p => #id p 54 | | NONE => "NONE") ^ "\n") 55 | 56 | val initialPlaylist = case player of 57 | SOME p => TPlaylist.render (Command.playlist (#id p) 0 9999) 58 | | NONE => Web.HTML "" 59 | 60 | val initialStatus = case player of 61 | SOME { info = ref info, ... } => SOME (#status info) 62 | | NONE => NONE 63 | in 64 | U.xhtmlResp (TIndex.render { 65 | players = players, 66 | initialPlaylist = initialPlaylist, 67 | initialStatus = initialStatus 68 | }) 69 | end 70 | 71 | fun rootHandler (req: Web.request) = (case U.postpath req of 72 | nil => index req 73 | | [ "" ] => index req 74 | | [ "exit" ] => OS.Process.exit OS.Process.success 75 | | _ => raise U.notFound 76 | ) 77 | 78 | val staticApp = StaticServer.server { basepath = "static", 79 | expires = SOME (60*60*24*365), 80 | headers = nil } 81 | 82 | val app = U.dispatch [ ( [ "browse" ], U.PREFIX, Browser.browseApp ), 83 | ( [ "search", "" ], U.EXACT, SearchApp.searchApp ), 84 | ( [ "player" ], U.PREFIX, PlayerApp.playerApp ), 85 | ( [ "musicfolder" ], U.PREFIX, MFBrowser.browseApp ), 86 | ( [ "static" ], U.PREFIX, staticApp ), 87 | ( nil, U.PREFIX, rootHandler ) ] 88 | 89 | fun timer app req = let 90 | val t = PrettyTimer.start () 91 | val resp = app req 92 | val () = print ("Request time: " ^ PrettyTimer.print t ^ "\n") 93 | in 94 | resp 95 | end 96 | 97 | (* val app = timer (U.dumpRequestWrapper print (U.exnWrapper app)) 98 | *) 99 | val app = timer (U.exnWrapper app) 100 | 101 | val () = HTTPServer.addCleanupCallback GC.collectAll; 102 | val httpd = HTTPServer.spawn_server (INetSock.any 8888) app; 103 | 104 | fun main _ = ( 105 | print "Starting up...\n"; 106 | Startup.startup (); 107 | print "Listening...\n"; 108 | T.run (); 109 | 0 110 | ) 111 | 112 | end 113 | -------------------------------------------------------------------------------- /mlmusic/music2.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/basis.cm 3 | $/regexp-lib.cm 4 | $/inet-lib.cm 5 | $/smlnj-lib.cm 6 | 7 | ../../stilts/db/libmysqlclient/libmysqlclient.cm 8 | ../../stilts/db/squall/squall-tool.cm : tool 9 | music.squall 10 | 11 | ../../stilts/web/web.cm 12 | 13 | db.sml 14 | conf.sml 15 | 16 | ../util/timer.sml 17 | ../util/gc-smlnj.sml 18 | 19 | ../util/json.sml 20 | 21 | ../chiralml/chiralml.cm 22 | ../chiralml/simplehttp.sml 23 | ../web/server/http-server-fn.sml 24 | chiral.sml 25 | 26 | index/index.cm 27 | 28 | request.sml 29 | 30 | squeezecenter/cli.sml 31 | squeezecenter/command.sml 32 | squeezecenter/playercache.sml 33 | squeezecenter/player.sml 34 | 35 | ../../stilts/smelt/smelt-tool.cm : tool 36 | templates2/index.html 37 | templates2/item.html 38 | templates2/list.html 39 | templates/song.html 40 | templates2/topbar.html 41 | templates2/buttons.html 42 | templates2/trackitem.html 43 | templates2/albumitem.html 44 | templates2/artistitem.html 45 | templates2/folderitem.html 46 | templates2/search.html 47 | templates2/playlist.html 48 | 49 | 50 | jsonrpc.sml 51 | 52 | clisonginfo.sml 53 | 54 | startup.sml 55 | 56 | pagebar.sml 57 | browser/browser.sml 58 | browser/mfbrowser.sml 59 | search.sml 60 | music.sml 61 | 62 | index/search.sml 63 | -------------------------------------------------------------------------------- /mlmusic/mysql-mods.sql: -------------------------------------------------------------------------------- 1 | alter table albums modify titlesort varchar(255); 2 | alter table albums add index(titlesort, disc); 3 | alter table contributors modify namesort varchar(255); 4 | -------------------------------------------------------------------------------- /mlmusic/request.sml: -------------------------------------------------------------------------------- 1 | structure Request = struct 2 | 3 | structure U = WebUtil 4 | 5 | fun getCookie req cname = let 6 | val cookieStr = case U.http_header "HTTP_COOKIE" req of SOME s => s 7 | | NONE => "" 8 | fun isSep c = c = #" " orelse c = #";" 9 | val cookies = String.fields isSep cookieStr 10 | 11 | val cookie = List.find (String.isPrefix (cname ^ "=")) cookies 12 | in 13 | case cookie of 14 | SOME c => SOME (String.extract (c, size cname + 1, NONE)) 15 | | NONE => NONE 16 | end 17 | 18 | fun get_player_info req = let 19 | val desiredPlayer = Option.map U.urldecode (getCookie req "SqueezeCenter-player") 20 | 21 | (* Go through the cached player list doing two things: 22 | * - Find the player that the user wants; if they didn't specify one, 23 | * take the first one we find 24 | * - Assemble a list of { id, name } for all players 25 | *) 26 | fun plFolder (item : PlayerCache.player_item, (foundPlayer, acc)) = ( 27 | case (desiredPlayer, foundPlayer) of 28 | (SOME desired, SOME prev) => if (#id item = desired) then SOME item else SOME prev 29 | | (NONE, SOME prev) => SOME prev 30 | | _ => SOME item, 31 | { id = #id item, name = #name (!(#info item)) } :: acc 32 | ) 33 | 34 | val (player, playerList) = Command.Map.foldl plFolder (NONE, nil) (!PlayerCache.player_cache) 35 | 36 | (* Add a 'cur' field to indicate whether the player is selected *) 37 | val players = map (fn { id, name } => { 38 | id = id, name = name, 39 | cur = case player of SOME p => (id = #id p) | NONE => false 40 | }) playerList 41 | 42 | in 43 | (players, player) 44 | end 45 | 46 | fun get_header req = let 47 | val (players, player) = get_player_info req 48 | val status = Option.map (#status o ! o #info) player 49 | in 50 | (players, status) 51 | end 52 | 53 | end 54 | -------------------------------------------------------------------------------- /mlmusic/search.sml: -------------------------------------------------------------------------------- 1 | structure SearchApp :> sig val searchApp: Web.app end = struct 2 | 3 | structure U = WebUtil 4 | 5 | fun renderTrack { id, tracknum, title } = { 6 | id = id, 7 | name = case tracknum of NONE => title 8 | | SOME t => (Int.toString t) ^ ". " ^ title 9 | } 10 | 11 | fun search q = let 12 | val start = Timer.startRealTimer () 13 | 14 | val { artists as artistIds, 15 | albums as albumIds, 16 | tracks as songIds, time } = Search.search q 17 | 18 | val artists = case artistIds of nil => nil 19 | | _ => SQL.artistMulti artistIds 20 | val albums = case albumIds of nil => nil 21 | | _ => SQL.albumMulti albumIds 22 | val songs = case songIds of nil => nil 23 | | _ => SQL.trackMulti songIds 24 | 25 | val ttime = Timer.checkRealTimer start 26 | 27 | val () = print ("Search: done; index " ^ Real.toString ((Time.toReal time) * 1000.0) 28 | ^ " ms, total " ^ Real.toString ((Time.toReal ttime) * 1000.0) 29 | ^ " ms\n"); 30 | 31 | val opts = { artists = artists, 32 | albums = albums, 33 | songs = DB.fold_tracks songs, 34 | itime = time, 35 | ttime = ttime } 36 | in 37 | (q, SOME opts, true) 38 | end 39 | 40 | fun searchApp (req: Web.request) = let 41 | val form = Form.load req 42 | val header = Request.get_header req 43 | in 44 | U.xhtmlResp (TSearch.render ( 45 | (case Form.get form "q" of SOME q => search q | NONE => ("", NONE, true)), 46 | header 47 | )) 48 | end 49 | 50 | end 51 | -------------------------------------------------------------------------------- /mlmusic/sing-wrapper.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | exec /home/jacob/stilts/mlmusic/wrapper /home/jacob/stilts/mlmusic/sing 3 | -------------------------------------------------------------------------------- /mlmusic/squeezecenter/cli.sml: -------------------------------------------------------------------------------- 1 | signature CLI = sig 2 | 3 | type conn 4 | 5 | val connect: string * int -> conn 6 | 7 | val command: conn -> string list -> string list 8 | 9 | end 10 | 11 | structure CLI :> CLI = struct 12 | 13 | structure LR = LineReader(Socket) 14 | structure S = Socket 15 | 16 | type conn = (INetSock.inet, S.active S.stream) S.sock * LR.reader 17 | 18 | fun connect (hostname, port) = let 19 | val host = case NetHostDB.getByName hostname of 20 | SOME host => host 21 | | NONE => raise Fail ("error looking up " ^ hostname) 22 | val target = INetSock.toAddr (NetHostDB.addr host, port) 23 | val s = INetSock.TCP.socket () 24 | val () = S.connect (s, target) 25 | in 26 | (s, LR.new (s, { increment = 8192, stripCR = true })) 27 | end 28 | 29 | fun unquote v = let 30 | fun process (s, acc) = (let 31 | val vchars = Substring.string (Substring.slice (s, 0, SOME 2)) 32 | val v = Word8.fromString vchars 33 | in 34 | Substring.full (String.str (Byte.byteToChar (valOf v))) 35 | :: Substring.slice (s, 2, NONE) 36 | :: acc 37 | end 38 | handle Overflow => Substring.full "%" :: s :: acc 39 | | Subscript => Substring.full "%" :: s :: acc 40 | | Option => Substring.full "%" :: s :: acc) 41 | in 42 | case Substring.fields (fn c => c = #"%") v of 43 | nil => "" 44 | | x::rest => Substring.concat (x :: foldr process nil rest) 45 | end 46 | 47 | fun command (s, r) ins = let 48 | 49 | val timer = PrettyTimer.start () 50 | 51 | val () = print ("CLI: sending: " ^ String.concatWith " " ins ^ "\n") 52 | 53 | fun hex2 i = StringCvt.padLeft #"0" 2 (Int.fmt StringCvt.HEX i) 54 | fun quote #"-" = "-" 55 | | quote #"_" = "_" 56 | | quote #"~" = "~" 57 | | quote #"." = "." 58 | | quote c = if Char.isAlphaNum c 59 | then String.str c 60 | else "%" ^ (hex2 (Char.ord c)) 61 | 62 | val out = String.concatWith " " (map (String.translate quote) ins) 63 | 64 | val () = print ("CLI: out computed: " ^ PrettyTimer.print timer ^ "\n") 65 | 66 | val () = SockUtil.sendVec (s, Byte.stringToBytes (out ^ "\n")) 67 | val () = print ("CLI: sent: " ^ PrettyTimer.print timer ^ "\n") 68 | val resp = Byte.bytesToString (LR.readline r) 69 | val () = print ("CLI: read response: " ^ Int.toString (size resp) ^ " bytes, " ^ PrettyTimer.print timer ^ "\n") 70 | val fields = Substring.fields (fn c => c = #" ") (Substring.full resp) 71 | val () = print ("CLI: parsed fields: " ^ PrettyTimer.print timer ^ "\n") 72 | val resFields = map unquote fields 73 | 74 | val () = print ("CLI: command took " ^ PrettyTimer.print timer ^ "\n") 75 | 76 | in 77 | resFields 78 | end 79 | end 80 | -------------------------------------------------------------------------------- /mlmusic/squeezecenter/player.sml: -------------------------------------------------------------------------------- 1 | structure PlayerApp :> sig val playerApp: Web.app end = struct 2 | 3 | structure U = WebUtil 4 | 5 | fun playerApp (req: Web.request) = let 6 | val path = U.postpath req 7 | in 8 | (case path of 9 | 10 | [ player, "status" ] => let 11 | val cmdStr = Byte.bytesToString (#content req ()) 12 | val () = print ("Command: \"" ^ cmdStr ^ "\"\n") 13 | 14 | val commands = String.fields (fn c => c = #" ") cmdStr 15 | 16 | val cmd = case commands of 17 | [ "repeat" ] => SOME [ player, "playlist", "repeat" ] 18 | | [ "shuffle" ] => SOME [ player, "playlist", "shuffle" ] 19 | | [ "pause" ] => SOME [ player, "pause" ] 20 | | [ "prev" ] => SOME [ player, "playlist", "index", "-1" ] 21 | | [ "next" ] => SOME [ player, "playlist", "index", "+1" ] 22 | | [ "volup" ] => SOME [ player, "mixer", "volume", "+10" ] 23 | | [ "voldown" ] => SOME [ player, "mixer", "volume", "-10" ] 24 | | "add" :: cmds => SOME (player :: "playlistcontrol" :: "cmd:add" :: cmds) 25 | | "play" :: cmds => SOME (player :: "playlistcontrol" :: "cmd:load" :: cmds) 26 | | "pljump" :: cmds => SOME (player :: "playlist" :: "index" :: cmds) 27 | | "pldel" :: cmds => SOME (player :: "playlist" :: "delete" :: cmds) 28 | | "plmove" :: cmds => SOME (player :: "playlist" :: "move" :: cmds) 29 | | [ "" ] => NONE 30 | | _ => (print "Command: unknown command!\n"; NONE) 31 | 32 | val _ = case cmd of SOME cmd => Command.command cmd 33 | | NONE => nil 34 | in 35 | U.resp "text/plain" (Command.statusJSON (SOME (Command.statusRaw player))) 36 | end 37 | 38 | | [ player, "playlist" ] => let 39 | val (prologue, tracks) = Command.playlist player 0 9999 40 | in 41 | U.htmlResp (TPlaylist.render (prologue, tracks)) 42 | end 43 | 44 | | _ => raise U.notFound 45 | ) 46 | end 47 | 48 | 49 | end 50 | -------------------------------------------------------------------------------- /mlmusic/startup.sml: -------------------------------------------------------------------------------- 1 | structure Startup = struct 2 | 3 | fun startup () = let 4 | val () = Command.conn := SOME (CLI.connect ("localhost", 9090)) 5 | val cachedir = Command.cachedir () 6 | (* 7 | val db = SQLite.opendb (cachedir ^ "/squeezecenter.db") 8 | *) 9 | 10 | val conn_info_sock : MySQLClient.connect_info = { 11 | host = NONE, port = 0w0, unix_socket = SOME (cachedir ^ "/squeezebox-mysql.sock"), 12 | user = SOME "root", password = NONE, db = SOME "slimserver" 13 | } 14 | val db = MySQLClient.init () 15 | val () = MySQLClient.real_connect db conn_info_sock 16 | val () = MySQLClient.set_reconnect db true 17 | 18 | in 19 | SQL.prepare db; 20 | ( 21 | SearchFile.init "searchdb.idx" 22 | handle OS.SysErr _ => ( 23 | print "Rebuilding index...\n"; 24 | Index.prepare db; 25 | Index.generate "searchdb.idx"; 26 | SearchFile.init "searchdb.idx" 27 | ) 28 | ) 29 | end 30 | 31 | end 32 | -------------------------------------------------------------------------------- /mlmusic/static/.htaccess: -------------------------------------------------------------------------------- 1 | ExpiresActive On 2 | ExpiresDefault "access plus 1 year" 3 | FileETag none 4 | -------------------------------------------------------------------------------- /mlmusic/static/blank.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | [ blank.html ] 6 | 7 | 8 | -------------------------------------------------------------------------------- /mlmusic/static/home.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 38 | 39 | 40 | 41 |
12 | 13 |
14 | 15 | Home 16 |
17 | 18 |
26 | 37 |
42 | 43 | 44 | 45 | -------------------------------------------------------------------------------- /mlmusic/static/images/b_add.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/j4cbo/stilts/c7ba8cfa417dba209fe6287b99b778ef2aed7e72/mlmusic/static/images/b_add.gif -------------------------------------------------------------------------------- /mlmusic/static/images/b_play.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/j4cbo/stilts/c7ba8cfa417dba209fe6287b99b778ef2aed7e72/mlmusic/static/images/b_play.gif -------------------------------------------------------------------------------- /mlmusic/static/images/background.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/j4cbo/stilts/c7ba8cfa417dba209fe6287b99b778ef2aed7e72/mlmusic/static/images/background.png -------------------------------------------------------------------------------- /mlmusic/static/images/browse.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/j4cbo/stilts/c7ba8cfa417dba209fe6287b99b778ef2aed7e72/mlmusic/static/images/browse.gif -------------------------------------------------------------------------------- /mlmusic/static/images/controls.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/j4cbo/stilts/c7ba8cfa417dba209fe6287b99b778ef2aed7e72/mlmusic/static/images/controls.gif -------------------------------------------------------------------------------- /mlmusic/static/images/handle.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/j4cbo/stilts/c7ba8cfa417dba209fe6287b99b778ef2aed7e72/mlmusic/static/images/handle.gif -------------------------------------------------------------------------------- /mlmusic/static/images/handle2.psd: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/j4cbo/stilts/c7ba8cfa417dba209fe6287b99b778ef2aed7e72/mlmusic/static/images/handle2.psd -------------------------------------------------------------------------------- /mlmusic/static/images/icns.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/j4cbo/stilts/c7ba8cfa417dba209fe6287b99b778ef2aed7e72/mlmusic/static/images/icns.png -------------------------------------------------------------------------------- /mlmusic/static/images/icns.psd: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/j4cbo/stilts/c7ba8cfa417dba209fe6287b99b778ef2aed7e72/mlmusic/static/images/icns.psd -------------------------------------------------------------------------------- /mlmusic/static/images/volume_levels.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/j4cbo/stilts/c7ba8cfa417dba209fe6287b99b778ef2aed7e72/mlmusic/static/images/volume_levels.gif -------------------------------------------------------------------------------- /mlmusic/static/js/.gitignore: -------------------------------------------------------------------------------- 1 | sing-all.js 2 | -------------------------------------------------------------------------------- /mlmusic/static/js/Makefile: -------------------------------------------------------------------------------- 1 | SRCS = jquery-1.2.6.min.js jquery-ui-personalized-1.5.2.js sing.js 2 | 3 | sing-all.js: $(SRCS) 4 | cat $^ | ./jsmin.py > $@ 5 | 6 | dist: $(SRCS) 7 | cat $^ | ./jsmin.py > sing-all.js 8 | rm $^ jsmin.py Makefile 9 | -------------------------------------------------------------------------------- /mlmusic/static/js/sing.js: -------------------------------------------------------------------------------- 1 | (function() { 2 | 3 | var lastStatusObject = initialStatus; 4 | 5 | function curPlayer() { 6 | return $("#player").val(); 7 | } 8 | 9 | function parseStatusObject(status) { 10 | $("#prevbutton").removeClass("disabled"); 11 | $("#nextbutton").removeClass("disabled"); 12 | $("#playbutton").removeClass("disabled"); 13 | $("#voldownbutton").removeClass("disabled"); 14 | $("#volupbutton").removeClass("disabled"); 15 | 16 | /* Play/pause */ 17 | if (status.mode == "play") { 18 | $("#playbutton").addClass("pause"); 19 | } else { 20 | $("#playbutton").removeClass("pause"); 21 | } 22 | 23 | /* Repeat and shuffle */ 24 | $("#repeatbutton").removeClass(); 25 | $("#repeatbutton").addClass("r" + status["playlist repeat"]); 26 | $("#shufflebutton").removeClass(); 27 | $("#shufflebutton").addClass("s" + status["playlist shuffle"]); 28 | 29 | var volumeBars = Math.floor(status["mixer volume"] / 10.0); 30 | $("#volumebar").css( 31 | "background-position", 32 | "0 -" + (volumeBars * 22) + "px" 33 | ); 34 | } 35 | 36 | function updateCurSong(song) { 37 | $("#cstitle").html(song[0]); 38 | $("#csalbum").html(song[1]); 39 | $("#csartist").html(song[2]); 40 | } 41 | 42 | function handleStatusObject(obj) { 43 | parseStatusObject(obj[0]); 44 | updateCurSong(obj[2]); 45 | 46 | if (obj[0].playlist_timestamp != lastStatusObject[0].playlist_timestamp) { 47 | $("#playlistul").load("/player/" + curPlayer() + "/playlist"); 48 | } 49 | 50 | lastStatusObject = obj; 51 | } 52 | 53 | function updateStatus(postdata) { 54 | $.post( 55 | "/player/" + curPlayer() + "/status", 56 | postdata, 57 | function(resp) { 58 | handleStatusObject(eval("(" + resp + ")")); 59 | } 60 | ); 61 | } 62 | 63 | $.each({ 64 | "#repeatbutton": "repeat", 65 | "#shufflebutton": "shuffle", 66 | "#playbutton": "pause", 67 | "#prevbutton": "prev", 68 | "#nextbutton": "next", 69 | "#volupbutton": "volup", 70 | "#voldownbutton": "voldown" 71 | }, function(k, v) { 72 | $(k).bind("click", function() { 73 | updateStatus(v); 74 | return false; 75 | }); 76 | }); 77 | 78 | function doCommand (cmd, selectors) { 79 | updateStatus(cmd + " " + selectors); 80 | } 81 | 82 | $("#player").change(function() { 83 | document.cookie = "SqueezeCenter-player=" + escape(curPlayer()); 84 | updateStatus(""); 85 | }); 86 | 87 | handleStatusObject(initialStatus); 88 | $("#playlistul").sortable({ 89 | axis: "y", 90 | containment: "parent", 91 | handle: ".handle", 92 | cursor: "move", 93 | forcePlaceholderSize: true, 94 | opacity: 0.8, 95 | start: function(e, ui) { ui.helper.addClass("dragging"); }, 96 | revert: 100, 97 | update: function(e, ui) { 98 | var item = $(ui.item); 99 | var newidx = item.parent().children().index(ui.item); 100 | var oldidx = Number(item.attr("id").substring(1)); 101 | var offset = newidx - oldidx; 102 | if (offset >= 0) offset = "+" + offset; 103 | updateStatus("plmove " + oldidx + " " + offset); 104 | } 105 | }); 106 | /* $("#playlistul").load("/player/" + curPlayer() + "/playlist"); 107 | */ 108 | 109 | top.Sing = { 110 | ctl: { 111 | add: function(s) { doCommand ("add", s); }, 112 | play: function(s) { doCommand ("play", s); } 113 | }, 114 | pl: { 115 | play: function(s) { doCommand ("pljump", s); }, 116 | del: function(s) { doCommand ("pldel", s); } 117 | } 118 | }; 119 | }()); 120 | -------------------------------------------------------------------------------- /mlmusic/templates/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Sing 6 | 7 | 8 | 9 | 10 | 11 | 20 | 21 |
22 | 23 |
24 | 25 |
26 | 34 | 35 |
36 |
37 | 38 | 39 | 40 | 41 |
42 |
    $H{initialPlaylist}
43 |
44 |
45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | -------------------------------------------------------------------------------- /mlmusic/templates/item.html: -------------------------------------------------------------------------------- 1 | 2 |
  • 7 | 9 | 10 | ${name} 11 | ${name} 12 | ${name} 13 | 14 |
    • 15 | -------------------------------------------------------------------------------- /mlmusic/templates/list.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 59 | 60 | 61 | 62 |
    13 | 14 |
    15 | 16 | Browse: ${title} 17 |
    18 | 19 |
    20 | Home 21 | > ${name} 22 |
    23 | 24 |
    25 | ${char}${ 32 | char}​ 33 |
    34 | 35 |
    43 |
    44 |
    45 | 46 |
      47 | $H{ 48 | TListItem.render ("", "All Songs", NONE, false, allCmd', "") 49 | } 50 | $H{ 51 | perItem item 52 | 53 | } 54 |
    55 | 56 |
    57 |
    58 |
    63 | 64 | 65 | 66 | -------------------------------------------------------------------------------- /mlmusic/templates/playlist.html: -------------------------------------------------------------------------------- 1 | 2 | 4 |
  • 5 | 7 | 8 | ${ 9 | case tracknum of NONE => "" | SOME s => s ^ ". " }${title}
    10 | ${name}
    12 | ${name} 14 |
    • 15 |     16 | -------------------------------------------------------------------------------- /mlmusic/templates/search.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 104 | 105 | 106 | 107 |
    13 | 14 |
    15 | 16 | Search 17 |
    18 | 19 |
    20 | Home > Search 21 |
    22 | 23 |
    31 |
    32 |
    33 | 34 |
    35 | 36 | 37 |
    38 | 39 |
    41 | 42 |
    43 |

    Artists matching "${q}": ${Int.toString (length artists)}

    44 |
      45 | $H{ 46 | TListItem.render (id, name, SOME "/browse/artists/", appendName, "artist_id:", "") 47 | } 48 |
    49 |
    50 | 51 |
    52 |

    Albums matching "${q}": ${Int.toString (length albums)}

    53 |
      54 | $H{ 55 | TListItem.render (id, name, SOME "/browse/albums/", appendName, "album_id:", "") 56 | } 57 |
    58 |
    59 | 60 |
    61 |

    Songs matching "${q}": ${Int.toString (length songs)}

    62 | 89 |
    90 | 91 |
    92 | No search results. 93 |
    94 | 95 |

    96 | Time: ${Real.toString ((Time.toReal itime) * 1000.0)} ms index, 97 | ${Real.toString ((Time.toReal ttime) * 1000.0)} ms total 98 |

    99 | 100 |
    101 |
    102 |
    103 |
    108 | 109 | 110 | 111 | -------------------------------------------------------------------------------- /mlmusic/templates/song.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 51 | 52 | 53 |
    13 | 14 |
    15 | ${valOf title} 16 |
    17 | 18 |
    19 | Home 20 | > 21 | Song Info 22 |
    23 | 24 |
    32 |
    33 |
    34 | 35 |
      36 |
    • Title: ${valOf title}
      • 37 |
    • Year: ${Int.toString year}
      • 38 |
    • Album: ${albumTitle}
      • 39 | 40 | 41 |
    • Format: ${Int.toString (br div 1000)} kBps ${ct}
      • 42 |       43 | 44 |       45 |
    • URL: ${url}
      • 46 |
    47 | 48 |
    49 |
    50 |
    54 | 55 | 56 | 57 | -------------------------------------------------------------------------------- /mlmusic/templates/templates.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/basis.cm 3 | ../../../stilts/smelt/smelt-tool.cm : tool 4 | ../../../stilts/web/web.cm 5 | ../conf.sml 6 | index.html 7 | item.html 8 | list.html 9 | home.html 10 | song.html 11 | search.html 12 | playlist.html 13 | -------------------------------------------------------------------------------- /mlmusic/templates/templates.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | ../conf.sml 3 | ../../../stilts/web/web.mlb 4 | 5 | index.html.sml 6 | item.html.sml 7 | list.html.sml 8 | song.html.sml 9 | search.html.sml 10 | playlist.html.sml 11 | search2.html.sml 12 | -------------------------------------------------------------------------------- /mlmusic/templates2/.gitignore: -------------------------------------------------------------------------------- 1 | .cm 2 | *.html.sml 3 | -------------------------------------------------------------------------------- /mlmusic/templates2/albumitem.html: -------------------------------------------------------------------------------- 1 | 2 |
  • 3 | $H{ TButtons.render ("album_id:" ^ id) } 4 | ${name}
    5 | 6 | ${artist_name} 9 | 10 | 11 | 12 | 13 | - ${Int.toString y} 14 | 15 |
    • 16 | -------------------------------------------------------------------------------- /mlmusic/templates2/artistitem.html: -------------------------------------------------------------------------------- 1 | 2 |
  • 3 | $H{ TButtons.render ("artist_id:" ^ id) } 4 | ${name}
    5 | ${Int.toString numAlbums} ${if numAlbums = 1 then "album" else "albums"} 6 |
    • 7 | -------------------------------------------------------------------------------- /mlmusic/templates2/buttons.html: -------------------------------------------------------------------------------- 1 | 2 | Add 4 | Play 5 | 6 | -------------------------------------------------------------------------------- /mlmusic/templates2/folderitem.html: -------------------------------------------------------------------------------- 1 | 2 |
  • 3 | $H{ TButtons.render ("folder_id:" ^ id) } 4 | ${filename}
    5 |
    • 6 | -------------------------------------------------------------------------------- /mlmusic/templates2/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Sing 7 | 8 | 9 | 10 | $H{ (TTopBar.render (players, initialStatus, Command.render_header_lines initialStatus)) } 11 | 12 |

    Now Playing

    13 | 14 |
    15 |
      $H{initialPlaylist}
    16 |
    17 | 18 | 21 | 22 | 23 | 24 | 25 | -------------------------------------------------------------------------------- /mlmusic/templates2/item.html: -------------------------------------------------------------------------------- 1 | 2 |
  • 3 | $H{ TButtons.render cmd } 4 | ${name}
    5 |
    • 6 | -------------------------------------------------------------------------------- /mlmusic/templates2/list.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Sing 7 | 8 | 9 | 10 | $H{ (TTopBar.render (players, initialStatus, Command.render_header_lines initialStatus)) } 11 | 12 |

    13 | ${name} 14 |

    15 | 16 |

    17 | ${char}${ 24 | char}​ 25 |

    26 | 27 |
    28 |
      29 | $H{ all () 30 | } 31 | $H{ perItem item } 32 |
    33 |
    34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | -------------------------------------------------------------------------------- /mlmusic/templates2/playlist.html: -------------------------------------------------------------------------------- 1 | 2 | $H{ 4 | TTrackItem.render (SOME (Int.toString index)) track 5 | } 6 | -------------------------------------------------------------------------------- /mlmusic/templates2/search.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | Sing 8 | 9 | 10 | 11 | $H{ (TTopBar.render (players, initialStatus, Command.render_header_lines initialStatus)) } 12 | 13 |

    Search: ${q}

    14 | 15 |
    16 | 17 |
      18 | 19 |
    • ${Int.toString (length artists)} Artists
      • 20 | $H{ TArtistItem.render true artist } 21 | 22 |
    • ${Int.toString (length albums)} Albums
      • 23 | $H{ TAlbumItem.render true album } 24 | 25 |
    • ${Int.toString (length songs)} Songs
      • 26 | $H{ TTrackItem.render NONE song } 27 | 28 |
    • 29 | No search results. 30 |
      • 31 | 32 |

      33 | Time: ${Real.toString ((Time.toReal itime) * 1000.0)} ms index, 34 | ${Real.toString ((Time.toReal ttime) * 1000.0)} ms total 35 |

      36 | 37 |
    38 | 39 |
    40 | 41 | 44 | 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- /mlmusic/templates2/topbar.html: -------------------------------------------------------------------------------- 1 | 2 |
    3 | 4 |
    5 |
    6 | 7 | 10 |
    11 |
    12 | 13 |
    14 |
    15 | $H{Web.HTML title} 16 | $H{Web.HTML artist} 17 | $H{Web.HTML album} 18 |
    19 | 20 |
    21 | 24 |
    25 | 26 | Now Playing 27 | 28 |
    29 | 30 |
    31 | 36 |
    37 | 38 |
    39 | -------------------------------------------------------------------------------- /mlmusic/templates2/trackitem.html: -------------------------------------------------------------------------------- 1 | 2 | 3 |
  • 4 | 5 | $H{ TButtons.render ("track_id:" ^ id) } 6 | Del 8 | Play 9 | 10 | 11 | ${tracknum}. ${title}
    12 | ${name} 14 | - ${aTitle} 17 | (FLAC) 18 | (${ct} 19 | ${Int.toString (br div 1000)}kbps 20 | 21 | ) 22 | 23 | 24 |
    • 25 | -------------------------------------------------------------------------------- /smelt/.gitignore: -------------------------------------------------------------------------------- 1 | .cm 2 | smelt 3 | -------------------------------------------------------------------------------- /smelt/Makefile: -------------------------------------------------------------------------------- 1 | smelt: ../util/stream.sml tinyxml/nqx.lex tinyxml/tinyxml.sml tinyxml/tinyxml_parser.sig tinyxml/tinyxml_parser.sml templateattr.sig templateattr.sml templategen.sig templategen.sml templatecompiler.sig templatecompiler.sml smelt.sml smelt-standalone.sml 2 | mllex tinyxml/nqx.lex 3 | mlton smelt.mlb 4 | 5 | heap: 6 | ml-build smelt.cm Smelt.main heap 7 | 8 | clean: 9 | rm -rf tinyxml/nqx.lex.sml smelt heap.* .cm tinyxml/.cm 10 | -------------------------------------------------------------------------------- /smelt/README: -------------------------------------------------------------------------------- 1 | Smelt 2 | ----- 3 | 4 | Smelt is an XML templating system that precompiles input documents to SML 5 | code, allowing template processing invocations to be properly typechecked. 6 | The generated code preserializes as much of the XML document tree as possible; 7 | thus, its complexity depends only on the portions being substituted, with all 8 | static content already flattened to plain text. The XML-embedded template is 9 | heavily inspired by Kid and Genshi, two similar tools for Python, but trimmed 10 | down and with some SML-specific features. 11 | 12 | Input documents are parsed as XML. They must have a processing instruction, 13 | before the document element, of the form: 14 | 15 | 16 | 17 | The compiled template code will be a declaration of a structure, with the 18 | specified name, containing only a function "render": 19 | 20 | structure StructureName = struct 21 | val render: input bindings -> Web.HTML 22 | end 23 | 24 | Note that the input bindings are substituted into a function declaration, of 25 | the form "fun render ... = (expression)", so tuples must be parenthesized, and 26 | curried functions can be declared. 27 | 28 | Within the document, two types of processing can be specified. Tree-level 29 | manipulation can be defined with t:... attributes on elements; additionally, 30 | within attribute values and text nodes, ${expressions} can be embedded to 31 | directly insert string content. The compiled code XML-escapes all ${} 32 | substitutions. To insert snippets of prerendered HTML, use $H{expr}; this 33 | inserts a "Web.html" value literally into the output, with no further 34 | processing. 35 | 36 | Any attribute beginning with "t:" must be a valid template attribute. (Smelt 37 | is not yet namespace-aware, so this is not a namespace as such.) The following 38 | attributes are defined: 39 | 40 | - t:if="expr" (expr: bool) 41 | 42 | Only include the tagged element and its children if "expr" is true. 43 | 44 | Example:

    Math is broken!

    45 | 46 | - t:ifOption="expr as binding" (expr: 'a option) 47 | 48 | Only include the element and its children if "expr" evaluates to SOME 'a. 49 | The binding is used in a pattern-match, "case expr of SOME binding => ..."; 50 | within child nodes, all bound variables will be available. 51 | If no " as " is present in the parameter value, the while string will be 52 | used for both expr and binding: "case s of SOME s => ...". 53 | 54 | Example:

    Hello, ${name}!

    55 | 56 | - t:for="binding in expr" (expr: 'a list) 57 | 58 | Substitute this node and all its children repeated for each value in expr, 59 | with binding matched to each element in turn. 60 | 61 | Example:
    • ${i}
    62 | 63 | - t:strip="expr" 64 | 65 | "Strip" the element (meaning, include only its child elements in-place) if 66 | expr evaluates to true. As a shortcut, a blank expr is considered to always 67 | be true. 68 | 69 | - t:case="expr", t:of="binding" 70 | 71 | These two must be used together; a t:case element contains a number of 72 | child elements, each of which must contain a t:of attribute. Any text nodes 73 | that are immediate children of a t:case will be ignored if they contain only 74 | whitespace; it is an error if non-whitespace characters are found. They map 75 | as expected to a case/of expression. 76 | 77 | Example:

    Greater

    ...
    78 | 79 | For compatibility with XML's unordered attribtes, t: attributes are always 80 | processed in the following order ("outer" to "inner"), rather than in the order 81 | in which they appear in the program's source. 82 | 83 | t:of, t:for, t:ifOption, t:if, t:strip, t:case 84 | 85 | See "example.html" for some sample template code. 86 | 87 | -------------------------------------------------------------------------------- /smelt/cm.sml: -------------------------------------------------------------------------------- 1 | structure SmeltTool = struct 2 | 3 | fun smeltRule { spec as { name, mkpath, class, opts, derived }, 4 | native2pathmaker, context, defaultClassOf, sysinfo } = 5 | let 6 | val srcpath = Tools.srcpath (mkpath ()) 7 | val srcFile = (Tools.nativeSpec srcpath) 8 | val outputFile = srcFile ^ ".sml" 9 | 10 | val partial_expansion = ( 11 | { smlfiles = nil, 12 | cmfiles = nil, 13 | sources = [ (srcpath, { class = "smelt", derived = false }) ] }, 14 | [ { name = outputFile : string, 15 | mkpath = native2pathmaker outputFile, 16 | class = SOME "sml", 17 | opts = NONE, 18 | derived = true } ] 19 | ) 20 | 21 | fun rulefun () = ( 22 | if Tools.outdated "smelt" ([ outputFile ], srcFile) 23 | then (Tools.vsay [ "[smelt: compiling ", srcFile, "]\n" ]; 24 | Smelt.process_file srcFile) 25 | else (); 26 | partial_expansion 27 | ) 28 | in 29 | context rulefun 30 | end 31 | 32 | val _ = Tools.registerClass ("smelt", smeltRule) 33 | 34 | val _ = Tools.registerClassifier (Tools.SFX_CLASSIFIER (fn "html" => SOME "smelt" 35 | | "smelt" => SOME "smelt" 36 | | _ => NONE)) 37 | 38 | end 39 | -------------------------------------------------------------------------------- /smelt/example.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | hello, ${adjective} world! 4 | classy 5 |
      6 |
    • ${i}
      • 7 |
    8 |
    9 |
    10 |

    No elements in frob

    11 |

    Elements in frob

    12 |
    13 | 14 | -------------------------------------------------------------------------------- /smelt/smelt-standalone.sml: -------------------------------------------------------------------------------- 1 | val _ = OS.Process.exit (Smelt.main ()); 2 | -------------------------------------------------------------------------------- /smelt/smelt-tool.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $smlnj/cm/tools.cm 3 | smelt.cm 4 | cm.sml 5 | -------------------------------------------------------------------------------- /smelt/smelt.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/basis.cm 3 | $/smlnj-lib.cm 4 | tinyxml/tinyxml.cm 5 | templateattr.sig 6 | templateattr.sml 7 | templategen.sig 8 | templategen.sml 9 | templatecompiler.sig 10 | templatecompiler.sml 11 | smelt.sml 12 | -------------------------------------------------------------------------------- /smelt/smelt.mk: -------------------------------------------------------------------------------- 1 | SMELT_DEPS = $(shell $(MLTON) -stop f $(SMELT_PATH)/smelt.mlb) 2 | 3 | %.grm.sig %.grm.sml: %.grm 4 | mlyacc $< 5 | 6 | %.lex.sml: %.lex 7 | mllex $< 8 | 9 | $(SMELT_PATH)/smelt: $(SMELT_DEPS) 10 | $(MLTON) $(SMELT_PATH)/smelt.mlb 11 | 12 | %.html.sml: %.html $(SMELT_PATH)/smelt 13 | $(SMELT_PATH)/smelt $< 14 | -------------------------------------------------------------------------------- /smelt/smelt.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | $(SML_LIB)/smlnj-lib/Util/lib-base-sig.sml 3 | $(SML_LIB)/smlnj-lib/Util/lib-base.sml 4 | $(SML_LIB)/smlnj-lib/Util/listsort-sig.sml 5 | $(SML_LIB)/smlnj-lib/Util/list-mergesort.sml 6 | ../util/stream.sml 7 | ../util/rope.sig 8 | ../util/rope.sml 9 | tinyxml/nqx.lex.sml 10 | tinyxml/tinyxml.sml 11 | tinyxml/tinyxml_parser.sig 12 | tinyxml/tinyxml_parser.sml 13 | templateattr.sig 14 | templateattr.sml 15 | templategen.sig 16 | templategen.sml 17 | templatecompiler.sig 18 | templatecompiler.sml 19 | smelt.sml 20 | smelt-standalone.sml 21 | -------------------------------------------------------------------------------- /smelt/smelt.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Smelt wrapper script. 4 | dn="`dirname $0`" 5 | 6 | if [ -e "$dn/smelt" ] 7 | then 8 | exec "$dn/smelt" $* 9 | fi 10 | 11 | sml @SMLcmdname=$0 "@SMLload=$dn/heap" $* 12 | -------------------------------------------------------------------------------- /smelt/smelt.sml: -------------------------------------------------------------------------------- 1 | structure Smelt = struct 2 | 3 | structure XP = TinyXMLParser 4 | structure TC = TemplateCompiler 5 | structure TG = TemplateGenerator 6 | 7 | fun err msg = TextIO.output (TextIO.stdErr, String.concat msg) 8 | 9 | fun process_file filename = let 10 | val template = XP.parseFile filename 11 | val result = (TC.compile o TG.generate) template 12 | val outfile = TextIO.openOut (filename ^ ".sml") 13 | in 14 | TextIO.output (outfile, result); 15 | TextIO.closeOut outfile 16 | end 17 | 18 | fun main _ = (case CommandLine.arguments () of 19 | [ filename ] => (process_file filename; OS.Process.success) 20 | | _ => (print ("Usage: " ^ (CommandLine.name ()) 21 | ^ " templatefile\n"); 22 | OS.Process.failure 23 | )) 24 | handle e => (err [ CommandLine.name(), ": uncaught exception ", 25 | General.exnMessage e, "\n"]; 26 | OS.Process.failure) 27 | 28 | end 29 | -------------------------------------------------------------------------------- /smelt/templateattr.sig: -------------------------------------------------------------------------------- 1 | signature TEMPLATE_ATTR = 2 | sig 3 | 4 | type in_attr = TinyXML.attribute 5 | exception InvalidAttribute of in_attr 6 | 7 | type expr = string 8 | 9 | datatype attr = TAFor of expr * expr 10 | | TAIf of expr 11 | | TAIfOption of expr * expr 12 | | TAStrip of expr 13 | | TACase of expr 14 | | TAOf of expr 15 | 16 | val process: in_attr list -> (attr list * in_attr list) 17 | 18 | val separateOf: in_attr list -> (expr * in_attr list) option 19 | 20 | end 21 | -------------------------------------------------------------------------------- /smelt/templateattr.sml: -------------------------------------------------------------------------------- 1 | structure TemplateAttr :> TEMPLATE_ATTR = struct 2 | 3 | (* Attribute parsing. *) 4 | 5 | type in_attr = TinyXML.attribute 6 | exception InvalidAttribute of in_attr 7 | 8 | type expr = string 9 | 10 | datatype attr = TAFor of expr * expr 11 | | TAIf of expr 12 | | TAIfOption of expr * expr 13 | | TAStrip of expr 14 | | TACase of expr 15 | | TAOf of expr 16 | 17 | 18 | (* val isBefore: (attr * attr) -> bool 19 | * 20 | * Provide an ordering on template attributes. 21 | *) 22 | fun isBefore (a, b) = let 23 | fun ordering (TAOf _) = 6 24 | | ordering (TAFor _) = 5 25 | | ordering (TAIfOption _) = 4 26 | | ordering (TAIf _) = 3 27 | | ordering (TAStrip _) = 2 28 | | ordering (TACase _) = 1 29 | in 30 | ordering a < ordering b 31 | end 32 | 33 | 34 | (* val fromKV: in_attr -> attr 35 | * 36 | * Convert an XML attribute to a template attribute (type attr) value. 37 | *) 38 | fun fromKV (k as "t:for", v) = let 39 | val (fst, rest) = Substring.position " in " (Substring.full v) 40 | in 41 | if Substring.isPrefix " in " rest 42 | then TAFor (Substring.string fst, 43 | Substring.string (Substring.triml 4 rest)) 44 | else raise InvalidAttribute (k, v) 45 | end 46 | | fromKV ("t:if", v) = TAIf v 47 | | fromKV ("t:ifOption", v) = let 48 | val (fst, rest) = Substring.position " as " (Substring.full v) 49 | in 50 | if Substring.isPrefix " as " rest 51 | then TAIfOption (Substring.string fst, 52 | Substring.string (Substring.triml 4 rest)) 53 | else TAIfOption (v, v) 54 | end 55 | | fromKV ("t:case", v) = TACase v 56 | | fromKV ("t:of", v) = TAOf v 57 | | fromKV ("t:strip", v) = TAStrip v 58 | | fromKV (k, v) = raise InvalidAttribute (k, v) 59 | 60 | 61 | (* val orderedFromKV: in_attr list -> attr list 62 | * 63 | * Convert an (arbitrarily-ordered) list of XML attributes to an ordered 64 | * list of template attributes. 65 | *) 66 | fun orderedFromKV list = ListMergeSort.sort isBefore (map fromKV list) 67 | 68 | 69 | (* val process: in_attr list -> (attr list * in_attr list) 70 | * 71 | * Process a list of XML attributes, separating the template-language ones 72 | * from others, and then parse the template-language attributes. 73 | 74 | * If an unrecognized "t:" attribute is encoutered, this will raise an 75 | * InvalidAttribute exception with the attribute in question. 76 | *) 77 | fun process' accT accO nil = (orderedFromKV accT, accO) 78 | | process' accT accO ((k, v)::rest) = if String.isPrefix "t:" k 79 | then process' ((k, v)::accT) accO rest 80 | else process' accT ((k, v)::accO) rest 81 | val process = process' nil nil 82 | 83 | 84 | (* val separateOf: in_attr list -> (expr * in_attr list) 85 | * 86 | * Scan through the input list searching for a t:of attribute. If found, 87 | * return SOME (t:of value, other attributes); otherwise return NONE. 88 | *) 89 | fun separateOf' acc nil = NONE 90 | | separateOf' acc (("t:of", v:string)::rest) = SOME (v, acc @ rest) 91 | | separateOf' acc ((k, v)::rest) = separateOf' ((k, v)::acc) rest 92 | val separateOf = separateOf' nil 93 | 94 | end 95 | -------------------------------------------------------------------------------- /smelt/templatecompiler.sig: -------------------------------------------------------------------------------- 1 | signature TEMPLATE_COMPILER = 2 | sig 3 | 4 | val compile: string * string * TemplateGenerator.gen -> string 5 | 6 | end 7 | -------------------------------------------------------------------------------- /smelt/templatecompiler.sml: -------------------------------------------------------------------------------- 1 | structure TemplateCompiler :> TEMPLATE_COMPILER = 2 | struct 3 | structure TG = TemplateGenerator 4 | 5 | (* val mix: 'a -> 'a list -> 'a list 6 | * 7 | * Intersperse the first parameter between each element in the second list: 8 | * mix 0 [ 1, 2, 3 ] ==> [ 1, 0, 2, 0, 3 ] 9 | *) 10 | fun mix _ nil = nil 11 | | mix _ (a::nil) = a :: nil 12 | | mix sep (a::rest) = a :: sep :: mix sep rest 13 | 14 | 15 | (* val compileGen: gen -> string 16 | * 17 | * Compile gen to ML code. All keys in TG.GenSubst nodes should exist in the 18 | * surrounding environment. 19 | *) 20 | fun compileGen (TG.GenText t) = "\"" ^ String.toString t ^ "\"" 21 | | compileGen (TG.GenSubst (cvt, v)) = cvt ^ "(" ^ v ^ ")" 22 | | compileGen (TG.GenConcat gens) = String.concat [ 23 | "String.concat[", 24 | String.concat (mix "," (map compileGen gens)), 25 | "]" ] 26 | | compileGen (TG.GenIterate (var, src, tree, sep)) = String.concat [ 27 | case sep of "" => "String.concat" 28 | | _ => "String.concatWith" ^ compileGen (TG.GenText sep), 29 | "(map(fn ", var, "=>", 30 | compileGen tree, 31 | ")(", src, "))" ] 32 | | compileGen (TG.GenCaseOf (var, terms)) = String.concat [ 33 | "case ", 34 | var, 35 | " of", 36 | String.concat (mix "|" (map (fn (exp, gen) => String.concat [ 37 | "(", exp, ")=>(", 38 | compileGen gen, 39 | ")" ] 40 | ) terms)) ] 41 | 42 | 43 | (* val compile: string * string * gen -> string 44 | * 45 | * Compile gen to ML code. The first arugment is the name of the structure 46 | * to produce; the second is the type of arguments expected by gen. 47 | *) 48 | fun compile (sname, itype, gen) = String.concat [ 49 | "structure ", 50 | sname, 51 | " = struct fun render ", 52 | itype, 53 | "=Web.HTML(", 54 | compileGen gen, 55 | ") end" 56 | ] 57 | 58 | end 59 | -------------------------------------------------------------------------------- /smelt/templategen.sig: -------------------------------------------------------------------------------- 1 | signature TEMPLATE_GENERATOR = 2 | sig 3 | exception ParseError of string 4 | 5 | type expr = string 6 | datatype gen = GenText of string 7 | | GenSubst of string * expr 8 | | GenConcat of gen list 9 | | GenIterate of expr * expr * gen * string 10 | | GenCaseOf of expr * (expr * gen) list 11 | 12 | val generate: TinyXML.document -> string * string * gen 13 | 14 | 15 | val optimizeGen: gen -> gen 16 | end 17 | -------------------------------------------------------------------------------- /smelt/tinyxml/.gitignore: -------------------------------------------------------------------------------- 1 | nqx.lex.sml 2 | -------------------------------------------------------------------------------- /smelt/tinyxml/nqx.lex: -------------------------------------------------------------------------------- 1 | datatype lexresult = 2 | DATA of string 3 | | BEGINTAG of string 4 | | TAGEND 5 | | TAGSELFCLOSE 6 | | ATTRIB of string 7 | | ATTRIBVALUE of string 8 | | CLOSETAG of string 9 | | PI of string 10 | | EOF 11 | 12 | fun eof () = EOF 13 | 14 | %% 15 | 16 | %s MAIN TAG TAGBEGIN ATTNAME ATTVALUE ATTVALUEDONE DQUOT SQUOT CTAGBEGIN PIBEGIN PIDATA PIEND ; 17 | 18 | space = ([\t\n] | " "); 19 | identchar = [A-Za-z_0-9:-]; 20 | pcchar = [^<]; 21 | 22 | %% 23 | 24 | {space}* => (YYBEGIN MAIN; lex()); 25 |
    {pcchar}+ => (DATA yytext); 26 |
    "<" => ( YYBEGIN TAGBEGIN; continue() ); 27 |
    " ( YYBEGIN CTAGBEGIN; continue() ); 28 |
    " ( YYBEGIN PIBEGIN; continue() ); 29 | 30 | {identchar}+ => ( YYBEGIN TAG; BEGINTAG yytext); 31 | 32 | {space}+ => ( continue() ); 33 | {identchar}+ => ( YYBEGIN ATTNAME; ATTRIB yytext); 34 | ">" => ( YYBEGIN MAIN; TAGEND ); 35 | "/>" => ( YYBEGIN MAIN; TAGSELFCLOSE ); 36 | 37 | "=" => ( YYBEGIN ATTVALUE; continue () ); 38 | "\"" => ( YYBEGIN DQUOT; continue () ); 39 | "'" => ( YYBEGIN SQUOT; continue () ); 40 | [^"]* => ( YYBEGIN ATTVALUEDONE; ATTRIBVALUE yytext ); 41 | [^']* => ( YYBEGIN ATTVALUEDONE; ATTRIBVALUE yytext ); 42 | "\"" => ( YYBEGIN TAG; continue() ); 43 | "'" => ( YYBEGIN TAG; continue() ); 44 | 45 | {identchar}+ => ( YYBEGIN TAG; CLOSETAG yytext ); 46 | 47 | {identchar}+ => ( YYBEGIN PIDATA; PI yytext ); 48 | {space} => ( continue() ); 49 | [^\ ] [^?]* => ( YYBEGIN PIEND; DATA yytext (* XXX fix this *) ); 50 | "?>" => ( YYBEGIN MAIN; continue() ); 51 | -------------------------------------------------------------------------------- /smelt/tinyxml/tinyxml.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/basis.cm 3 | ../../util/rope.cm 4 | ../../util/stream.sml 5 | nqx.lex 6 | tinyxml.sml 7 | tinyxml_parser.sig 8 | tinyxml_parser.sml 9 | -------------------------------------------------------------------------------- /smelt/tinyxml/tinyxml.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | ../../util/rope.sig 3 | ../../util/rope.sml 4 | ../../util/stream.sml 5 | nqx.lex.sml 6 | tinyxml.sml 7 | tinyxml_parser.sig 8 | tinyxml_parser.sml 9 | -------------------------------------------------------------------------------- /smelt/tinyxml/tinyxml.sml: -------------------------------------------------------------------------------- 1 | structure TinyXML = 2 | struct 3 | type nodename = string 4 | type attribute = string * string 5 | 6 | type dtd = string 7 | 8 | datatype document = XDocument of dtd option * procinst list * element 9 | and element = XElement of nodename * attribute list * node list 10 | and procinst = XProcInst of string * string 11 | and node = XElementNode of element 12 | | XTextNode of string 13 | | XPINode of procinst 14 | 15 | fun escape t = String.translate (fn #"<" => "<" 16 | | #"&" => "&" 17 | | #"\"" => """ 18 | | c => String.str c) t 19 | 20 | fun serialize (XDocument (_, _, root)) = 21 | let 22 | fun serializeAttr (key, value) = Rope.fromStrings([ " ", key, "=\"", (escape value), "\"" ]) 23 | 24 | fun serializeNode (XTextNode t) = Rope.fromString (escape t) 25 | | serializeNode (XElementNode (XElement (tag, attrs, nodes))) = 26 | Rope.fromRopes [ 27 | Rope.fromString ("<" ^ tag), 28 | Rope.fromRopes (map serializeAttr attrs), 29 | Rope.fromString ">", 30 | Rope.fromRopes (map serializeNode nodes), 31 | Rope.fromString ("") 32 | ] 33 | | serializeNode (XPINode (XProcInst (k, v))) = 34 | Rope.fromString ("") 35 | in 36 | Rope.toString (serializeNode (XElementNode root)) 37 | end 38 | 39 | end 40 | -------------------------------------------------------------------------------- /smelt/tinyxml/tinyxml_parser.sig: -------------------------------------------------------------------------------- 1 | signature TINYXML_PARSER = 2 | sig 3 | 4 | exception ParseError 5 | 6 | val parseFile: string -> TinyXML.document 7 | 8 | end 9 | -------------------------------------------------------------------------------- /util/.gitignore: -------------------------------------------------------------------------------- 1 | .cm 2 | -------------------------------------------------------------------------------- /util/gc-mlton.sml: -------------------------------------------------------------------------------- 1 | structure GC = struct 2 | 3 | val collectAll = MLton.GC.collect 4 | 5 | end 6 | -------------------------------------------------------------------------------- /util/gc-smlnj.sml: -------------------------------------------------------------------------------- 1 | structure GC = struct 2 | 3 | fun collectAll () = SMLofNJ.Internals.GC.doGC 3 4 | 5 | end 6 | -------------------------------------------------------------------------------- /util/linereader.sml: -------------------------------------------------------------------------------- 1 | functor LineReader (S: SOCKET) :> sig 2 | 3 | type reader 4 | val new: (INetSock.inet, S.active S.stream) S.sock * { increment: int, 5 | stripCR: bool } -> reader 6 | 7 | val readline: reader -> Word8Vector.vector 8 | 9 | val readbytes: reader -> int -> Word8Vector.vector 10 | 11 | end = struct 12 | 13 | structure W8V = Word8Vector 14 | structure W8VS = Word8VectorSlice 15 | 16 | val emptyVec = W8V.fromList nil 17 | 18 | type config = { increment: int, 19 | stripCR: bool } 20 | 21 | type reader = (INetSock.inet, S.active S.stream) S.sock 22 | * config 23 | * (W8VS.slice list * int) ref 24 | 25 | fun new (sock, config) = (sock, config, ref (nil, 0)) 26 | 27 | val cr = 0wx0D: Word8.word 28 | 29 | fun isNL (_, 0wx0A: Word8.word) = true 30 | | isNL (_, _) = false 31 | 32 | fun readline (reader as (_, _, ref (nil, _))) = getMore reader readline 33 | | readline (reader as (sock, { increment, stripCR }, 34 | buf as (ref (head::backlog, len)))) = ( 35 | case W8VS.findi isNL head of 36 | NONE => getMore reader readline 37 | | SOME (pos, _) => let 38 | val pos' = if stripCR andalso pos > 0 39 | then (case W8VS.sub (head, pos - 1) of 40 | 0wx0D => pos - 1 41 | | _ => pos) 42 | else pos 43 | 44 | val headslice = W8VS.subslice (head, 0, SOME pos') 45 | 46 | val rest = case (backlog, pos, stripCR) of 47 | (blh::rest, 0, true) => let 48 | val blhl = W8VS.length blh 49 | val blh' = if W8VS.sub (blh, blhl - 1) = cr 50 | then W8VS.subslice (blh, 0, SOME (blhl - 1)) 51 | else blh 52 | in 53 | blh' :: rest 54 | end 55 | | _ => backlog 56 | 57 | val newData = W8VS.subslice (head, pos + 1, NONE) 58 | val () = buf := (newData :: nil, W8VS.length newData) 59 | in 60 | W8VS.concat (rev (headslice :: rest)) 61 | end 62 | ) 63 | 64 | and readbytes (reader as (sock, _, buf as (ref (slices, dlen)))) len = 65 | if len > dlen then getMore reader (fn r => readbytes r len) 66 | else case slices of 67 | nil => emptyVec 68 | | head :: rest => let 69 | val brkpt = W8VS.length head - (dlen - len) 70 | val newData = W8VS.subslice (head, brkpt, NONE) 71 | val () = buf := (newData :: nil, W8VS.length newData) 72 | in 73 | W8VS.concat (rev (W8VS.subslice (head, 0, SOME brkpt)::rest)) 74 | end 75 | 76 | and getMore (sock, config as { increment, stripCR }, sliceref) cont = let 77 | val (slices, len) = !sliceref 78 | val vec' = S.recvVec (sock, increment) 79 | val newLen = W8V.length vec' 80 | in 81 | if newLen = 0 then emptyVec 82 | else (sliceref := (W8VS.full vec' :: slices, len + newLen); 83 | cont (sock, config, sliceref)) 84 | end 85 | 86 | end 87 | -------------------------------------------------------------------------------- /util/rope.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/basis.cm 3 | rope.sml 4 | rope.sig 5 | -------------------------------------------------------------------------------- /util/rope.sig: -------------------------------------------------------------------------------- 1 | signature ROPE = sig 2 | 3 | eqtype rope 4 | val fromString: string -> rope 5 | val fromStrings: string list -> rope 6 | val fromRopes: rope list -> rope 7 | 8 | val toString: rope -> string 9 | 10 | end 11 | -------------------------------------------------------------------------------- /util/rope.sml: -------------------------------------------------------------------------------- 1 | structure Rope :> ROPE = 2 | struct 3 | 4 | datatype rope = RString of string 5 | | RList of rope list 6 | 7 | val fromString = RString 8 | fun fromStrings sl = RList(map RString sl) 9 | val fromRopes = RList 10 | 11 | fun toString (RString(s)) = s 12 | | toString (RList(rl)) = String.concat (map toString rl) 13 | 14 | end 15 | -------------------------------------------------------------------------------- /util/timer.sml: -------------------------------------------------------------------------------- 1 | structure PrettyTimer :> sig 2 | 3 | type timer 4 | 5 | val start: unit -> timer 6 | val print: timer -> string 7 | 8 | end = struct 9 | 10 | type timer = Timer.real_timer * Timer.cpu_timer 11 | 12 | fun start () = (Timer.startRealTimer (), Timer.startCPUTimer ()) 13 | 14 | fun print (real, cpu) = let 15 | val realTime = Timer.checkRealTimer real 16 | val { nongc, gc } = Timer.checkCPUTimes cpu 17 | fun ms time = Real.toString ((Time.toReal time) * 1000.0) 18 | in 19 | String.concat [ 20 | ms realTime, " ms total, ", ms (#usr nongc), "+", ms (#usr gc), 21 | " ms user, ", ms (#sys nongc), "+", ms (#sys gc), " ms system" 22 | ] 23 | end 24 | 25 | end 26 | -------------------------------------------------------------------------------- /util/wrapper.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | int main(int argc, char ** argv) { 6 | int devnull; 7 | 8 | if (argc < 2) { 9 | printf("Usage: %s command [args...]\n", argv[0]); 10 | return 1; 11 | } 12 | 13 | devnull = open("/dev/null", O_WRONLY); 14 | 15 | if (devnull < 0) { 16 | perror("open"); 17 | return 1; 18 | } 19 | 20 | if (devnull != 1) dup2(devnull, 1); 21 | if (devnull != 2) dup2(devnull, 2); 22 | if (devnull != 1 && devnull != 2) close(devnull); 23 | 24 | execvp(argv[1], argv + 1); 25 | 26 | return 1; 27 | } 28 | -------------------------------------------------------------------------------- /web/.gitignore: -------------------------------------------------------------------------------- 1 | .cm 2 | -------------------------------------------------------------------------------- /web/README: -------------------------------------------------------------------------------- 1 | Stilts 2 | ------ 3 | 4 | This provides the core of the Stilts web infrastructure. The following modues 5 | are defined: 6 | 7 | - Web 8 | 9 | Core web request types. 10 | 11 | The html datatype is provided to allow some type safety when dealing with 12 | both strings, which may contain any data and must not be passed directly to 13 | a browser, and HTML snippets, which are only generated by certain pieces of 14 | "safe" code. 15 | 16 | Since one may want to return content of any type (even binary data), 17 | the response type is defined using a Word8Vector.vector rather than a string 18 | or HTML datatype. 19 | 20 | - WebUtil / WEB_UTIL 21 | 22 | Useful functions for processing Web requests and responses. 23 | 24 | This contains a large collection of helper functions; they are documented 25 | indiviually in web-util.sml. 26 | 27 | 28 | - Form / FORM 29 | 30 | HTTP form handling; extracting variables from GET and POST requests. 31 | 32 | An HTTP form does not quite correspond to a mapping between values in the 33 | usual sense. Input elements are generally named uniquely, but some types of 34 | control (checkboxes, multi-select boxes) will produce multiple values for the 35 | same key; this results in encodings like key=value1&key=value2&... 36 | 37 | However, most of the time, one is only interested in one value (if any) for 38 | a key. The Form structure implements this by defining a form as a mapping from 39 | a string key to a _list_ of values, and providing helper functions to return 40 | the last-specifed value (if any) as well as all values. For flexibility, the 41 | backing ORD_MAP structure is also made available. 42 | 43 | ----------------------------------------- 44 | Notes on the prepath/postpath abstraction 45 | ----------------------------------------- 46 | 47 | Web.request records carry two pieces of path information, the "prepath" and 48 | "postpath". The concatenation of the two represents the full incoming path 49 | for the request without a leading slash. The division between the two sections 50 | represents the division between paths in the URL hierarchy "leading two" an 51 | application versus those "within" the application. The precise semantics of 52 | "application" here are intentionally somewhat loose. 53 | 54 | For example, one could use WebUtil.dispatch to build a hierarchy of what some 55 | frameworks refer to as controllers. Alternately, an app could pattern-match 56 | on the whole of its postpath, and not have to worry about where it is available 57 | on the actual Web server. 58 | 59 | At the Stilts <-> Web server boundary, prepath and postpath correspond 60 | roughly to the CGI SCRIPT_NAME and PATH_INFO variables, respectively. However, 61 | servers are not entirely consistent in how they provide these; the interface 62 | needs some robustness work. 63 | 64 | -------------------------------------------------------------------------------- /web/form.sig: -------------------------------------------------------------------------------- 1 | signature FORM = sig 2 | 3 | structure Map : ORD_MAP where type Key.ord_key = string 4 | type form = string list Map.map 5 | 6 | val load: Web.request -> form 7 | 8 | val get: form -> string -> string option 9 | val getAll: form -> string -> string list 10 | 11 | val export: form -> string 12 | val import: string -> form 13 | 14 | val dump: form -> string 15 | 16 | end 17 | -------------------------------------------------------------------------------- /web/form.sml: -------------------------------------------------------------------------------- 1 | structure Form : FORM = struct 2 | 3 | (* Types for FORM signature. *) 4 | 5 | structure Map = RedBlackMapFn (type ord_key = string 6 | val compare = String.compare) 7 | 8 | type form = string list Map.map 9 | 10 | 11 | (* val parseVars: string -> (string * string) list 12 | * 13 | * Parse out a query string (key=value&key=value&...) into a set of pairs 14 | * of (key, value). All values are URL-decoded. 15 | *) 16 | fun parseVars qstring = 17 | List.mapPartial (fn field => 18 | let 19 | val (k, v) = Substring.splitl (fn c => c <> #"=") field 20 | in 21 | SOME (Substring.string k, 22 | WebUtil.urldecode (Substring.string (Substring.slice (v, 1, NONE)))) 23 | end 24 | handle Subscript => NONE 25 | ) (Substring.fields (fn c => c = #"&") (Substring.full qstring)) 26 | 27 | 28 | (* val add_value: (string * string) * form -> form 29 | * 30 | * Insert the given value at the beginning of the values for the given key. 31 | *) 32 | fun add_value ((k, v), form) = let 33 | val existing = case Map.find (form, k) of NONE => nil | SOME vs => vs 34 | in 35 | Map.insert (form, k, v::existing) 36 | end 37 | 38 | 39 | (* val import: string -> form 40 | * 41 | * Builds a form from a query string. 42 | *) 43 | fun import str = foldl add_value Map.empty (parseVars str) 44 | 45 | 46 | (* val export: form -> string 47 | * 48 | * Exports a form into a query string format suitable for use by the "import" 49 | * function. May not properly preserve the ordering of keys with multiple 50 | * values. 51 | *) 52 | fun export form = String.concatWith "&" ( 53 | map (fn (k, vs) => 54 | String.concatWith "&" ( 55 | map (fn v => k ^ "=" ^ (WebUtil.urlencode v)) vs 56 | ) 57 | ) (Map.listItemsi form) 58 | ) 59 | 60 | 61 | (* val load: Web.request -> form 62 | * 63 | * Parse all form variables out of a request. 64 | * 65 | * If the request is GET, only the query string is parsed; if it is a POST 66 | * of application/x-www-form-urlencoded data, that content is loaded as well. 67 | *) 68 | fun load (req: Web.request) = let 69 | val form = import (#query_string req) 70 | val content_type = case WebUtil.server_header "CONTENT_TYPE" req of 71 | SOME ct => SOME ct 72 | | NONE => WebUtil.http_header "HTTP_CONTENT_TYPE" req 73 | val postVars = case (#method req, content_type) of 74 | ("POST", SOME "application/x-www-form-urlencoded") => 75 | parseVars (Byte.bytesToString (#content req ())) 76 | | _ => nil 77 | in 78 | foldl add_value form postVars 79 | end 80 | 81 | 82 | (* val get: form -> string -> string option 83 | * 84 | * Return the most-recenty-specified value for the given key in the form, 85 | * if any. 86 | *) 87 | fun get f k = case Map.find (f, k) of NONE => NONE 88 | | SOME nil => NONE 89 | | SOME (v::vs) => SOME v 90 | 91 | 92 | (* val getAll: form -> string -> string list 93 | * 94 | * Return all values for the given key in the form, in the order specified. 95 | *) 96 | fun getAll f k = case Map.find (f, k) of NONE => [] 97 | | SOME vs => rev vs 98 | 99 | 100 | (* val dump: form -> string 101 | * 102 | * Return a multiline string of all keys and values in the form which is 103 | * nominally human-readable and useful for debugging. 104 | *) 105 | fun dump form = String.concat ( 106 | map (fn (k, vs) => 107 | "- \"" ^ k ^ "\": " 108 | ^ (String.concatWith ", " (map (fn v => "\""^v^"\"") vs)) 109 | ^ "\n" 110 | ) (Map.listItemsi form) 111 | ) 112 | end 113 | -------------------------------------------------------------------------------- /web/http-date.sml: -------------------------------------------------------------------------------- 1 | structure HTTPDate :> sig 2 | 3 | (* Format dates in HTTP format. 4 | * 5 | * We cannot use the Date.fmt function in the basis library for this, because 6 | * it uses the current locale (and the current locale's names for days of 7 | * week and months), rather than the universal RFC 1123 date format. 8 | *) 9 | 10 | val format: Date.date -> string 11 | 12 | end = struct 13 | 14 | structure D = Date 15 | val format_wd = fn D.Mon => "Mon" | D.Tue => "Tue" | D.Wed => "Wed" 16 | | D.Thu => "Thu" | D.Fri => "Fri" | D.Sat => "Sat" 17 | | D.Sun => "Sun" 18 | 19 | val format_mon = fn D.Jan => "Jan" | D.Feb => "Feb" | D.Mar => "Mar" 20 | | D.Apr => "Apr" | D.May => "May" | D.Jun => "Jun" 21 | | D.Jul => "Jul" | D.Aug => "Aug" | D.Sep => "Sep" 22 | | D.Oct => "Oct" | D.Nov => "Nov" | D.Dec => "Dec" 23 | 24 | fun format date = let 25 | fun lz2 num = let val str = Int.toString num 26 | in case size str of 1 => "0" ^ str | _ => str end 27 | in 28 | String.concat [ 29 | format_wd (D.weekDay date), ", ", lz2 (D.day date), " ", 30 | format_mon (D.month date), " ", Int.toString (D.year date), " ", 31 | lz2 (D.hour date), ":", lz2 (D.minute date), ":", 32 | lz2 (D.second date), " GMT" ] 33 | end 34 | 35 | end 36 | 37 | -------------------------------------------------------------------------------- /web/pack-compat.sml: -------------------------------------------------------------------------------- 1 | structure PackWord16Little = Pack16Little 2 | structure PackWord32Little = Pack32Little 3 | structure PackWord16Big = Pack16Big 4 | structure PackWord32Big = Pack32Big 5 | -------------------------------------------------------------------------------- /web/server/.gitignore: -------------------------------------------------------------------------------- 1 | .cm 2 | -------------------------------------------------------------------------------- /web/server/cgi.sml: -------------------------------------------------------------------------------- 1 | structure CGI = struct 2 | 3 | exception ProtocolError 4 | 5 | (* val make_request: (string * string) list * int * (unit -> string) 6 | * -> Web.request 7 | * 8 | * Assemble CGI headers and a body reader function into a Web.request record. 9 | *) 10 | fun make_request (headers, content_length, content_reader) : Web.request = 11 | let 12 | (* Loop through all the headers and sort them out: HTTP, server, or 13 | * specially-handled. *) 14 | 15 | val remote_addr = ref "" 16 | val remote_port = ref "" 17 | val request_method = ref "" 18 | val script_name = ref "" 19 | val path_info = ref "" 20 | val query_string = ref "" 21 | val document_root = ref "" 22 | val server_addr = ref "" 23 | val server_name = ref "" 24 | val server_port = ref "" 25 | 26 | val process_key = (fn 27 | (("REMOTE_ADDR", v), acc) => (remote_addr := v; acc) 28 | | (("REMOTE_PORT", v), acc) => (remote_port := v; acc) 29 | | (("REQUEST_METHOD", v), acc) => (request_method := v; acc) 30 | | (("SCRIPT_NAME", v), acc) => (script_name := v; acc) 31 | | (("PATH_INFO", v), acc) => (path_info := v; acc) 32 | | (("QUERY_STRING", v), acc) => (query_string := v; acc) 33 | | (("DOCUMENT_ROOT", v), acc) => (document_root := v; acc) 34 | | (("SERVER_ADDR", v), acc) => (server_addr := v; acc) 35 | | (("SERVER_NAME", v), acc) => (server_name := v; acc) 36 | | (("SERVER_PORT", v), acc) => (server_port := v; acc) 37 | | ((k, v), (http_headers, other_headers)) => 38 | if String.isPrefix "HTTP_" k 39 | then (((k, v)::http_headers), other_headers) 40 | else (http_headers, ((k, v)::other_headers)) 41 | ) 42 | 43 | val (http_headers, server_headers) = foldl process_key (nil, nil) headers 44 | 45 | (* Parse out client and server port numbers *) 46 | val client = case Int.fromString (!remote_port) of 47 | SOME i => (!remote_addr, i) 48 | | NONE => raise ProtocolError 49 | handle Overflow => raise ProtocolError 50 | 51 | val server = case Int.fromString (!server_port) of 52 | SOME i => (!server_addr, i) 53 | | NONE => raise ProtocolError 54 | handle Overflow => raise ProtocolError 55 | 56 | (* Split the path, dropping leading / if necessary *) 57 | val splitSlash = String.fields (fn c => c = #"/") 58 | val pre = case splitSlash (!script_name) of (""::p) => p | p => p 59 | val post = case splitSlash (!path_info) of (""::p) => p | p => p 60 | 61 | (* If no postpath is provided, the prepath should probably be there... *) 62 | val (pre, post) = case (pre, post) of (x, nil) => (nil, x) | x => x 63 | in 64 | { 65 | client = client, method = !request_method, path = (pre, post), 66 | query_string = !query_string, content_length = content_length, 67 | content = content_reader, doc_root = !document_root, 68 | server_name = !server_name, server_bind = server, 69 | http_headers = http_headers, server_headers = server_headers 70 | } 71 | end 72 | 73 | 74 | (* val make_response: Web.header * string -> string 75 | * 76 | * Concatenate together output headers and content into a CGI-style response. 77 | *) 78 | fun make_response (headers, body) = let 79 | fun headerLine (k, v) = k ^ ": " ^ v ^ "\r\n" 80 | in 81 | Word8Vector.concat [ 82 | Byte.stringToBytes (String.concat (map headerLine headers)), 83 | Byte.stringToBytes "\r\n", 84 | body ] 85 | end 86 | 87 | end 88 | -------------------------------------------------------------------------------- /web/server/fastcgi-mlton.sml: -------------------------------------------------------------------------------- 1 | structure FastCGIServer :> WEB_SERVER where type opts = INetSock.sock_addr = struct 2 | 3 | structure FS = Posix.FileSys 4 | 5 | type opts = INetSock.sock_addr 6 | 7 | val callbacks : (unit -> unit) list ref = ref nil 8 | 9 | fun addCleanupCallback f = callbacks := (f :: !callbacks) 10 | 11 | fun serve addr application = 12 | let 13 | val sock = case FS.ST.isSock (FS.fstat FS.stdin) of 14 | true => MLton.Socket.fdToSock FS.stdin 15 | | false => let 16 | val listener = INetSock.TCP.socket () 17 | val () = Socket.Ctl.setREUSEADDR (listener, true); 18 | val () = Socket.bind (listener, addr); 19 | in 20 | listener 21 | end 22 | val () = Socket.listen (sock, 10); 23 | fun acceptLoop () = let 24 | val conn = Socket.accept sock 25 | val () = FastCGICommon.serveConn application conn 26 | val () = List.app (fn f => f ()) (!callbacks) 27 | in 28 | acceptLoop () 29 | end 30 | in 31 | acceptLoop () 32 | handle x => (Socket.close sock; raise x) 33 | end 34 | 35 | end 36 | -------------------------------------------------------------------------------- /web/server/http-server-fn.sml: -------------------------------------------------------------------------------- 1 | (* functor HTTPServerFn 2 | * 3 | * Chiral version of the HTTP server. This is distinct from the non-Chiral 4 | * version in supporting keep-alive; the single-threaed version can only handle 5 | * one request per connection. 6 | *) 7 | 8 | functor HTTPServerFn ( 9 | structure CS : CHIRAL_SOCKET 10 | structure T : THREAD 11 | ) 12 | = 13 | struct 14 | 15 | val server_name = "Stilts-HTTPd/0.1" 16 | 17 | structure Handler = HTTPHandlerFn( 18 | structure S = CS.Socket 19 | val can_keep_alive = true 20 | val server_name = server_name 21 | ) 22 | 23 | type opts = CS.INetSock.sock_addr 24 | 25 | fun spawn_server addr application = 26 | let 27 | val listener = CS.INetSock.TCP.socket () 28 | 29 | val (server_host, server_port) = CS.INetSock.fromAddr addr 30 | val sbind = (NetHostDB.toString server_host, server_port) 31 | 32 | val connServer = Handler.serve_conn (server_name, sbind, nil) application 33 | 34 | fun accept () = let 35 | val () = print "accept\n" 36 | val conn = CS.Socket.accept listener 37 | val t = T.new (connServer conn) 38 | in 39 | accept () 40 | end 41 | 42 | fun app () = ( 43 | CS.Socket.Ctl.setREUSEADDR (listener, true); 44 | CS.Socket.bind (listener, addr); 45 | CS.Socket.listen (listener, 9); 46 | accept () 47 | ) handle x => (CS.Socket.close listener; raise x) 48 | 49 | in 50 | T.new app 51 | end 52 | 53 | end 54 | -------------------------------------------------------------------------------- /web/server/http-server.sml: -------------------------------------------------------------------------------- 1 | structure HTTPServer :> WEB_SERVER where type opts = INetSock.sock_addr = struct 2 | 3 | val server_name = "Stilts-HTTPd/0.1" 4 | 5 | structure Handler = HTTPHandlerFn( 6 | structure S = Socket 7 | val can_keep_alive = true 8 | val server_name = server_name 9 | ) 10 | 11 | val addCleanupCallback = Handler.addCleanupCallback 12 | type opts = INetSock.sock_addr 13 | 14 | fun serve addr application = 15 | let 16 | val listener = INetSock.TCP.socket () 17 | 18 | val (server_host, server_port) = INetSock.fromAddr addr 19 | val sbind = (NetHostDB.toString server_host, server_port) 20 | 21 | fun accept () = (( 22 | Handler.serve_conn (server_name, sbind, nil) 23 | application 24 | (Socket.accept listener); 25 | accept () 26 | ) handle _ => accept ()) 27 | in 28 | ( 29 | Socket.Ctl.setREUSEADDR (listener, true); 30 | Socket.bind (listener, addr); 31 | Socket.listen (listener, 9); 32 | accept () 33 | ) handle x => (Socket.close listener; raise x) 34 | end 35 | 36 | end 37 | -------------------------------------------------------------------------------- /web/server/scgi-server.sml: -------------------------------------------------------------------------------- 1 | structure SCGIServer :> WEB_SERVER where type opts = INetSock.sock_addr = struct 2 | 3 | exception ProtocolError 4 | 5 | val callbacks : (unit -> unit) list ref = ref nil 6 | 7 | fun addCleanupCallback f = callbacks := (f :: !callbacks) 8 | 9 | (* val pairs: 'a list -> ('a * 'a) list 10 | 11 | Combine a list of even length into pairs of adjacent elements: 12 | [ a, b, c, d, e, f ] ==> [ (a, b), (c, d), (e, f) ] 13 | 14 | A trailing element, if present, will be ignored. 15 | *) 16 | fun pairs nil = nil 17 | | pairs (_::nil) = nil 18 | | pairs (a::(b::r)) = (a, b)::(pairs r) 19 | 20 | 21 | fun serveConn application (conn, conn_addr) = 22 | let 23 | 24 | fun read_length (sock, max) = let 25 | val delim = Byte.charToByte #":" 26 | fun loop (acc, n) = let 27 | val c = Word8Vector.sub (Socket.recvVec (sock, 1), 0) 28 | in 29 | if c = delim 30 | then rev acc 31 | else if n < max 32 | then loop (c :: acc, n + 1) 33 | else raise ProtocolError 34 | end 35 | in 36 | Byte.bytesToString (Word8Vector.fromList (loop (nil, 0))) 37 | end 38 | 39 | (* Parse request netstring *) 40 | val request_len = case Int.fromString (read_length (conn, 10)) of 41 | SOME i => i 42 | | NONE => raise ProtocolError 43 | handle Overflow => raise ProtocolError 44 | 45 | (* Read the request and split fields *) 46 | val req_data = Word8VectorSlice.slice ( 47 | SockUtil.recvVec (conn, request_len + 1), 48 | 0, 49 | SOME request_len 50 | ) 51 | val req_headers = pairs (String.fields (fn c => c = #"\000") 52 | (Byte.unpackStringVec req_data)) 53 | 54 | (* Get the content length and prepare to read the body *) 55 | val (content_length, req_headers) = case req_headers of 56 | (("CONTENT_LENGTH", n)::r) => (case (Int.fromString n) of 57 | SOME i => (i, r) 58 | | NONE => raise ProtocolError) 59 | | _ => raise ProtocolError 60 | 61 | val content_cache : Word8Vector.vector option ref = ref NONE 62 | 63 | fun reader () = 64 | case !content_cache of 65 | SOME c => c 66 | | NONE => let 67 | val c = SockUtil.recvVec (conn, content_length) 68 | in 69 | content_cache := SOME c; 70 | c 71 | end 72 | 73 | val request = CGI.make_request (req_headers, content_length, reader) 74 | 75 | (* GO GO GO! *) 76 | val response = CGI.make_response (application request) 77 | 78 | val () = SockUtil.sendVec (conn, response) 79 | val () = Socket.close conn 80 | 81 | val () = List.app (fn f => f ()) (!callbacks) 82 | in 83 | () 84 | end 85 | handle ProtocolError => Socket.close conn 86 | handle x => (Socket.close conn; raise x) 87 | 88 | 89 | type opts = INetSock.sock_addr 90 | 91 | fun serve addr application = 92 | let 93 | val listener = INetSock.TCP.socket () 94 | 95 | fun accept () = ( 96 | serveConn application (Socket.accept listener); 97 | accept () 98 | ) 99 | in 100 | ( 101 | Socket.Ctl.setREUSEADDR (listener, true); 102 | Socket.bind (listener, addr); 103 | Socket.listen (listener, 9); 104 | accept () 105 | ) handle x => (Socket.close listener; raise x) 106 | end 107 | 108 | end 109 | -------------------------------------------------------------------------------- /web/static-server.sml: -------------------------------------------------------------------------------- 1 | structure StaticServer :> sig 2 | 3 | val server: { basepath: string, 4 | expires: LargeInt.int option, 5 | headers: Web.header list } -> Web.app 6 | 7 | end = struct 8 | 9 | structure U = WebUtil 10 | 11 | val content_type = fn 12 | "png" => "image/png" 13 | | "gif" => "image/gif" 14 | | "jpg" => "image/jpeg" 15 | | "css" => "text/css" 16 | | "js" => "text/javascript" 17 | | "html" => "text/html" 18 | | _ => "text/plain" 19 | 20 | fun server { basepath, expires, headers } (req: Web.request) = let 21 | 22 | val (_, reqPath) = #path req 23 | 24 | fun isBad ".." = true 25 | | isBad _ = false 26 | 27 | val () = if List.exists isBad reqPath then raise U.notFound else () 28 | 29 | val reqPathStr = OS.Path.toString { isAbs = false, vol = "", 30 | arcs = basepath :: reqPath } 31 | 32 | val stream = BinIO.openIn reqPathStr 33 | val data = BinIO.inputAll stream 34 | val () = BinIO.closeIn stream 35 | 36 | val { ext, ... } = OS.Path.splitBaseExt reqPathStr 37 | 38 | val ct = content_type (case ext of SOME e => e | NONE => "") 39 | 40 | val formatTime = HTTPDate.format o Date.fromTimeUniv 41 | val now = Time.now () 42 | 43 | val headers = ("Content-Type", ct) 44 | :: ("Date", formatTime now) 45 | :: headers 46 | 47 | val headers = case expires of 48 | NONE => headers 49 | | SOME secs => ("Expires", 50 | formatTime (Time.+ (now, Time.fromSeconds secs))) 51 | :: headers 52 | in 53 | (headers, data) 54 | end 55 | handle Io => raise U.notFound 56 | 57 | end 58 | -------------------------------------------------------------------------------- /web/web-util.sig: -------------------------------------------------------------------------------- 1 | signature WEB_UTIL = sig 2 | 3 | (* Debugging *) 4 | val dumpRequest: Web.request -> string 5 | val dumpRequestWrapper: (string -> unit) -> Web.app -> Web.app 6 | 7 | (* Path extraction and manipulation *) 8 | val withPath: Web.pathsec * Web.pathsec -> Web.request -> Web.request 9 | val prepath: Web.request -> Web.pathsec 10 | val postpath: Web.request -> Web.pathsec 11 | val flattenPath: Web.pathsec * Web.pathsec -> string 12 | 13 | (* Other request accessors *) 14 | val http_header: string -> Web.request -> string option 15 | val server_header: string -> Web.request -> string option 16 | 17 | (* Exception handling, and some shortcuts for common exceptions *) 18 | val httpExnCode: Web.http_exn -> string 19 | val exnWrapper: Web.app -> Web.app 20 | val notFound: exn 21 | val redirect: string -> exn 22 | val redirectPostpath: Web.request -> Web.pathsec -> exn 23 | 24 | (* Wrappers to build a Web.response *) 25 | val resp: string -> string -> Web.response 26 | val htmlResp: Web.html -> Web.response 27 | val xhtmlResp: Web.html -> Web.response 28 | 29 | (* HTML escaping *) 30 | val escapeStr: string -> string 31 | val escape: string -> Web.html 32 | val escapeForJS: string -> Web.html 33 | 34 | (* Dispatching and automatic redirection *) 35 | datatype dispatchmode = EXACT | PREFIX | SLASH 36 | val dispatch: (Web.pathsec * dispatchmode * Web.app) list -> Web.app 37 | val forceSlash: Web.app -> Web.app 38 | 39 | (* URL-encoding *) 40 | val urlencode: string -> string 41 | val urldecode: string -> string 42 | 43 | end 44 | -------------------------------------------------------------------------------- /web/web.cm: -------------------------------------------------------------------------------- 1 | Library 2 | structure Web 3 | signature WEB_UTIL 4 | structure WebUtil 5 | signature FORM 6 | structure Form 7 | structure HTTPDate 8 | structure StaticServer 9 | structure CGI 10 | structure HTTPServer 11 | structure SCGIServer 12 | structure FastCGIServer 13 | functor HTTPHandlerFn 14 | functor LineReader 15 | is 16 | $/basis.cm 17 | $/smlnj-lib.cm 18 | $/inet-lib.cm 19 | web.sml 20 | web-util.sig 21 | web-util.sml 22 | form.sig 23 | form.sml 24 | http-date.sml 25 | static-server.sml 26 | ../util/linereader.sml 27 | server/cgi.sml 28 | server/http-server.sml 29 | server/scgi-server.sml 30 | server/fastcgi-server.sml 31 | server/http-handler-fn.sml 32 | #if (SMLNJ_VERSION = 110) andalso (SMLNJ_MINOR_VERSION < 57) 33 | pack-compat.sml 34 | #endif 35 | -------------------------------------------------------------------------------- /web/web.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | $(SML_LIB)/basis/mlton.mlb 4 | $(SML_LIB)/smlnj-lib/INet/inet-lib.mlb 5 | web.sml 6 | web-util.sig 7 | web-util.sml 8 | $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb 9 | form.sig 10 | form.sml 11 | http-date.sml 12 | static-server.sml 13 | ../util/linereader.sml 14 | server/cgi.sml 15 | server/scgi-server.sml 16 | server/http-handler-fn.sml 17 | server/http-server.sml 18 | server/fastcgi-common.sml 19 | server/fastcgi-mlton.sml 20 | in 21 | structure Web 22 | 23 | signature WEB_UTIL 24 | structure WebUtil 25 | 26 | signature FORM 27 | structure Form 28 | 29 | structure HTTPDate 30 | 31 | structure StaticServer 32 | structure CGI 33 | structure SCGIServer 34 | structure FastCGIServer 35 | structure HTTPServer 36 | 37 | functor HTTPHandlerFn 38 | end 39 | -------------------------------------------------------------------------------- /web/web.sml: -------------------------------------------------------------------------------- 1 | structure Web = struct 2 | 3 | type header = string * string 4 | type hostport = string * int 5 | type pathsec = string list 6 | 7 | type request = { 8 | (* Client connection *) 9 | client: hostport, 10 | 11 | (* GET, POST, etc. *) 12 | method: string, 13 | 14 | (* The path is divied into two parts: the prepath is 15 | the portion of the URL hierarchy leading up to the 16 | application's root, and the postpath is everything 17 | after. Paths with a trailing slash are represented with 18 | an empty string at the end of postpath. 19 | 20 | Invariants: 21 | - An empty path component may only occur as the last 22 | item in postpath; never elsewhere in postpath or 23 | anywhere in prepath. 24 | - Either prepath or postpath may be nil, but not both. 25 | The absolute root must therefore be represented as: 26 | (nil, [""]) 27 | *) 28 | path: pathsec * pathsec, 29 | query_string: string, 30 | 31 | (* HTTP headers are passed as in CGI/SCGI: upper case, 32 | with an HTTP_ prefix. The order is not specified. 33 | *) 34 | http_headers: header list, 35 | 36 | (* Request content is read on demand, to allow applications 37 | to reject excessive amounts of data. The interface does 38 | not yet allow incremental reading of data. 39 | *) 40 | content_length: int, 41 | content: unit -> Word8Vector.vector, 42 | 43 | (* Server *) 44 | doc_root: string, 45 | server_name: string, 46 | server_bind: hostport, 47 | server_headers: header list 48 | } 49 | 50 | type response = header list * Word8Vector.vector 51 | 52 | type app = request -> response 53 | 54 | type 'a server = 'a -> app -> unit 55 | 56 | datatype html = HTML of string 57 | 58 | (* HTTP error and redirect codes *) 59 | datatype http_exn = HTTP300MultipleChoices 60 | | HTTP301Moved of string 61 | | HTTP302Found of string 62 | | HTTP303SeeOther of string 63 | | HTTP304NotModified 64 | | HTTP305UseProxy of string 65 | | HTTP307TemporaryRedirect of string 66 | | HTTP400BadRequest 67 | | HTTP401Unauthorized 68 | | HTTP403Forbidden 69 | | HTTP404NotFound 70 | | HTTP405MethodNotAllowed 71 | | HTTP406NotAcceptable 72 | | HTTP407ProxAuthReq 73 | | HTTP408RequestTimeout 74 | | HTTP409Conflict 75 | | HTTP410Gone 76 | | HTTP411LengthRequired 77 | | HTTP412PreconditionFailed 78 | | HTTP413ReqEntityTooLarge 79 | | HTTP414ReqURITooLong 80 | | HTTP415UnsuppMediaType 81 | | HTTP416RangeNotSatisfiable 82 | | HTTP417ExpectationFailed 83 | | HTTP500InternalServerError of string 84 | | HTTP501NotImplemented 85 | | HTTP502BadGateway 86 | | HTTP503ServiceUnavailable 87 | | HTTP504GatewayTimeout 88 | | HTTP505VersionNotSupported 89 | 90 | exception HTTPExn of http_exn 91 | 92 | end 93 | 94 | signature WEB_SERVER = sig 95 | 96 | type opts 97 | 98 | val serve : opts Web.server 99 | 100 | val addCleanupCallback: (unit -> unit) -> unit 101 | 102 | end 103 | -------------------------------------------------------------------------------- /wiki/.gitignore: -------------------------------------------------------------------------------- 1 | .cm 2 | wiki 3 | wiki.db 4 | *.squall.sml 5 | -------------------------------------------------------------------------------- /wiki/chiral.sml: -------------------------------------------------------------------------------- 1 | structure T = Thread (structure T = ThreadBase 2 | structure RC = SelectReactorCore 3 | structure C = ConfigPrintEverything) 4 | 5 | structure CV = CondVar(T) 6 | structure CS = ChiralSocketFn(T) 7 | structure SU = ChiralSockUtil(CS) 8 | structure LR = LineReader(CS.Socket) 9 | 10 | structure HTTPServer = HTTPServerFn(structure CS = CS structure T = T) 11 | 12 | -------------------------------------------------------------------------------- /wiki/lighttpd.conf: -------------------------------------------------------------------------------- 1 | server.modules = ( "mod_access", 2 | "mod_fastcgi", 3 | "mod_accesslog", 4 | "mod_rewrite", 5 | "mod_staticfile" ) 6 | 7 | server.document-root = "/Library/WebServer/Documents" 8 | server.event-handler = "freebsd-kqueue" # on Mac OS X or FreeBSD 9 | 10 | # server.errorlog = "/tmp/lighttpd.error.log" 11 | accesslog.filename = "/tmp/access.log" 12 | 13 | fastcgi.server = ( "" => 14 | ( "127.0.0.1" => 15 | ( 16 | "host" => "127.0.0.1", 17 | "port" => 5124, 18 | "check-local" => "disable", 19 | "disable-time" => 1, 20 | ) 21 | ) 22 | ) 23 | 24 | server.port = 8080 25 | -------------------------------------------------------------------------------- /wiki/main.sml: -------------------------------------------------------------------------------- 1 | val _ = Wiki.main () 2 | -------------------------------------------------------------------------------- /wiki/templates/edit.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Wiki: ${title} 5 | 6 | 7 |

    Wiki: ${title}

    8 |

    This page does not exist yet. You can create it now:

    9 |
    10 | 11 |
    12 | 13 | 14 |
    15 |

    Put text in [squarebrackets] to make it a Wiki link.

    16 | 17 | 18 | -------------------------------------------------------------------------------- /wiki/templates/page.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Wiki: ${title} 5 | 6 | 7 |

    Wiki: ${title}

    8 |

    9 | $H{body} 10 |

    11 | edit 12 | 13 | 14 | -------------------------------------------------------------------------------- /wiki/templates/templates.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/basis.cm 3 | ../../smelt/smelt-tool.cm : tool 4 | ../../web/web.cm 5 | page.html 6 | edit.html 7 | -------------------------------------------------------------------------------- /wiki/wiki-mysql.ddl: -------------------------------------------------------------------------------- 1 | drop table if exists page; 2 | create table page ( 3 | id int primary key not null auto_increment, 4 | title char(50) unique not null, 5 | text text 6 | ); 7 | 8 | -------------------------------------------------------------------------------- /wiki/wiki-sqlite.ddl: -------------------------------------------------------------------------------- 1 | drop table if exists page; 2 | create table page ( 3 | id integer primary key autoincrement not null, 4 | title char(50) unique not null, 5 | text text 6 | ); 7 | 8 | -------------------------------------------------------------------------------- /wiki/wiki.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/basis.cm 3 | $/regexp-lib.cm 4 | 5 | ../db/sqlite/sqlite.cm 6 | ../db/squall/squall-tool.cm : tool 7 | wiki.squall 8 | 9 | ../web/web.cm 10 | 11 | ../chiralml/chiralml.cm 12 | ../web/server/http-server-fn.sml 13 | chiral.sml 14 | 15 | templates/templates.cm 16 | wiki.sml 17 | -------------------------------------------------------------------------------- /wiki/wiki.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | $(SML_LIB)/smlnj-lib/RegExp/regexp-lib.mlb 3 | ../db/sqlite/sqlite.mlb 4 | wiki.squall.sml 5 | 6 | ../smelt/tinyxml/tinyxml.mlb 7 | ../web/web.mlb 8 | 9 | ../chiralml/chiralml.mlb 10 | ../web/server/http-server-fn.sml 11 | chiral.sml 12 | 13 | templates/page.html.sml 14 | templates/edit.html.sml 15 | wiki.sml 16 | main.sml 17 | -------------------------------------------------------------------------------- /wiki/wiki.sml: -------------------------------------------------------------------------------- 1 | structure Wiki = struct 2 | 3 | structure U = WebUtil 4 | structure RE = RegExpFn (structure P = AwkSyntax 5 | structure E = BackTrackEngine) 6 | 7 | fun formatPage page = let 8 | 9 | fun getMatch { pos, len } = Substring.string (Substring.slice (pos, 0, SOME len)) 10 | 11 | fun makeLink s = "" ^ s ^ "" 12 | 13 | val translateCR = String.translate (fn #"\n" => "
    " 14 | | c => String.str c) 15 | 16 | val match = RE.match [ ("\\[([A-Za-z]*)\\]", fn m => 17 | makeLink (getMatch (MatchTree.nth (m, 1)))), 18 | ("[^\\[]+", fn m => let 19 | val match = getMatch (MatchTree.root m) 20 | in 21 | translateCR (WebUtil.escapeStr match) 22 | end) 23 | ] 24 | Substring.getc 25 | 26 | fun loop s = case match s of NONE => nil 27 | | SOME (res, s') => res :: (loop s') 28 | in 29 | Web.HTML (String.concat (loop (Substring.full page))) 30 | end 31 | 32 | fun handler (req: Web.request) = (case U.postpath req of 33 | 34 | nil => 35 | raise U.redirectPostpath req [ "MainPage" ] 36 | 37 | | [ "" ] => 38 | raise U.redirectPostpath req [ "MainPage" ] 39 | 40 | | [ title ] => U.htmlResp ( 41 | case SQL.getPage title of 42 | SOME { id, text } => TPage.render { title = title, 43 | body = formatPage text } 44 | | NONE => raise U.redirectPostpath req [ title, "edit" ] 45 | ) 46 | 47 | | [ title, "edit" ] => U.htmlResp ( 48 | TEditPage.render ( 49 | case SQL.getPage title of 50 | SOME { id, text } => { title = title, text = text, new = false } 51 | | NONE => { title = title, text = "", new = true } ) 52 | ) 53 | 54 | | [ title, "save" ] => 55 | let 56 | val form = Form.load req 57 | val content = valOf (Form.get form "content") 58 | handle Option => raise U.redirectPostpath req [ title ] 59 | in 60 | case Form.get form "new" of 61 | SOME _ => SQL.createPage { title = title, text = content } 62 | | NONE => SQL.updatePage { title = title, text = content }; 63 | 64 | raise U.redirectPostpath req [ title ] 65 | end 66 | 67 | | _ => raise U.notFound 68 | ) 69 | (* 70 | val conn_info : MySQLClient.connect_info = { 71 | host = NONE, port = 0w0, unix_socket = NONE, 72 | user = SOME "root", password = NONE, db = SOME "foowiki" 73 | } 74 | 75 | val conn = MySQLClient.init () 76 | 77 | val () = (MySQLClient.real_connect conn conn_info; 78 | SQL.conn := SOME conn) 79 | *) 80 | val () = SQL.prepare (SQLite.opendb "wiki.db") 81 | 82 | val app = U.dumpRequestWrapper print (U.exnWrapper handler) 83 | 84 | fun main _ = let 85 | val () = print "Listening...\n" 86 | val serverthread = HTTPServer.spawn_server (INetSock.any 5124) app 87 | in 88 | T.run (); 89 | 0 90 | end 91 | 92 | end 93 | -------------------------------------------------------------------------------- /wiki/wiki.squall: -------------------------------------------------------------------------------- 1 | engine: sqlite 2 | 3 | --- getPage: string -> { id: int, text: string } option 4 | 5 | select id, text from page where title = ? 6 | 7 | --- updatePage: { text: string, title: string } -> unit 8 | 9 | update page set text = ? where title = ? 10 | 11 | --- createPage: { text: string, title: string } -> unit 12 | 13 | insert into page (text, title) values (?, ?) 14 | --------------------------------------------------------------------------------