Don't show stats on uninhabited locations
[hcoop/zz_old/portal.git] / init.sml
CommitLineData
8d347a33 1structure Init :> INIT =
2struct
3
4open Util Sql
5structure C = PgClient
6
7exception Access of string
5146e435 8exception NeedTos
8d347a33 9
31b85852 10val scratchDir = "/home/hcoop"
646dca75 11val urlPrefix = "https://members.hcoop.net/portal/"
fd650826 12val emailSuffix = "@hcoop.net"
646dca75 13val boardEmail = "board" ^ emailSuffix
2eae496b 14
646dca75 15fun conn () = C.conn "dbname='hcoop_hcoop'"
8d347a33 16val close = C.close
17
5146e435 18type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp,
19 app : int}
8d347a33 20
21val db = ref (NONE : C.conn option)
22val user = ref (NONE : user option)
23
369e1577 24fun fromSql v =
25 if C.isNull v then
26 "NULL"
27 else
28 C.stringFromSql v
29
30fun rowError (tab, vs) = raise Fail ("Bad " ^ tab ^ "row: " ^ makeSet fromSql vs)
31
8d347a33 32fun getDb () = valOf (!db)
33
5146e435 34fun mkUserRow [id, name, rname, bal, joined, app] =
8d347a33 35 {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname,
5146e435 36 bal = C.intFromSql bal, joined = C.timestampFromSql joined,
37 app = C.intFromSql app}
369e1577 38 | mkUserRow row = rowError ("user", row)
8d347a33 39
40fun init () =
41 let
78304862 42 val _ = Util.init ()
43
8d347a33 44 val c = conn ()
45 in
5146e435 46 db := SOME c;
8d347a33 47 C.dml c "BEGIN";
48 case Web.getCgi "REMOTE_USER" of
49 NONE => raise Fail "Not logged in"
50 | SOME name =>
5146e435 51 (case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app
47bc9315 52 FROM WebUserActive
8d347a33 53 WHERE name=^(C.stringToSql name)`) of
54 NONE => raise Fail "User not found"
5146e435 55 | SOME r =>
56 let
57 val r = mkUserRow r
58 in
59 user := SOME r;
60 case C.oneOrNoRows c ($`SELECT ipaddr
61 FROM MemberApp
62 WHERE id = ^(C.intToSql (#app r))
63 AND ipaddr IS NOT NULL`) of
64 NONE =>
65 if Web.getParam "agree" = "on" then
66 (case Web.getCgi "REMOTE_ADDR" of
67 NONE => raise Fail "REMOTE_ADDR not set"
68 | SOME ra =>
69 ignore (C.dml c ($`UPDATE MemberApp
70 SET ipaddr = ^(C.stringToSql ra),
71 applied = CURRENT_TIMESTAMP
72 WHERE id = ^(C.intToSql (#app r))`)))
73 else
74 raise NeedTos
75 | _ => ()
76 end)
8d347a33 77 end
78
79fun done () =
80 let
81 val db = getDb ()
82 in
83 C.dml db "COMMIT";
84 close db
85 end
86
87fun getUser () = valOf (!user)
88fun getUserId () = #id (getUser ())
89fun getUserName () = #name (getUser ())
90
91fun lookupUser id =
5146e435 92 mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app
8d347a33 93 FROM WebUser
94 WHERE id = ^(C.intToSql id)`))
95
96fun listUsers () =
5146e435 97 C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app
8d347a33 98 FROM WebUser
99 ORDER BY name`)
100
101fun nextSeq (db, seq) =
102 case C.oneRow db ($`SELECT nextval('^(seq)')`) of
369e1577 103 [id] => C.intFromSql id
8d347a33 104 | _ => raise Fail "Bad next sequence val"
105
5146e435 106fun addUser (name, rname, bal, app) =
8d347a33 107 let
108 val db = getDb ()
109 val id = nextSeq (db, "WebUserSeq")
110 in
5146e435 111 C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app)
112 VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), CURRENT_TIMESTAMP, ^(C.intToSql app))`);
369e1577 113 id
8d347a33 114 end
115
116fun modUser (user : user) =
117 let
118 val db = getDb ()
119 in
120 ignore (C.dml db ($`UPDATE WebUser SET
121 name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)),
5146e435 122 bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user))
8d347a33 123 WHERE id = ^(C.intToSql (#id user))`))
124 end
125
126fun deleteUser id =
127 C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`)
128
129fun validUsername name =
130 size name <= 10
131 andalso CharVector.all Char.isAlpha name
132
133fun userNameToId name =
134 case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of
135 SOME [id] => SOME (C.intFromSql id)
136 | _ => NONE
137
4b8df0b1 138fun dateString () =
139 case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of
140 [d] => C.stringFromSql d
141 | r => rowError ("dateString", r)
142
5146e435 143fun grandfatherUsers () =
144 let
145 val db = getDb ()
146
147 fun mkApp [id, name, rname] =
148 let
149 val id = C.intFromSql id
150 val name = C.stringFromSql name
151 val rname = C.stringFromSql rname
152
153 val aid = nextSeq (db, "MemberAppSeq")
154 in
155 ignore (C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other,
156 passwd, status, applied, confirmed, decided, msg)
157 VALUES (^(C.intToSql aid), ^(C.stringToSql name), ^(C.stringToSql rname),
646dca75 158 NULL, '^name^(emailSuffix)', FALSE, 'GRANDFATHERED', 'GRANDFATHERED',
5146e435 159 'GRANDFATHERED', 4, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP,
160 CURRENT_TIMESTAMP, 'GRANDFATHERED')`));
161 ignore (C.dml db ($`UPDATE WebUser SET app = ^(C.intToSql aid) WHERE id = ^(C.intToSql id)`))
162 end
163 in
164 C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL"
165 end
646dca75 166end