adamc@993: functor Make(M : sig adamc@993: con key :: {Type} adamc@993: con data :: {Type} adamc@993: constraint key ~ data adamc@995: constraint [When, Version] ~ (key ++ data) adamc@993: adamc@993: val key : $(map sql_injectable key) adamc@993: val data : $(map (fn t => {Inj : sql_injectable_prim t, adamc@993: Eq : eq t}) data) adamc@993: adamc@993: val keyFolder : folder key adamc@993: val dataFolder : folder data adamc@993: end) = struct adamc@995: type version = int adamc@995: con all = [When = time, Version = version] ++ M.key ++ map option M.data adamc@995: sequence s adamc@993: table t : all adamc@993: adamc@993: val keys = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t) (fn r => r.T) adamc@995: fun keysAt vr = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t adamc@995: WHERE t.Version <= {[vr]}) (fn r => r.T) adamc@993: adamc@993: con dmeta = fn t => {Inj : sql_injectable_prim t, adamc@993: Eq : eq t} adamc@993: adamc@993: fun keyRecd (r : $(M.key ++ M.data)) = adamc@1093: @map2 [sql_injectable] [id] [sql_exp [] [] []] adamc@1093: (fn [t] => @sql_inject) adamc@1093: M.keyFolder M.key (r --- M.data) adamc@993: adamc@995: fun insert r = adamc@995: vr <- nextval s; adamc@995: dml (Basis.insert t adamc@995: ({Version = (SQL {[vr]}), When = (SQL CURRENT_TIMESTAMP)} adamc@995: ++ keyRecd r adamc@1093: ++ @map2 [dmeta] [id] adamc@995: [fn t => sql_exp [] [] [] (option t)] adamc@995: (fn [t] x v => @sql_inject (@sql_option_prim x.Inj) adamc@995: (Some v)) adamc@1093: M.dataFolder M.data (r --- M.key))) adamc@993: adamc@993: fun keyExp (r : $M.key) : sql_exp [T = all] [] [] bool = adamc@1093: @foldR2 [sql_injectable] [id] [fn before => after :: {Type} -> [before ~ after] adamc@1093: => sql_exp [T = before ++ after] [] [] bool] adamc@1093: (fn [nm :: Name] [t :: Type] [before :: {Type}] [[nm] ~ before] adamc@1093: (inj : sql_injectable t) (v : t) adamc@1093: (e : after :: {Type} -> [before ~ after] adamc@1093: => sql_exp [T = before ++ after] [] [] bool) adamc@1093: [after :: {Type}] [[nm = t] ++ before ~ after] => adamc@1093: (SQL t.{nm} = {[v]} AND {e [[nm = t] ++ after] !})) adamc@1093: (fn [after :: {Type}] [[] ~ after] => (SQL TRUE)) adamc@1093: M.keyFolder M.key r adamc@1093: [_] ! adamc@993: adamc@995: datatype bound = adamc@995: NoBound adamc@995: | Lt of int adamc@995: | Le of int adamc@995: adamc@995: fun seek vro k = adamc@993: let adamc@995: fun current' vro r = adamc@993: let adamc@1093: val complete = @foldR [option] [fn ts => option $ts] adamc@1093: (fn [nm :: Name] [v :: Type] [r :: {Type}] [[nm] ~ r] adamc@1093: v r => adamc@1093: case (v, r) of adamc@1093: (Some v, Some r) => Some ({nm = v} ++ r) adamc@1093: | _ => None) adamc@1093: (Some {}) M.dataFolder r adamc@993: in adamc@993: case complete of adamc@993: Some r => return (Some r) adamc@993: | None => adamc@993: let adamc@995: val filter = case vro of adamc@995: NoBound => (WHERE TRUE) adamc@995: | Lt vr => (WHERE t.Version < {[vr]}) adamc@995: | Le vr => (WHERE t.Version <= {[vr]}) adamc@993: in adamc@995: ro <- oneOrNoRows (SELECT t.Version, t.{{map option M.data}} adamc@993: FROM t adamc@993: WHERE {filter} adamc@993: AND {keyExp k} adamc@993: ORDER BY t.When DESC adamc@993: LIMIT 1); adamc@993: case ro of adamc@993: None => return None adamc@993: | Some r' => adamc@993: let adamc@1093: val r = @map2 [option] [option] [option] adamc@1093: (fn [t ::: Type] old new => adamc@1093: case old of adamc@1093: None => new adamc@1093: | Some _ => old) adamc@1093: M.dataFolder r (r'.T -- #Version) adamc@993: in adamc@995: current' (Lt r'.T.Version) r adamc@993: end adamc@993: end adamc@993: end adamc@993: in adamc@1093: current' vro (@map0 [option] (fn [t :: Type] => None : option t) M.dataFolder) adamc@993: end adamc@993: adamc@995: val current = seek NoBound adamc@995: fun archive vr = seek (Le vr) adamc@995: adamc@993: fun update r = adamc@993: cur <- current (r --- M.data); adamc@993: case cur of adamc@993: None => error Tried to update nonexistent key adamc@993: | Some cur => adamc@995: vr <- nextval s; adamc@993: let adamc@1093: val r' = @map3 [dmeta] [id] [id] [fn t => sql_exp [] [] [] (option t)] adamc@1093: (fn [t] (meta : dmeta t) old new => adamc@1093: @sql_inject (@sql_option_prim meta.Inj) adamc@1093: (if @@eq [_] meta.Eq old new then adamc@1093: None adamc@1093: else adamc@1093: Some new)) adamc@1093: M.dataFolder M.data cur (r --- M.key) adamc@995: val r' = {Version = (SQL {[vr]}), When = (SQL CURRENT_TIMESTAMP)} adamc@993: ++ keyRecd r adamc@993: ++ r' adamc@993: in adamc@993: dml (Basis.insert t r') adamc@993: end adamc@995: adamc@995: val updateTimes = List.mapQuery (SELECT t.Version, t.When adamc@995: FROM t adamc@995: ORDER BY t.When) (fn r => (r.T.Version, r.T.When)) adamc@993: end