summaryrefslogtreecommitdiff
path: root/demo/more/versioned.ur
blob: bc9911e312b21b577e5072d71f09f9ef5b520ef6 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
functor Make(M : sig
                 con key :: {Type}
                 con data :: {Type}
                 constraint key ~ data
                 constraint [When, Version] ~ (key ++ data)

                 val key : $(map sql_injectable key)
                 val data : $(map (fn t => {Inj : sql_injectable_prim t,
                                            Eq : eq t}) data)

                 val keyFolder : folder key
                 val dataFolder : folder data
             end) = struct
    type version = int
    con all = [When = time, Version = version] ++ M.key ++ map option M.data
    sequence s
    table t : all

    val keys = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t) (fn r => r.T)
    fun keysAt vr = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t
                                   WHERE t.Version <= {[vr]}) (fn r => r.T)

    con dmeta = fn t => {Inj : sql_injectable_prim t,
                         Eq : eq t}

    fun keyRecd (r : $(M.key ++ M.data)) =
        map2 [sql_injectable] [id] [sql_exp [] [] []]
             (fn [t] => @sql_inject)
             [_] M.keyFolder M.key (r --- M.data)

    fun insert r =
        vr <- nextval s;
        dml (Basis.insert t
                          ({Version = (SQL {[vr]}), When = (SQL CURRENT_TIMESTAMP)}
                               ++ keyRecd r
                               ++ map2 [dmeta] [id]
                               [fn t => sql_exp [] [] [] (option t)]
                               (fn [t] x v => @sql_inject (@sql_option_prim x.Inj)
                                               (Some v))
                               [_] M.dataFolder M.data (r --- M.key)))

    fun keyExp (r : $M.key) : sql_exp [T = all] [] [] bool =
        foldR2 [sql_injectable] [id] [fn before => after :: {Type} -> [before ~ after]
                                         => sql_exp [T = before ++ after] [] [] bool]
               (fn [nm :: Name] [t :: Type] [before :: {Type}] [[nm] ~ before]
                                (inj : sql_injectable t) (v : t)
                   (e : after :: {Type} -> [before ~ after]
                    => sql_exp [T = before ++ after] [] [] bool)
                   [after :: {Type}] [[nm = t] ++ before ~ after] =>
                   (SQL t.{nm} = {[v]} AND {e [[nm = t] ++ after] !}))
               (fn [after :: {Type}] [[] ~ after] => (SQL TRUE))
               [_] M.keyFolder M.key r
               [_] !

    datatype bound =
             NoBound
           | Lt of int
           | Le of int

    fun seek vro k =
        let
            fun current' vro r =
                let
                    val complete = foldR [option] [fn ts => option $ts]
                                   (fn [nm :: Name] [v :: Type] [r :: {Type}] [[nm] ~ r]
                                                    v r =>
                                       case (v, r) of
                                           (Some v, Some r) => Some ({nm = v} ++ r)
                                         | _ => None)
                                   (Some {}) [_] M.dataFolder r
                in
                    case complete of
                        Some r => return (Some r)
                      | None =>
                        let
                            val filter = case vro of
                                             NoBound => (WHERE TRUE)
                                           | Lt vr => (WHERE t.Version < {[vr]})
                                           | Le vr => (WHERE t.Version <= {[vr]})
                        in
                            ro <- oneOrNoRows (SELECT t.Version, t.{{map option M.data}}
                                               FROM t
                                               WHERE {filter}
                                                 AND {keyExp k}
                                               ORDER BY t.When DESC
                                               LIMIT 1);
                            case ro of
                                None => return None
                              | Some r' =>
                                let
                                    val r = map2 [option] [option] [option]
                                            (fn [t ::: Type] old new =>
                                                case old of
                                                    None => new
                                                  | Some _ => old)
                                            [_] M.dataFolder r (r'.T -- #Version)
                                in
                                    current' (Lt r'.T.Version) r
                                end
                        end
                end
        in
            current' vro (map0 [option] (fn [t :: Type] => None : option t) [_] M.dataFolder)
        end

    val current = seek NoBound
    fun archive vr = seek (Le vr)

    fun update r =
        cur <- current (r --- M.data);
        case cur of
            None => error <xml>Tried to update nonexistent key</xml>
          | Some cur =>
            vr <- nextval s;
            let
                val r' = map3 [dmeta] [id] [id] [fn t => sql_exp [] [] [] (option t)]
                              (fn [t] (meta : dmeta t) old new =>
                                  @sql_inject (@sql_option_prim meta.Inj)
                                   (if @@eq [_] meta.Eq old new then
                                        None
                                    else
                                        Some new))
                              [_] M.dataFolder M.data cur (r --- M.key)
                val r' = {Version = (SQL {[vr]}), When = (SQL CURRENT_TIMESTAMP)}
                             ++ keyRecd r
                             ++ r'
            in
                dml (Basis.insert t r')
            end

    val updateTimes = List.mapQuery (SELECT t.Version, t.When
                                     FROM t
                                     ORDER BY t.When) (fn r => (r.T.Version, r.T.When))
end