@@ -1,5 +1,10 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE TemplateHaskell #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE ExtendedDefaultRules #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TemplateHaskell #-}
5+{-# LANGUAGE TypeFamilies #-}
6+
7+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
38
49-- Module : Network.PagerDuty.REST.Users
510-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
@@ -18,36 +23,88 @@
1823-- /See:/ <http://developer.pagerduty.com/documentation/rest/users>
1924module Network.PagerDuty.REST.Users
2025 (
26+ -- * List Users
27+ ListUsers
28+ , listUsers
29+ , luQuery
30+
31+ -- * Create User
32+ , CreateUser
33+ , createUser
34+ , cuName
35+ , cuEmail
36+ , cuRole
37+ , cuJobTitle
38+ , cuTimeZone
39+
40+ -- * Get User
41+ , getUser
42+
43+ -- * Get User On Call
44+ , getUserOnCall
45+
46+ -- * Update User
47+ , UpdateUser
48+ , updateUser
49+ , uuName
50+ , uuEmail
51+ , uuRole
52+ , uuJobTitle
53+ , uuTimeZone
54+
55+ -- * Delete User
56+ , deleteUser
2157
2258 -- * Types
23− HasUserInfo (..)
59+ , PolicyInfo
60+ , piId
61+ , piName
62+
63+ , OnCall
64+ , ocLevel
65+ , ocStart
66+ , ocEnd
67+ , ocEscalationPolicy
68+
69+ , Role (..)
70+
71+ , HasUserInfo (..)
2472 , UserInfo
2573 , User
2674 , uRole
2775 , uAvatarUrl
28− , uUrl
76+ , uUserUrl
2977 , uInvitationSent
78+ , uJobTitle
3079 ) where
3180
3281import Control.Applicative hiding (empty)
3382import Control.Lens hiding ((.=))
3483import Data.Aeson
35−import Data.Monoid
84+import Data.Default
3685import Data.Text (Text)
3786import Data.Time
3887import Network.HTTP.Types
3988import Network.PagerDuty.TH
4089import Network.PagerDuty.Types
4190
91+default (Path)
92+
4293users :: Path
4394users = "users"
4495
96+includes :: Query
97+includes =
98+ [ ("include[]", Just "contact_methods")
99+ , ("include[]", Just "notification_rules")
100+ ]
101+
45102data UserInfo = UserInfo
46103 { _uId' :: UserId
47104 , _uName' :: Text
48105 , _uEmail' :: Address
49106 , _uColor' :: Text
50− , _uTimeZone' :: Maybe TZ
107+ , _uTimeZone' :: TZ
51108 } deriving (Eq, Show)
52109
53110deriveRecord ''UserInfo
@@ -68,13 +125,13 @@ class HasUserInfo a where
68125 uColor :: Lens' a Text
69126
70127 -- | The user's personal time zone.
71− uTimeZone :: Lens' a (Maybe TimeZone)
128+ uTimeZone :: Lens' a TimeZone
72129
73130 uId = userInfo.uId'
74131 uName = userInfo.uName'
75132 uEmail = userInfo.uEmail'
76133 uColor = userInfo.uColor'
77− uTimeZone = userInfo.uTimeZone'.mapping _TZ
134+ uTimeZone = userInfo.uTimeZone'._TZ
78135
79136instance (QueryLike a, ToJSON a, HasUserInfo a)
80137 => HasUserInfo (Request a s b) where
@@ -83,34 +140,66 @@ instance (QueryLike a, ToJSON a, HasUserInfo a)
83140instance HasUserInfo UserInfo where
84141 userInfo = id
85142
143+data PolicyInfo = PolicyInfo
144+ { _piId :: PolicyId
145+ , _piName :: Text
146+ } deriving (Eq, Show)
147+
148+deriveRecord ''PolicyInfo
149+
150+data OnCall = OnCall
151+ { _ocLevel :: !Int
152+ , _ocStart :: Maybe Date
153+ , _ocEnd :: Maybe Date
154+ , _ocEscalationPolicy :: PolicyInfo
155+ } deriving (Eq, Show)
156+
157+deriveRecord ''OnCall
158+
159+data Role
160+ = RoleAdmin
161+ | RoleUser
162+ | RoleLimitedUser
163+ deriving (Eq, Show)
164+
165+deriveNullaryWith (dropped 4 underscored) ''Role
166+
167+instance Default Role where
168+ def = RoleUser
169+
86170data User = User
87171 { _uInfo :: UserInfo
88− , _uRole :: Text
172+ , _uRole :: !Role
89173 , _uAvatarUrl :: Text
90− , _uUrl :: Text
174+ , _uUserUrl :: Text
91175 , _uInvitationSent' :: !Bool'
176+ , _uJobTitle :: Maybe Text
92177 } deriving (Eq, Show)
93178
179+ -- FIXME: add notification_rules, contact_methods, on_call
180+
94181makeLenses ''User
95182
96183instance FromJSON User where
97184 parseJSON = withObject "user" $ \o ->
98185 User <$> parseJSON (Object o)
99− <*> o .: "role"
100− <*> o .: "avatar_url"
101− <*> o .: "url"
102− <*> o .: "invitation_sent"
103−
104−instance ToJSON User where
105− toJSON u = Object (x <> y)
106− where
107− Object x = toJSON (_uInfo u)
108− Object y = object
109− [ "role" .= _uRole u
110− , "avatar_url" .= _uAvatarUrl u
111− , "url" .= _uUrl u
112− , "invitation_sent" .= _uInvitationSent' u
113− ]
186+ <*> o .: "role"
187+ <*> o .: "avatar_url"
188+ <*> o .: "user_url"
189+ <*> o .: "invitation_sent"
190+ <*> o .:? "job_title"
191+
192+-- instance ToJSON User where
193+-- toJSON u = Object (x <> y)
194+-- where
195+-- Object x = toJSON (_uInfo u)
196+-- Object y = object
197+-- [ "role" .= _uRole u
198+-- , "avatar_url" .= _uAvatarUrl u
199+-- , "user_url" .= _uUserUrl u
200+-- , "invitation_sent" .= _uInvitationSent' u
201+-- , "job_title"
202+-- ]
114203
115204instance HasUserInfo User where
116205 userInfo = uInfo
@@ -118,19 +207,38 @@ instance HasUserInfo User where
118207uInvitationSent :: Lens' User Bool
119208uInvitationSent = uInvitationSent'._B
120209
210+newtype ListUsers = ListUsers
211+ { _luQuery' :: Maybe Text
212+ }
213+
214+queryRequest ''ListUsers
215+
216+instance Paginate ListUsers
217+
218+-- | Filters the result, showing only the users whose names or email addresses
219+-- match the query.
220+luQuery :: Lens' (Request ListUsers s b) (Maybe Text)
221+luQuery = upd.luQuery'
222+
121223-- | List users of your PagerDuty account, optionally filtered by a search query.
122224--
123225-- @GET \/users@
124226--
125227-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/list>
126−listUsers = undefined
228+listUsers :: Request ListUsers s [User]
229+listUsers =
230+ mk ListUsers
231+ { _luQuery' = Nothing
232+ } & path .~ users
233+ & query .~ includes
127234
128235-- | Get information about an existing user.
129236--
130237-- @GET \/users\/\:id@
131238--
132239-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/show>
133−getUser = undefined
240+getUser :: UserId -> Request Empty s User
241+getUser u = empty & path .~ users % u & query .~ includes
134242
135243-- | Get a user object with that user's current on-call status. If the on-call
136244-- object is an empty list, the user is never on-call.
@@ -141,7 +249,40 @@ getUser = undefined
141249-- @GET \/users\/\:id\/on_call@
142250--
143251-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/show_on_call>
144−getUserOnCall = undefined
252+getUserOnCall :: UserId -> Request Empty s User
253+getUserOnCall u = empty & path .~ users % u % "on_call" & query .~ includes
254+
255+data CreateUser = CreateUser
256+ { _cuName' :: Text
257+ , _cuEmail' :: Address
258+ , _cuRole' :: Maybe Role
259+ , _cuJobTitle' :: Maybe Text
260+ , _cuTimeZone' :: Maybe TZ
261+ } deriving (Eq, Show)
262+
263+jsonRequest ''CreateUser
264+
265+-- | The name of the user.
266+cuName :: Lens' (Request CreateUser s b) Text
267+cuName = upd.cuName'
268+
269+-- | The email of the user. The newly created user will receive an email asking
270+-- to confirm the subscription.
271+cuEmail :: Lens' (Request CreateUser s b) Address
272+cuEmail = upd.cuEmail'
273+
274+-- | The user's role.
275+cuRole :: Lens' (Request CreateUser s b) (Maybe Role)
276+cuRole = upd.cuRole'
277+
278+-- | The job title of the user.
279+cuJobTitle :: Lens' (Request CreateUser s b) (Maybe Text)
280+cuJobTitle = upd.cuJobTitle'
281+
282+-- | The time zone the user is in. If not specified, the time zone of the
283+-- account making the API call will be used.
284+cuTimeZone :: Lens' (Request CreateUser s b) (Maybe TimeZone)
285+cuTimeZone = upd.cuTimeZone'.mapping _TZ
145286
146287-- | Create a new user for your account. An invite email will be sent asking
147288-- the user to choose a password.
@@ -149,18 +290,80 @@ getUserOnCall = undefined
149290-- @POST \/users@
150291--
151292-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/create>
152−createUser = undefined
293+createUser :: RequesterId
294+ -> Text -- ^ 'cuName'
295+ -> Address -- ^ 'cuEmail'
296+ -> Request CreateUser s User
297+createUser r n e = auth (createUserBasic n e) & query .~ [("requester_id", r)]
298+
299+-- | A version of 'disableService' which uses HTTP Basic authentication and
300+-- doesn't require a 'RequesterId'.
301+createUserBasic :: Text -- ^ 'cuName'
302+ -> Address -- ^ 'cuEmail'
303+ -> Request CreateUser Basic User
304+createUserBasic n e =
305+ mk CreateUser
306+ { _cuName' = n
307+ , _cuEmail' = e
308+ , _cuRole' = Nothing
309+ , _cuJobTitle' = Nothing
310+ , _cuTimeZone' = Nothing
311+ } & meth .~ POST
312+ & path .~ users
313+
314+data UpdateUser = UpdateUser
315+ { _uuName' :: Maybe Text
316+ , _uuEmail' :: Maybe Address
317+ , _uuRole' :: Maybe Role
318+ , _uuJobTitle' :: Maybe Text
319+ , _uuTimeZone' :: Maybe TZ
320+ } deriving (Eq, Show)
321+
322+jsonRequest ''UpdateUser
323+
324+-- | The name of the user.
325+uuName :: Lens' (Request UpdateUser s b) (Maybe Text)
326+uuName = upd.uuName'
327+
328+-- | The email of the user. The newly created user will receive an email asking
329+-- to confirm the subscription.
330+uuEmail :: Lens' (Request UpdateUser s b) (Maybe Address)
331+uuEmail = upd.uuEmail'
332+
333+-- | The user's role.
334+uuRole :: Lens' (Request UpdateUser s b) (Maybe Role)
335+uuRole = upd.uuRole'
336+
337+-- | The job title of the user.
338+uuJobTitle :: Lens' (Request UpdateUser s b) (Maybe Text)
339+uuJobTitle = upd.uuJobTitle'
340+
341+-- | The time zone the user is in. If not specified, the time zone of the
342+-- account making the API call will be used.
343+uuTimeZone :: Lens' (Request UpdateUser s b) (Maybe TimeZone)
344+uuTimeZone = upd.uuTimeZone'.mapping _TZ
153345
154346-- | Update an existing user.
155347--
156348-- @PUT \/users\/\:id@
157349--
158350-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/update>
159−updateUser = undefined
351+updateUser :: UserId -> Request UpdateUser s User
352+updateUser u =
353+ mk UpdateUser
354+ { _uuName' = Nothing
355+ , _uuEmail' = Nothing
356+ , _uuRole' = Nothing
357+ , _uuJobTitle' = Nothing
358+ , _uuTimeZone' = Nothing
359+ } & meth .~ PUT
360+ & path .~ users % u
160361
161362-- | Remove an existing user.
162363--
163364-- @DELETE \/users\/\:id@
164365--
165366-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/delete>
166−deleteUser = undefined
367+deleteUser :: UserId -> Request Empty s Empty
368+deleteUser u = empty & meth .~ DELETE & path .~ users % u
369+-- FIXME: deal with conflict errors