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
, 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
, node
, data
, msg
, status
, stamp
] =
31 {id
= C
.intFromSql id
, usr
= C
.intFromSql usr
, node
= C
.intFromSql node
,
32 data
= C
.stringFromSql data
,
33 msg
= C
.stringFromSql msg
, status
= statusFromSql status
, stamp
= C
.timestampFromSql stamp
}
34 | mkRow r
= rowError ("APT request", r
)
36 fun add
{usr
, node
, data
, msg
} =
39 val id
= nextSeq (db
, seq
)
41 C
.dml
db ($`INSERT INTO ^
table (id
, usr
, node
, data
, msg
, status
, stamp
)
42 VALUES (^
(C
.intToSql id
), ^
(C
.intToSql usr
), ^
(C
.intToSql node
), ^
(C
.stringToSql data
), ^
(C
.stringToSql msg
),
43 0, CURRENT_TIMESTAMP
)`
);
47 fun modify (req
: request
) =
51 ignore (C
.dml
db ($`UPDATE ^table SET
52 usr
= ^
(C
.intToSql (#usr req
)), data
= ^
(C
.stringToSql (#data req
)),
53 node
= ^
(C
.intToSql (#node req
)),
54 msg
= ^
(C
.stringToSql (#msg req
)), status
= ^
(statusToSql (#status req
))
55 WHERE id
= ^
(C
.intToSql (#id req
))`
))
59 ignore (C
.dml (getDb ()) ($`DELETE FROM ^table WHERE id
= ^
(C
.intToSql id
)`
))
62 case C
.oneOrNoRows (getDb ()) ($`SELECT id
, usr
, node
, data
, msg
, status
, stamp
64 WHERE id
= ^
(C
.intToSql id
)`
) of
66 | NONE
=> raise Fail ($`^table request not found`
)
68 fun mkRow
' (name
:: rest
) = (C
.stringFromSql name
, mkRow rest
)
69 | mkRow
' r
= rowError ("Apt.request'", r
)
72 C
.map (getDb ()) mkRow
' ($`SELECT name
, ^table
.id
, usr
, node
, data
, msg
, status
, stamp
73 FROM ^table JOIN WebUser ON usr
= WebUser
.id
77 C
.map (getDb ()) mkRow
' ($`SELECT name
, ^table
.id
, usr
, node
, data
, msg
, status
, stamp
78 FROM ^table JOIN WebUser ON usr
= WebUser
.id
85 case Group
.groupNameToId T
.adminGroup
of
90 val user
= Init
.lookupUser (#usr req
)
92 val mail
= Mail
.mopen ()
96 val name
= C
.stringFromSql name
98 if name
= #name user
then
101 (Mail
.mwrite (mail
, name
);
102 Mail
.mwrite (mail
, emailSuffix
);
103 Mail
.mwrite (mail
, ","))
105 | doOne r
= rowError (table ^
".doOne", r
)
107 Mail
.mwrite (mail
, "From: Hcoop Portal <portal");
108 Mail
.mwrite (mail
, emailSuffix
);
109 Mail
.mwrite (mail
, ">\nTo: ");
110 Mail
.mwrite (mail
, #name user
);
111 Mail
.mwrite (mail
, emailSuffix
);
112 Mail
.mwrite (mail
, "\nBcc: ");
113 C
.app (getDb ()) doOne ($`SELECT name
114 FROM WebUser JOIN Membership
ON (usr
= id AND grp
= ^
(C
.intToSql grp
))`
);
115 Mail
.mwrite (mail
, "\nSubject: ");
116 Mail
.mwrite (mail
, T
.subject (#data req
));
117 Mail
.mwrite (mail
, "\n\n");
119 Mail
.mwrite (mail
, "Machine: ");
120 Mail
.mwrite (mail
, Init
.nodeName (#node req
));
121 Mail
.mwrite (mail
, "\n\n");
125 T
.body
{node
= #node req
, mail
= mail
, data
= #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
{old
, new
, changer
, req
} =
150 notify (fn (_
, mail
) =>
151 (Mail
.mwrite (mail
, changer
);
152 Mail
.mwrite (mail
, " has changed the status of this request from ");
153 Mail
.mwrite (mail
, statusToString old
);
154 Mail
.mwrite (mail
, " to ");
155 Mail
.mwrite (mail
, statusToString new
);
156 Mail
.mwrite (mail
, ".\n\n"))) req