Mercurial > urweb

annotate demo/batchFun.ur @ 1739:c414850f206f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add support for -boot flag, which allows in-tree execution of Ur/Web The boot flag rewrites most hardcoded paths to point to the build directory, and also forces static compilation. This is convenient for developing Ur/Web, or if you cannot 'sudo make install' Ur/Web. The following changes were made: * Header files were moved to include/urweb instead of include; this lets FFI users point their C_INCLUDE_PATH at this directory at write <urweb/urweb.h>. For internal Ur/Web executables, we simply pass -I$PATH/include/urweb as normal. * Differentiate between LIB and SRCLIB; SRCLIB is Ur and JavaScript source files, while LIB is compiled products from libtool. For in-tree compilation these live in different places. * No longer reference Config for paths; instead use Settings; these settings can be changed dynamically by Compiler.enableBoot () (TODO: add a disableBoot function.) * config.h is now generated directly in include/urweb/config.h, for consistency's sake (especially since it gets installed along with the rest of the headers!) * All of the autotools build products got updated. * The linkStatic field in protocols now only contains the name of the build product, and not the absolute path. Future users have to be careful not to reference the Settings files to early, lest they get an old version (this was the source of two bugs during development of this patch.)
author Edward Z. Yang <ezyang@mit.edu>
date Wed, 02 May 2012 17:17:57 -0400
parents 68429cfce8db
children 6bc2a8cb3a67
rev   line source
adamc@1002 1 con colMeta = fn (db :: Type, state :: Type) =>
adamc@650 2 {Nam : string,
adamc@1002 3 Show : db -> xbody,
adamc@1002 4 Inject : sql_injectable db,
adamc@650 5
adamc@1002 6 NewState : transaction state,
adamc@1002 7 Widget : state -> xbody,
adamc@1002 8 ReadState : state -> transaction db}
adam@1302 9 con colsMeta = fn cols => $(map colMeta cols)
adamc@650 10
adamc@823 11 fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t)
adamc@650 12 name : colMeta (t, source string) =
adamc@650 13 {Nam = name,
adamc@650 14 Show = txt,
adamc@650 15 Inject = _,
adamc@650 16
adamc@650 17 NewState = source "",
adamc@650 18 Widget = fn s => <xml><ctextbox source={s}/></xml>,
adamc@650 19 ReadState = fn s => v <- get s; return (readError v)}
adamc@650 20
adamc@650 21 val int = default
adamc@650 22 val float = default
adamc@650 23 val string = default
adamc@650 24
adamc@650 25 functor Make(M : sig
adamc@650 26 con cols :: {(Type * Type)}
adamc@650 27 constraint [Id] ~ cols
adamc@650 28 val fl : folder cols
adamc@650 29
adamc@706 30 table tab : ([Id = int] ++ map fst cols)
adamc@650 31
adamc@650 32 val title : string
adamc@650 33
adamc@650 34 val cols : colsMeta cols
adamc@650 35 end) = struct
adamc@650 36
adamc@650 37 val t = M.tab
adamc@650 38
adamc@650 39 datatype list t = Nil | Cons of t * list t
adamc@650 40
adamc@650 41 fun allRows () =
adamc@650 42 query (SELECT * FROM t)
adamc@650 43 (fn r acc => return (Cons (r.T, acc)))
adamc@650 44 Nil
adamc@650 45
adamc@650 46 fun add r =
adamc@650 47 dml (insert t
adamc@1093 48 (@foldR2 [fst] [colMeta]
adam@1302 49 [fn cols => $(map (fn t => sql_exp [] [] [] t.1) cols)]
adam@1302 50 (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] input col acc =>
adamc@1093 51 acc ++ {nm = @sql_inject col.Inject input})
adamc@1093 52 {} M.fl (r -- #Id) M.cols
adamc@1093 53 ++ {Id = (SQL {[r.Id]})}))
adamc@650 54
adamc@650 55 fun doBatch ls =
adamc@650 56 case ls of
adamc@650 57 Nil => return ()
adamc@650 58 | Cons (r, ls') =>
adamc@650 59 add r;
adamc@650 60 doBatch ls'
adamc@650 61
adamc@650 62 fun del id =
adamc@650 63 dml (DELETE FROM t WHERE t.Id = {[id]})
adamc@650 64
adamc@650 65 fun show withDel lss =
adamc@650 66 let
adamc@650 67 fun show' ls =
adamc@650 68 case ls of
adamc@650 69 Nil => <xml/>
adamc@650 70 | Cons (r, ls) => <xml>
adamc@650 71 <tr>
adamc@650 72 <td>{[r.Id]}</td>
adamc@1172 73 {@mapX2 [colMeta] [fst] [_]
adam@1302 74 (fn [nm :: Name] [p ::_] [rest ::_] [[nm] ~ rest] m v =>
adamc@1093 75 <xml><td>{m.Show v}</td></xml>)
adamc@1093 76 M.fl M.cols (r -- #Id)}
adamc@650 77 {if withDel then
adamc@908 78 <xml><td><button value="Delete" onclick={rpc (del r.Id)}/></td></xml>
adamc@650 79 else
adamc@650 80 <xml/>}
adamc@650 81 </tr>
adamc@650 82 {show' ls}
adamc@650 83 </xml>
adamc@650 84 in
adamc@650 85 <xml><dyn signal={ls <- signal lss; return <xml><table>
adamc@650 86 <tr>
adamc@650 87 <th>Id</th>
adam@1641 88 {@mapX [colMeta] [tr]
adam@1302 89 (fn [nm :: Name] [p ::_] [rest ::_] [[nm] ~ rest] m =>
adamc@1093 90 <xml><th>{[m.Nam]}</th></xml>)
adamc@1093 91 M.fl M.cols}
adamc@650 92 </tr>
adamc@650 93 {show' ls}
adamc@650 94 </table></xml>}/></xml>
adamc@650 95 end
adamc@650 96
adamc@650 97 fun main () =
adamc@650 98 lss <- source Nil;
adamc@650 99 batched <- source Nil;
adamc@650 100
adamc@650 101 id <- source "";
adamc@1093 102 inps <- @foldR [colMeta] [fn r => transaction ($(map snd r))]
adam@1302 103 (fn [nm :: Name] [p ::_] [rest ::_] [[nm] ~ rest] m acc =>
adamc@1093 104 s <- m.NewState;
adamc@1093 105 r <- acc;
adamc@1093 106 return ({nm = s} ++ r))
adamc@1093 107 (return {})
adamc@1093 108 M.fl M.cols;
adamc@1093 109
adamc@650 110 let
adamc@650 111 fun add () =
adamc@650 112 id <- get id;
adamc@1093 113 vs <- @foldR2 [colMeta] [snd] [fn r => transaction ($(map fst r))]
adam@1302 114 (fn [nm :: Name] [p ::_] [rest ::_] [[nm] ~ rest] m s acc =>
adamc@1093 115 v <- m.ReadState s;
adamc@1093 116 r <- acc;
adamc@1093 117 return ({nm = v} ++ r))
adamc@1093 118 (return {})
adamc@1093 119 M.fl M.cols inps;
adamc@650 120 ls <- get batched;
adamc@650 121
adamc@650 122 set batched (Cons ({Id = readError id} ++ vs, ls))
adamc@650 123
adamc@650 124 fun exec () =
adamc@650 125 ls <- get batched;
adamc@650 126
adamc@908 127 rpc (doBatch ls);
adamc@650 128 set batched Nil
adamc@650 129 in
adamc@650 130 return <xml><body>
adamc@650 131 <h2>Rows</h2>
adamc@650 132
adamc@650 133 {show True lss}
adamc@650 134
adamc@908 135 <button value="Update" onclick={ls <- rpc (allRows ()); set lss ls}/><br/>
adamc@650 136 <br/>
adamc@650 137
adamc@650 138 <h2>Batch new rows to add</h2>
adamc@650 139
adamc@650 140 <table>
adamc@650 141 <tr> <th>Id:</th> <td><ctextbox source={id}/></td> </tr>
adamc@1172 142 {@mapX2 [colMeta] [snd] [_]
adam@1302 143 (fn [nm :: Name] [p ::_] [rest ::_] [[nm] ~ rest] m s =>
adamc@1093 144 <xml><tr> <th>{[m.Nam]}:</th> <td>{m.Widget s}</td> </tr></xml>)
adamc@1093 145 M.fl M.cols inps}
adamc@650 146 <tr> <th/> <td><button value="Batch it" onclick={add ()}/></td> </tr>
adamc@650 147 </table>
adamc@650 148
adamc@650 149 <h2>Already batched:</h2>
adamc@650 150 {show False batched}
adamc@650 151 <button value="Execute" onclick={exec ()}/>
adamc@650 152 </body></xml>
adamc@650 153 end
adamc@650 154
adamc@650 155 end