1 structure Roll
:> ROLL
= struct
5 fun activeUsernames () =
7 fun mkRow
[name
] = C
.stringFromSql name
8 | mkRow row
= rowError ("activeUsernames", row
)
10 C
.map (getDb ()) mkRow
"SELECT name FROM WebUserActive ORDER BY name"
20 fun mkRollRow
[id
, title
, msg
, started
] =
21 {id
= C
.intFromSql id
, title
= C
.stringFromSql title
,
22 msg
= C
.stringFromSql msg
, started
= C
.timestampFromSql started
}
23 | mkRollRow row
= rowError ("roll", row
)
25 fun addRollCall (title
, msg
) =
28 val id
= nextSeq (db
, "RollCallSeq")
30 fun addUser
[uid
, name
] =
32 val uid
= C
.intFromSql uid
33 val name
= C
.stringFromSql name
34 val code
= randomPassword ()
36 val _
= C
.dml
db ($`INSERT INTO
RollCallEntry (rol
, usr
, code
, responded
)
37 VALUES (^
(C
.intToSql id
), ^
(C
.intToSql uid
), ^
(C
.stringToSql code
), NULL
)`
)
39 val mail
= Mail
.mopen ()
41 Mail
.mwrite (mail
, "From: Hcoop Portal <hcoop");
42 Mail
.mwrite (mail
, emailSuffix
);
43 Mail
.mwrite (mail
, ">\nTo: ");
44 Mail
.mwrite (mail
, name
);
45 Mail
.mwrite (mail
, emailSuffix
);
46 Mail
.mwrite (mail
, "\nSubject: HCoop Roll Call: ");
47 Mail
.mwrite (mail
, title
);
48 Mail
.mwrite (mail
, "\n\n");
49 Mail
.mwrite (mail
, "The admins want to make sure that they can reach everyone by e-mail. To let them know that you're here, please visit this URL:\n\t");
50 Mail
.mwrite (mail
, urlPrefix
);
51 Mail
.mwrite (mail
, "roll?cmd=respond&rol=");
52 Mail
.mwrite (mail
, Int.toString id
);
53 Mail
.mwrite (mail
, "&code=");
54 Mail
.mwrite (mail
, code
);
55 Mail
.mwrite (mail
, "\nYou may have to hit \"reload\" in your web browser, if you aren't already logged into the portal.\n\n");
56 Mail
.mwrite (mail
, msg
);
57 ignore (Mail
.mclose mail
)
59 | addUser row
= rowError ("add roll entry", row
)
61 C
.dml
db ($`INSERT INTO
RollCall (id
, title
, msg
, started
)
62 VALUES (^
(C
.intToSql id
), ^
(C
.stringToSql title
), ^
(C
.stringToSql msg
),
64 C
.app db addUser
"SELECT id, name FROM WebUserActive";
68 fun modRollCall (rc
: roll_call
) =
72 ignore (C
.dml
db ($`UPDATE RollCall SET
73 title
= ^
(C
.stringToSql (#title rc
)),
74 msg
= ^
(C
.stringToSql (#msg rc
))
75 WHERE id
= ^
(C
.intToSql (#id rc
))`
))
78 fun deleteRollCall id
=
79 ignore (C
.dml (getDb ()) ($`DELETE FROM RollCall WHERE id
= ^
(C
.intToSql id
)`
))
81 fun lookupRollCall id
=
82 case C
.oneOrNoRows (getDb ()) ($`SELECT id
, title
, msg
, started
84 WHERE id
= ^
(C
.intToSql id
)`
) of
85 NONE
=> raise Fail
"Roll call not found"
86 | SOME row
=> mkRollRow row
88 fun listRollCalls id
=
89 C
.map (getDb ()) mkRollRow
"SELECT id, title, msg, started FROM RollCall ORDER BY started DESC"
91 type roll_call_entry
= {
95 responded
: C
.timestamp option
98 fun mkEntryRow
[rol
, usr
, code
, responded
] =
99 {rol
= C
.intFromSql rol
, usr
= C
.intFromSql usr
,
100 code
= C
.stringFromSql code
,
101 responded
= (if C
.isNull responded
then NONE
else SOME (C
.timestampFromSql responded
))}
102 | mkEntryRow row
= rowError ("roll entry", row
)
104 fun lookupEntry (rol
, usr
) =
105 case C
.oneOrNoRows (getDb ()) ($`SELECT rol
, usr
, code
, responded
107 WHERE rol
= ^
(C
.intToSql rol
) AND usr
= ^
(C
.intToSql usr
)`
) of
108 NONE
=> raise Fail
"Roll call entry not found"
109 | SOME row
=> mkEntryRow row
113 fun folder (_
:: row
, (didnt
, did
)) =
115 val ent
= mkEntryRow row
116 val uent
= (Init
.lookupUser (#usr ent
), ent
)
118 case #responded ent
of
119 NONE
=> (uent
:: didnt
, did
)
120 | SOME _
=> (didnt
, uent
:: did
)
122 |
folder (row
, _
) = rowError ("listEntries folder", row
)
124 C
.fold (getDb ()) folder ([], [])
125 ($`SELECT name
, rol
, usr
, code
, responded
126 FROM RollCallEntry JOIN WebUser ON id
= usr
127 WHERE rol
= ^
(C
.intToSql id
)
128 ORDER BY responded
, name DESC`
)
131 fun respond (rol
, usr
) =
132 ignore (C
.dml (getDb ()) ($`UPDATE RollCallEntry
133 SET responded
= CURRENT_TIMESTAMP
134 WHERE rol
= ^
(C
.intToSql rol
) AND usr
= ^
(C
.intToSql usr
)`
))