1 structure Init
:> INIT
=
7 exception Access
of string
10 fun conn () = C
.conn dbstring
13 type user
= {id
: int, name
: string, rname
: string, bal
: int, joined
: C
.timestamp
,
14 app
: int, shares
: int}
16 val db
= ref (NONE
: C
.conn option
)
17 val user
= ref (NONE
: user option
)
25 fun rowError (tab
, vs
) = raise Fail ("Bad " ^ tab ^
"row: " ^ makeSet fromSql vs
)
27 fun getDb () = valOf (!db
)
29 fun mkUserRow
[id
, name
, rname
, bal
, joined
, app
, shares
] =
30 {id
= C
.intFromSql id
, name
= C
.stringFromSql name
, rname
= C
.stringFromSql rname
,
31 bal
= C
.intFromSql bal
, joined
= C
.timestampFromSql joined
,
32 app
= C
.intFromSql app
, shares
= C
.intFromSql shares
}
33 | mkUserRow row
= rowError ("user", row
)
43 case Web
.getCgi
"REMOTE_USER" of
44 NONE
=> raise Fail
"Not logged in"
48 if String.isSuffix kerberosSuffix name
then
49 String.substring (name
, 0, size name
- size kerberosSuffix
)
53 case C
.oneOrNoRows
c ($`SELECT id
, name
, rname
, bal
, joined
, app
, shares
55 WHERE name
=^
(C
.stringToSql name
)`
) of
56 NONE
=> raise Fail
"User not found"
62 case C
.oneOrNoRows
c ($`SELECT ipaddr
64 WHERE id
= ^
(C
.intToSql (#app r
))
65 AND ipaddr IS NOT NULL`
) of
67 if Web
.getParam
"agree" = "on" then
68 (case Web
.getCgi
"REMOTE_ADDR" of
69 NONE
=> raise Fail
"REMOTE_ADDR not set"
71 ignore (C
.dml
c ($`UPDATE MemberApp
72 SET ipaddr
= ^
(C
.stringToSql ra
),
73 applied
= CURRENT_TIMESTAMP
74 WHERE id
= ^
(C
.intToSql (#app r
))`
)))
90 fun getUser () = valOf (!user
)
91 fun getUserId () = #
id (getUser ())
92 fun getUserName () = #
name (getUser ())
95 mkUserRow (C
.oneRow (getDb ()) ($`SELECT id
, name
, rname
, bal
, joined
, app
, shares
97 WHERE id
= ^
(C
.intToSql id
)`
))
100 C
.map (getDb ()) mkUserRow ($`SELECT id
, name
, rname
, bal
, joined
, app
, shares
104 fun listActiveUsers () =
105 C
.map (getDb ()) mkUserRow ($`SELECT id
, name
, rname
, bal
, joined
, app
, shares
109 fun nextSeq (db
, seq
) =
110 case C
.oneRow
db ($`SELECT
nextval('^
(seq
)')`
) of
111 [id
] => C
.intFromSql id
112 | _
=> raise Fail
"Bad next sequence val"
114 fun addUser (name
, rname
, bal
, app
, shares
) =
117 val id
= nextSeq (db
, "WebUserSeq")
119 C
.dml
db ($`INSERT INTO
WebUser (id
, name
, rname
, bal
, joined
, app
, shares
)
120 VALUES (^
(C
.intToSql id
), ^
(C
.stringToSql name
), ^
(C
.stringToSql rname
), ^
(C
.intToSql bal
),
121 CURRENT_TIMESTAMP
, ^
(C
.intToSql app
), ^
(C
.intToSql shares
))`
);
125 fun modUser (user
: user
) =
129 ignore (C
.dml
db ($`UPDATE WebUser SET
130 name
= ^
(C
.stringToSql (#name user
)), rname
= ^
(C
.stringToSql (#rname user
)),
131 bal
= ^
(C
.intToSql (#bal user
)), app
= ^
(C
.intToSql (#app user
)),
132 shares
= ^
(C
.intToSql (#shares user
))
133 WHERE id
= ^
(C
.intToSql (#id user
))`
))
137 C
.map (getDb ()) mkUserRow ($`SELECT id
, name
, rname
, bal
, joined
, app
, shares
140 ORDER BY shares DESC
, name`
)
143 C
.dml (getDb ()) ($`DELETE FROM WebUser WHERE id
= ^
(C
.intToSql id
)`
)
145 fun validUsername name
=
147 andalso size name
> 0
148 andalso Char.isLower (String.sub (name
, 0))
149 andalso CharVector
.all
Char.isAlphaNum name
151 fun userNameToId name
=
152 case C
.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name
= ^
(C
.stringToSql name
)`
) of
153 SOME
[id
] => SOME (C
.intFromSql id
)
157 case C
.oneRow (getDb ()) "SELECT CURRENT_DATE" of
158 [d
] => C
.stringFromSql d
159 | r
=> rowError ("dateString", r
)
161 fun grandfatherUsers () =
165 fun mkApp
[id
, name
, rname
] =
167 val id
= C
.intFromSql id
168 val name
= C
.stringFromSql name
169 val rname
= C
.stringFromSql rname
171 val aid
= nextSeq (db
, "MemberAppSeq")
173 ignore (C
.dml
db ($`INSERT INTO
MemberApp (id
, name
, rname
, gname
, email
, forward
, uses
, other
,
174 passwd
, status
, applied
, confirmed
, decided
, msg
)
175 VALUES (^
(C
.intToSql aid
), ^
(C
.stringToSql name
), ^
(C
.stringToSql rname
),
176 NULL
, '^name^
(emailSuffix
)', FALSE
, 'GRANDFATHERED
', 'GRANDFATHERED
',
177 'GRANDFATHERED
', 4, CURRENT_TIMESTAMP
, CURRENT_TIMESTAMP
,
178 CURRENT_TIMESTAMP
, 'GRANDFATHERED
')`
));
179 ignore (C
.dml
db ($`UPDATE WebUser SET app
= ^
(C
.intToSql aid
) WHERE id
= ^
(C
.intToSql id
)`
))
182 C
.app db mkApp
"SELECT id, name, rname FROM WebUser WHERE app IS NULL"
185 type node
= {id
: int, name
: string, descr
: string, debian
: string}
187 fun mkNodeRow
[id
, name
, descr
, debian
] =
188 {id
= C
.intFromSql id
, name
= C
.stringFromSql name
, descr
= C
.stringFromSql descr
,
189 debian
= C
.stringFromSql debian
}
190 | mkNodeRow row
= rowError ("node", row
)
193 C
.map (getDb ()) mkNodeRow ($`SELECT id
, name
, descr
, debian
198 case C
.oneRow (getDb ()) ($`SELECT name
200 WHERE id
= ^
(C
.intToSql id
)`
) of
201 [name
] => C
.stringFromSql name
202 | row
=> rowError ("nodeName", row
)
205 case C
.oneRow (getDb ()) ($`SELECT debian
207 WHERE id
= ^
(C
.intToSql id
)`
) of
208 [debian
] => C
.stringFromSql debian
209 | row
=> rowError ("nodeDebian", row
)
213 OS
.SysErr (name
, sop
) =>
214 "System error: " ^ name ^
217 | SOME syserr
=> ": " ^ OS
.errorName syserr ^
": " ^ OS
.errorMsg syserr
)
222 val proc
= Unix
.execute ("/usr/bin/tokens", [])
223 val inf
= Unix
.textInstreamOf proc
226 case TextIO.inputLine inf
of
227 NONE
=> String.concat (rev acc
)
228 | SOME s
=> reader (s
:: acc
)
231 before (TextIO.closeIn inf
;
232 ignore (Unix
.reap proc
))
235 fun tokensForked () =
236 case Posix
.Process
.fork () of
237 NONE
=> (OS
.Process
.system
"/usr/bin/tokens >/tmp/tokens.child";
238 OS
.Process
.exit OS
.Process
.success
)
239 | _
=> ignore (OS
.Process
.system
"/usr/bin/tokens >/tmp/tokens.parent")
241 fun unmigratedUsers () =
242 List.filter (fn user
=>
243 (ignore (Posix
.SysDB
.getpwnam (#name user
));
245 handle OS
.SysErr _
=> true) (listActiveUsers ())