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
, stamp
: C
.timestamp
}
20 | _
=> raise C
.Sql
"Bad APT request status"
27 fun statusFromSql v
= statusFromInt (C
.intFromSql v
)
28 fun statusToSql s
= C
.intToSql (statusToInt s
)
30 fun mkRow
[id
, usr
, data
, msg
, status
, stamp
] =
31 {id
= C
.intFromSql id
, usr
= C
.intFromSql usr
, data
= C
.stringFromSql data
,
32 msg
= C
.stringFromSql msg
, status
= statusFromSql status
, stamp
= C
.timestampFromSql stamp
}
33 | mkRow r
= rowError ("APT request", r
)
35 fun add (usr
, data
, msg
) =
38 val id
= nextSeq (db
, seq
)
40 C
.dml
db ($`INSERT INTO ^
table (id
, usr
, data
, msg
, status
, stamp
)
41 VALUES (^
(C
.intToSql id
), ^
(C
.intToSql usr
), ^
(C
.stringToSql data
), ^
(C
.stringToSql msg
),
42 0, CURRENT_TIMESTAMP
)`
);
46 fun modify (req
: request
) =
50 ignore (C
.dml
db ($`UPDATE ^table SET
51 usr
= ^
(C
.intToSql (#usr req
)), data
= ^
(C
.stringToSql (#data req
)),
52 msg
= ^
(C
.stringToSql (#msg req
)), status
= ^
(statusToSql (#status req
))
53 WHERE id
= ^
(C
.intToSql (#id req
))`
))
57 ignore (C
.dml (getDb ()) ($`DELETE FROM ^table WHERE id
= ^
(C
.intToSql id
)`
))
60 case C
.oneOrNoRows (getDb ()) ($`SELECT id
, usr
, data
, msg
, status
, stamp
62 WHERE id
= ^
(C
.intToSql id
)`
) of
64 | NONE
=> raise Fail ($`^table request not found`
)
66 fun mkRow
' (name
:: rest
) = (C
.stringFromSql name
, mkRow rest
)
67 | mkRow
' r
= rowError ("Apt.request'", r
)
70 C
.map (getDb ()) mkRow
' ($`SELECT name
, ^table
.id
, usr
, data
, msg
, status
, stamp
71 FROM ^table JOIN WebUser ON usr
= WebUser
.id
75 C
.map (getDb ()) mkRow
' ($`SELECT name
, ^table
.id
, usr
, data
, msg
, status
, stamp
76 FROM ^table JOIN WebUser ON usr
= WebUser
.id
83 case Group
.groupNameToId T
.adminGroup
of
88 val user
= Init
.lookupUser (#usr req
)
90 val mail
= Mail
.mopen ()
94 val name
= C
.stringFromSql name
96 if name
= #name user
then
99 (Mail
.mwrite (mail
, name
);
100 Mail
.mwrite (mail
, emailSuffix
);
101 Mail
.mwrite (mail
, ","))
103 | doOne r
= rowError (table ^
".doOne", r
)
105 Mail
.mwrite (mail
, "From: Hcoop Portal <portal");
106 Mail
.mwrite (mail
, emailSuffix
);
107 Mail
.mwrite (mail
, ">\nTo: ");
108 Mail
.mwrite (mail
, #name user
);
109 Mail
.mwrite (mail
, emailSuffix
);
110 Mail
.mwrite (mail
, "\nBcc: ");
111 C
.app (getDb ()) doOne ($`SELECT name
112 FROM WebUser JOIN Membership
ON (usr
= id AND grp
= ^
(C
.intToSql grp
))`
);
113 Mail
.mwrite (mail
, "\nSubject: ");
114 Mail
.mwrite (mail
, T
.subject (#data req
));
115 Mail
.mwrite (mail
, "\n\n");
119 T
.body (mail
, #data req
);
121 Mail
.mwrite (mail
, "\n");
122 Mail
.mwrite (mail
, #msg req
);
124 Mail
.mwrite (mail
, "\n\nOpen requests: ");
125 Mail
.mwrite (mail
, urlPrefix
);
126 Mail
.mwrite (mail
, T
.template
);
127 Mail
.mwrite (mail
, "?cmd=open\n");
129 OS
.Process
.isSuccess (Mail
.mclose mail
)
132 val notifyNew
= notify (fn (user
, mail
) =>
133 (Mail
.mwrite (mail
, #name user
);
134 Mail
.mwrite (mail
, " has requested the following ");
135 Mail
.mwrite (mail
, T
.descr
);
136 Mail
.mwrite (mail
, ":\n\n")))
140 | INSTALLED
=> "Installed"
141 | REJECTED
=> "Rejected"
143 fun notifyMod (oldStatus
, newStatus
, changer
, req
) =
144 notify (fn (_
, mail
) =>
145 (Mail
.mwrite (mail
, changer
);
146 Mail
.mwrite (mail
, " has changed the status of this request from ");
147 Mail
.mwrite (mail
, statusToString oldStatus
);
148 Mail
.mwrite (mail
, " to ");
149 Mail
.mwrite (mail
, statusToString newStatus
);
150 Mail
.mwrite (mail
, ".\n\n"))) req