1 functor RequestH (T
: REQUESTH_IN
) :> REQUESTH_OUT
=
7 val seq
= table ^
"Seq"
14 type request
= { id
: int, usr
: int, node
: 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
, node
, data
, msg
, status
, stamp
, cstamp
] =
32 {id
= C
.intFromSql id
, usr
= C
.intFromSql usr
, node
= C
.intFromSql node
,
33 data
= C
.stringFromSql data
,
34 msg
= C
.stringFromSql msg
, status
= statusFromSql status
, stamp
= C
.timestampFromSql stamp
,
35 cstamp
= if C
.isNull cstamp
then NONE
else SOME (C
.timestampFromSql cstamp
)}
36 | mkRow r
= rowError ("APT request", r
)
38 fun add
{usr
, node
, data
, msg
} =
41 val id
= nextSeq (db
, seq
)
43 C
.dml
db ($`INSERT INTO ^
table (id
, usr
, node
, data
, msg
, status
, stamp
, cstamp
)
44 VALUES (^
(C
.intToSql id
), ^
(C
.intToSql usr
), ^
(C
.intToSql node
), ^
(C
.stringToSql data
), ^
(C
.stringToSql msg
),
45 0, CURRENT_TIMESTAMP
, NULL
)`
);
49 fun modify (req
: request
) =
53 if #status req
<> NEW
then
54 ignore (C
.dml
db ($`UPDATE ^table SET cstamp
= CURRENT_TIMESTAMP WHERE id
= ^
(C
.intToSql (#id req
))`
))
58 ignore (C
.dml
db ($`UPDATE ^table SET
59 usr
= ^
(C
.intToSql (#usr req
)), data
= ^
(C
.stringToSql (#data req
)),
60 node
= ^
(C
.intToSql (#node req
)),
61 msg
= ^
(C
.stringToSql (#msg req
)), status
= ^
(statusToSql (#status req
))
62 WHERE id
= ^
(C
.intToSql (#id req
))`
))
66 ignore (C
.dml (getDb ()) ($`DELETE FROM ^table WHERE id
= ^
(C
.intToSql id
)`
))
69 case C
.oneOrNoRows (getDb ()) ($`SELECT id
, usr
, node
, data
, msg
, status
, stamp
, cstamp
71 WHERE id
= ^
(C
.intToSql id
)`
) of
73 | NONE
=> raise Fail ($`^table request not found`
)
75 fun mkRow
' (name
:: rest
) = (C
.stringFromSql name
, mkRow rest
)
76 | mkRow
' r
= rowError ("Apt.request'", r
)
79 C
.map (getDb ()) mkRow
' ($`SELECT name
, ^table
.id
, usr
, node
, data
, msg
, status
, stamp
, cstamp
80 FROM ^table JOIN WebUser ON usr
= WebUser
.id
84 C
.map (getDb ()) mkRow
' ($`SELECT name
, ^table
.id
, usr
, node
, data
, msg
, status
, stamp
, cstamp
85 FROM ^table JOIN WebUser ON usr
= WebUser
.id
92 case Group
.groupNameToId T
.adminGroup
of
97 val user
= Init
.lookupUser (#usr req
)
99 val mail
= Mail
.mopen ()
103 val name
= C
.stringFromSql name
105 if name
= #name user
then
108 (Mail
.mwrite (mail
, name
);
109 Mail
.mwrite (mail
, emailSuffix
);
110 Mail
.mwrite (mail
, ","))
112 | doOne r
= rowError (table ^
".doOne", r
)
114 Mail
.mwrite (mail
, "From: Hcoop Portal <portal");
115 Mail
.mwrite (mail
, emailSuffix
);
116 Mail
.mwrite (mail
, ">\nTo: ");
117 Mail
.mwrite (mail
, #name user
);
118 Mail
.mwrite (mail
, emailSuffix
);
119 Mail
.mwrite (mail
, "\nBcc: ");
120 C
.app (getDb ()) doOne ($`SELECT name
121 FROM WebUser JOIN Membership
ON (usr
= id AND grp
= ^
(C
.intToSql grp
))`
);
122 Mail
.mwrite (mail
, "\nSubject: ");
123 Mail
.mwrite (mail
, T
.subject (#data req
));
124 Mail
.mwrite (mail
, "\n\n");
126 Mail
.mwrite (mail
, "Machine: ");
127 Mail
.mwrite (mail
, Init
.nodeName (#node req
));
128 Mail
.mwrite (mail
, "\n\n");
132 T
.body
{node
= #node req
, mail
= mail
, data
= #data req
};
134 Mail
.mwrite (mail
, "\n");
135 Mail
.mwrite (mail
, #msg req
);
137 Mail
.mwrite (mail
, "\n\nOpen requests: ");
138 Mail
.mwrite (mail
, urlPrefix
);
139 Mail
.mwrite (mail
, T
.template
);
140 Mail
.mwrite (mail
, "?cmd=open\n");
142 OS
.Process
.isSuccess (Mail
.mclose mail
)
145 val notifyNew
= notify (fn (user
, mail
) =>
146 (Mail
.mwrite (mail
, #name user
);
147 Mail
.mwrite (mail
, " has requested the following ");
148 Mail
.mwrite (mail
, T
.descr
);
149 Mail
.mwrite (mail
, ":\n\n")))
153 | INSTALLED
=> "Installed"
154 | REJECTED
=> "Rejected"
156 fun notifyMod
{old
, new
, changer
, req
} =
158 notify (fn (_
, mail
) =>
159 (Mail
.mwrite (mail
, changer
);
160 Mail
.mwrite (mail
, " has added a comment to this request.\n\n"))) req
162 notify (fn (_
, mail
) =>
163 (Mail
.mwrite (mail
, changer
);
164 Mail
.mwrite (mail
, " has changed the status of this request from ");
165 Mail
.mwrite (mail
, statusToString old
);
166 Mail
.mwrite (mail
, " to ");
167 Mail
.mwrite (mail
, statusToString new
);
168 Mail
.mwrite (mail
, ".\n\n"))) req