1 structure Init
:> INIT
=
7 fun nullableFromSql f x
=
12 fun nullableToSql f x
=
17 exception Access
of string
20 fun conn () = C
.conn dbstring
23 type user
= {id
: int, name
: string, rname
: string, bal
: int, joined
: C
.timestamp
,
24 app
: int, shares
: int, paypal
: string option
, checkout
: string option
}
26 val db
= ref (NONE
: C
.conn option
)
27 val user
= ref (NONE
: user option
)
35 fun rowError (tab
, vs
) = raise Fail ("Bad " ^ tab ^
"row: " ^ makeSet fromSql vs
)
37 fun getDb () = valOf (!db
)
39 fun mkUserRow
[id
, name
, rname
, bal
, joined
, app
, shares
, paypal
, checkout
] =
40 {id
= C
.intFromSql id
, name
= C
.stringFromSql name
, rname
= C
.stringFromSql rname
,
41 bal
= C
.intFromSql bal
, joined
= C
.timestampFromSql joined
,
42 app
= C
.intFromSql app
, shares
= C
.intFromSql shares
,
43 paypal
= nullableFromSql C
.stringFromSql paypal
,
44 checkout
= nullableFromSql C
.stringFromSql checkout
}
45 | mkUserRow row
= rowError ("user", row
)
55 case Web
.getCgi
"REMOTE_USER" of
56 NONE
=> raise Fail
"Not logged in"
60 if String.isSuffix kerberosSuffix name
then
61 String.substring (name
, 0, size name
- size kerberosSuffix
)
65 case C
.oneOrNoRows
c ($`SELECT id
, name
, rname
, bal
, joined
, app
, shares
, paypal
, checkout
67 WHERE name
=^
(C
.stringToSql name
)`
) of
68 NONE
=> raise Fail
"User not found"
74 case C
.oneOrNoRows
c ($`SELECT ipaddr
76 WHERE id
= ^
(C
.intToSql (#app r
))
77 AND ipaddr IS NOT NULL`
) of
79 if Web
.getParam
"agree" = "on" then
80 (case Web
.getCgi
"REMOTE_ADDR" of
81 NONE
=> raise Fail
"REMOTE_ADDR not set"
83 ignore (C
.dml
c ($`UPDATE MemberApp
84 SET ipaddr
= ^
(C
.stringToSql ra
),
85 applied
= CURRENT_TIMESTAMP
86 WHERE id
= ^
(C
.intToSql (#app r
))`
)))
102 fun getUser () = valOf (!user
)
103 fun getUserId () = #
id (getUser ())
104 fun getUserName () = #
name (getUser ())
107 mkUserRow (C
.oneRow (getDb ()) ($`SELECT id
, name
, rname
, bal
, joined
, app
, shares
, paypal
, checkout
109 WHERE id
= ^
(C
.intToSql id
)`
))
112 C
.map (getDb ()) mkUserRow ($`SELECT id
, name
, rname
, bal
, joined
, app
, shares
, paypal
, checkout
116 fun listActiveUsers () =
117 C
.map (getDb ()) mkUserRow ($`SELECT id
, name
, rname
, bal
, joined
, app
, shares
, paypal
, checkout
121 fun nextSeq (db
, seq
) =
122 case C
.oneRow
db ($`SELECT
nextval('^
(seq
)')`
) of
123 [id
] => C
.intFromSql id
124 | _
=> raise Fail
"Bad next sequence val"
126 fun addUser (name
, rname
, bal
, app
, shares
) =
129 val id
= nextSeq (db
, "WebUserSeq")
131 C
.dml
db ($`INSERT INTO
WebUser (id
, name
, rname
, bal
, joined
, app
, shares
, paypal
, checkout
)
132 VALUES (^
(C
.intToSql id
), ^
(C
.stringToSql name
), ^
(C
.stringToSql rname
), ^
(C
.intToSql bal
),
133 CURRENT_TIMESTAMP
, ^
(C
.intToSql app
), ^
(C
.intToSql shares
),
134 (SELECT paypal FROM MemberApp WHERE id
= ^
(C
.intToSql app
)),
135 (SELECT checkout FROM MemberApp WHERE id
= ^
(C
.intToSql app
)))`
);
139 fun modUser (user
: user
) =
143 ignore (C
.dml
db ($`UPDATE WebUser SET
144 name
= ^
(C
.stringToSql (#name user
)), rname
= ^
(C
.stringToSql (#rname user
)),
145 bal
= ^
(C
.intToSql (#bal user
)), app
= ^
(C
.intToSql (#app user
)),
146 shares
= ^
(C
.intToSql (#shares user
)),
147 paypal
= ^
(nullableToSql (C
.stringToSql
o Util
.normEmail
) (#paypal user
)),
148 checkout
= ^
(nullableToSql (C
.stringToSql
o Util
.normEmail
) (#checkout user
))
149 WHERE id
= ^
(C
.intToSql (#id user
))`
))
153 C
.map (getDb ()) mkUserRow ($`SELECT id
, name
, rname
, bal
, joined
, app
, shares
, paypal
, checkout
156 ORDER BY shares DESC
, name`
)
159 C
.dml (getDb ()) ($`DELETE FROM WebUser WHERE id
= ^
(C
.intToSql id
)`
)
161 fun validUsername name
=
163 andalso size name
> 0
164 andalso Char.isLower (String.sub (name
, 0))
165 andalso CharVector
.all
Char.isAlphaNum name
167 fun userNameToId name
=
168 case C
.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name
= ^
(C
.stringToSql name
)`
) of
169 SOME
[id
] => SOME (C
.intFromSql id
)
173 case C
.oneRow (getDb ()) "SELECT CURRENT_DATE" of
174 [d
] => C
.stringFromSql d
175 | r
=> rowError ("dateString", r
)
177 fun grandfatherUsers () =
181 fun mkApp
[id
, name
, rname
] =
183 val id
= C
.intFromSql id
184 val name
= C
.stringFromSql name
185 val rname
= C
.stringFromSql rname
187 val aid
= nextSeq (db
, "MemberAppSeq")
189 ignore (C
.dml
db ($`INSERT INTO
MemberApp (id
, name
, rname
, gname
, email
, forward
, uses
, other
,
190 passwd
, status
, applied
, confirmed
, decided
, msg
)
191 VALUES (^
(C
.intToSql aid
), ^
(C
.stringToSql name
), ^
(C
.stringToSql rname
),
192 NULL
, '^name^
(emailSuffix
)', FALSE
, 'GRANDFATHERED
', 'GRANDFATHERED
',
193 'GRANDFATHERED
', 4, CURRENT_TIMESTAMP
, CURRENT_TIMESTAMP
,
194 CURRENT_TIMESTAMP
, 'GRANDFATHERED
')`
));
195 ignore (C
.dml
db ($`UPDATE WebUser SET app
= ^
(C
.intToSql aid
) WHERE id
= ^
(C
.intToSql id
)`
))
198 C
.app db mkApp
"SELECT id, name, rname FROM WebUser WHERE app IS NULL"
201 type node
= {id
: int, name
: string, descr
: string, debian
: string}
203 fun mkNodeRow
[id
, name
, descr
, debian
] =
204 {id
= C
.intFromSql id
, name
= C
.stringFromSql name
, descr
= C
.stringFromSql descr
,
205 debian
= C
.stringFromSql debian
}
206 | mkNodeRow row
= rowError ("node", row
)
209 C
.map (getDb ()) mkNodeRow ($`SELECT id
, name
, descr
, debian
214 case C
.oneRow (getDb ()) ($`SELECT name
216 WHERE id
= ^
(C
.intToSql id
)`
) of
217 [name
] => C
.stringFromSql name
218 | row
=> rowError ("nodeName", row
)
221 case C
.oneRow (getDb ()) ($`SELECT debian
223 WHERE id
= ^
(C
.intToSql id
)`
) of
224 [debian
] => C
.stringFromSql debian
225 | row
=> rowError ("nodeDebian", row
)
229 OS
.SysErr (name
, sop
) =>
230 "System error: " ^ name ^
233 | SOME syserr
=> ": " ^ OS
.errorName syserr ^
": " ^ OS
.errorMsg syserr
)
238 val proc
= Unix
.execute ("/usr/bin/tokens", [])
239 val inf
= Unix
.textInstreamOf proc
242 case TextIO.inputLine inf
of
243 NONE
=> String.concat (rev acc
)
244 | SOME s
=> reader (s
:: acc
)
247 before (TextIO.closeIn inf
;
248 ignore (Unix
.reap proc
))
251 fun tokensForked () =
252 case Posix
.Process
.fork () of
253 NONE
=> (OS
.Process
.system
"/usr/bin/tokens >/tmp/tokens.child";
254 OS
.Process
.exit OS
.Process
.success
)
255 | _
=> ignore (OS
.Process
.system
"/usr/bin/tokens >/tmp/tokens.parent")
257 fun unmigratedUsers () =
258 List.filter (fn user
=>
259 (ignore (Posix
.SysDB
.getpwnam (#name user
));
261 handle OS
.SysErr _
=> true) (listActiveUsers ())
263 fun usersDiff (ls1
, ls2
) =
264 {onlyInFirst
= List.filter (fn x
=> not (Util
.mem (x
, ls2
))) ls1
,
265 onlyInSecond
= List.filter (fn x
=> not (Util
.mem (x
, ls1
))) ls2
}
267 fun listUsernames () = C
.map (getDb ())
268 (fn [name
] => C
.stringFromSql name
269 | row
=> rowError ("listUsernames", row
))
270 "SELECT name FROM WebUserActive ORDER BY name"
273 fun explore (dir
, level
, acc
) =
278 val dr
= Posix
.FileSys
.opendir dir
281 case Posix
.FileSys
.readdir dr
of
285 val dir
' = OS
.Path
.joinDirFile
{dir
= dir
,
288 val acc
= explore (dir
', level
+1, acc
)
294 before Posix
.FileSys
.closedir dr
297 val acc
= explore ("/afs/hcoop.net/user", 0, [])
299 List.map OS
.Path
.file acc
302 fun searchPaypal paypal
=
303 C
.map (getDb ()) mkUserRow ($`SELECT id
, name
, rname
, bal
, joined
, app
, shares
, paypal
, checkout
305 WHERE paypal
= ^
(C
.stringToSql (normEmail paypal
))
308 fun searchCheckout checkout
=
309 C
.map (getDb ()) mkUserRow ($`SELECT id
, name
, rname
, bal
, joined
, app
, shares
, paypal
, checkout
311 WHERE checkout
= ^
(C
.stringToSql (normEmail checkout
))