1 functor Request (T
: REQUEST_IN
) :> REQUEST_OUT
=
7 val seq
= table ^
"Seq"
14 type request
= { id
: int, usr
: int, data
: string, msg
: string, status
: status
,
15 stamp
: C
.timestamp
, cstamp
: C
.timestamp option
}
21 | _
=> raise C
.Sql
"Bad APT request status"
28 fun statusFromSql v
= statusFromInt (C
.intFromSql v
)
29 fun statusToSql s
= C
.intToSql (statusToInt s
)
31 fun mkRow
[id
, usr
, data
, msg
, status
, stamp
, cstamp
] =
32 {id
= C
.intFromSql id
, usr
= C
.intFromSql usr
, data
= C
.stringFromSql data
,
33 msg
= C
.stringFromSql msg
, status
= statusFromSql status
, stamp
= C
.timestampFromSql stamp
,
34 cstamp
= if C
.isNull cstamp
then NONE
else SOME (C
.timestampFromSql cstamp
)}
35 | mkRow r
= rowError ("APT request", r
)
37 fun add (usr
, data
, msg
) =
40 val id
= nextSeq (db
, seq
)
42 C
.dml
db ($`INSERT INTO ^
table (id
, usr
, data
, msg
, status
, stamp
, cstamp
)
43 VALUES (^
(C
.intToSql id
), ^
(C
.intToSql usr
), ^
(C
.stringToSql data
), ^
(C
.stringToSql msg
),
44 0, CURRENT_TIMESTAMP
, NULL
)`
);
48 fun modify (req
: request
) =
52 if #status req
<> NEW
then
53 ignore (C
.dml
db ($`UPDATE ^table SET cstamp
= CURRENT_TIMESTAMP WHERE id
= ^
(C
.intToSql (#id req
))`
))
56 ignore (C
.dml
db ($`UPDATE ^table SET
57 usr
= ^
(C
.intToSql (#usr req
)), data
= ^
(C
.stringToSql (#data req
)),
58 msg
= ^
(C
.stringToSql (#msg req
)), status
= ^
(statusToSql (#status req
))
59 WHERE id
= ^
(C
.intToSql (#id req
))`
))
63 ignore (C
.dml (getDb ()) ($`DELETE FROM ^table WHERE id
= ^
(C
.intToSql id
)`
))
66 case C
.oneOrNoRows (getDb ()) ($`SELECT id
, usr
, data
, msg
, status
, stamp
, cstamp
68 WHERE id
= ^
(C
.intToSql id
)`
) of
70 | NONE
=> raise Fail ($`^table request not found`
)
72 fun mkRow
' (name
:: rest
) = (C
.stringFromSql name
, mkRow rest
)
73 | mkRow
' r
= rowError ("Apt.request'", r
)
76 C
.map (getDb ()) mkRow
' ($`SELECT name
, ^table
.id
, usr
, data
, msg
, status
, stamp
, cstamp
77 FROM ^table JOIN WebUser ON usr
= WebUser
.id
81 C
.map (getDb ()) mkRow
' ($`SELECT name
, ^table
.id
, usr
, data
, msg
, status
, stamp
, cstamp
82 FROM ^table JOIN WebUser ON usr
= WebUser
.id
89 case Group
.groupNameToId T
.adminGroup
of
94 val user
= Init
.lookupUser (#usr req
)
96 val mail
= Mail
.mopen ()
100 val name
= C
.stringFromSql name
102 if name
= #name user
then
105 (Mail
.mwrite (mail
, name
);
106 Mail
.mwrite (mail
, emailSuffix
);
107 Mail
.mwrite (mail
, ","))
109 | doOne r
= rowError (table ^
".doOne", r
)
111 Mail
.mwrite (mail
, "From: Hcoop Portal <portal");
112 Mail
.mwrite (mail
, emailSuffix
);
113 Mail
.mwrite (mail
, ">\nTo: ");
114 Mail
.mwrite (mail
, #name user
);
115 Mail
.mwrite (mail
, emailSuffix
);
116 Mail
.mwrite (mail
, "\nBcc: ");
117 C
.app (getDb ()) doOne ($`SELECT name
118 FROM WebUser JOIN Membership
ON (usr
= id AND grp
= ^
(C
.intToSql grp
))`
);
119 Mail
.mwrite (mail
, "\nSubject: ");
120 Mail
.mwrite (mail
, T
.subject (#data req
));
121 Mail
.mwrite (mail
, "\n\n");
125 T
.body (mail
, #data req
);
127 Mail
.mwrite (mail
, "\n");
128 Mail
.mwrite (mail
, #msg req
);
130 Mail
.mwrite (mail
, "\n\nOpen requests: ");
131 Mail
.mwrite (mail
, urlPrefix
);
132 Mail
.mwrite (mail
, T
.template
);
133 Mail
.mwrite (mail
, "?cmd=open\n");
135 OS
.Process
.isSuccess (Mail
.mclose mail
)
138 val notifyNew
= notify (fn (user
, mail
) =>
139 (Mail
.mwrite (mail
, #name user
);
140 Mail
.mwrite (mail
, " has requested the following ");
141 Mail
.mwrite (mail
, T
.descr
);
142 Mail
.mwrite (mail
, ":\n\n")))
146 | INSTALLED
=> "Installed"
147 | REJECTED
=> "Rejected"
149 fun notifyMod (oldStatus
, newStatus
, changer
, req
) =
150 if oldStatus
= newStatus
then
151 notify (fn (_
, mail
) =>
152 (Mail
.mwrite (mail
, changer
);
153 Mail
.mwrite (mail
, " has added a comment to this request.\n\n"))) req
155 notify (fn (_
, mail
) =>
156 (Mail
.mwrite (mail
, changer
);
157 Mail
.mwrite (mail
, " has changed the status of this request from ");
158 Mail
.mwrite (mail
, statusToString oldStatus
);
159 Mail
.mwrite (mail
, " to ");
160 Mail
.mwrite (mail
, statusToString newStatus
);
161 Mail
.mwrite (mail
, ".\n\n"))) req