@@ -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.Schedules
510-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
@@ -17,9 +22,104 @@
1722-- This API allows users to manipulate on-call schedules.
1823module Network.PagerDuty.REST.Schedules
1924 (
20−
25+ -- * List Schedules
26+ ListSchedules
27+ , listSchedules
28+ , lsQuery
29+
30+ -- * Get Schedule
31+ , GetSchedule
32+ , getSchedule
33+ , gsSince
34+ , gsUntil
35+ , gsTimeZone
36+
37+ -- * Get Schedule Users
38+ , GetScheduleUsers
39+ , getScheduleUsers
40+ , gsuSince
41+ , gsuUntil
42+
43+ -- * Get Schedule Entries
44+ , GetScheduleEntries
45+ , getScheduleEntries
46+ , gseSince
47+ , gseUntil
48+ , gseOverflow
49+ , gseTimeZone
50+ , gseUserId
51+
52+ -- * Create Schedule
53+ , CreateSchedule
54+ , createSchedule
55+ , csName
56+ , csOverflow
57+ , csTimeZone
58+ , csScheduleLayers
59+
60+ -- * Update Schedule
61+ , UpdateSchedule
62+ , updateSchedule
63+ , usOverflow
64+ , usTimeZone
65+ , usScheduleLayers
66+
67+ -- * Preview Schedule
68+ , PreviewSchedule
69+ , previewSchedule
70+ , psSince
71+ , psUntil
72+ , psOverflow
73+ , psName
74+ , psTimeZone
75+ , psScheduleLayers
76+
77+ -- * Delete Schedule
78+ , deleteSchedule
79+
80+ -- * Types
81+ , RestrictionType (..)
82+ , Restriction
83+ , rStartTimeOfDay
84+ , rDurationSeconds
85+
86+ , Rotation
87+ , rMemberOrder
88+ , rUser
89+
90+ , ScheduleLayer
91+ , slName
92+ , slRenderedScheduleEntries
93+ , slRestrictionType
94+ , slRestrictions
95+ , slPriority
96+ , slStart
97+ , slEnd
98+ , slRenderedCoveragePercentage
99+ , slRotationTurnLengthSeconds
100+ , slRotationVirtualStart
101+ , slUsers
102+
103+ , HasScheduleInfo (..)
104+ , ScheduleInfo
105+ , Schedule
106+ , sScheduleLayers
107+ , sOverridesSubschedule
108+ , sFinalSchedule
21109 ) where
22110
111+import Control.Lens hiding ((.=))
112+import Data.Aeson
113+import Data.ByteString.Builder (Builder)
114+import Data.Text (Text)
115+import Data.Time
116+import Network.HTTP.Types.QueryLike
117+import Network.PagerDuty.REST.Users (User)
118+import Network.PagerDuty.TH
119+import Network.PagerDuty.Types
120+
121+default (Builder)
122+
23123schedules :: Path
24124schedules = "schedules"
25125
@@ -39,11 +139,9 @@ deriveJSON ''Restriction
39139
40140rStartTimeOfDay :: Lens' Restriction UTCTime
41141rStartTimeOfDay =
42− lens _rStartTimeOfDay (\r x -> r { _rStartTimeOfDay = x }) . _Date
142+ lens _rStartTimeOfDay (\r x -> r { _rStartTimeOfDay = x }) . _D
43143
44−rDurationSeconds :: Lens' Restriction UTCTime
45−rDurationSeconds =
46− lens _rDurationSeconds (\r x -> r { _rDurationSeconds = x }) . _Date
144+makeLens "_rDurationSeconds" ''Restriction
47145
48146data Rotation = Rotation
49147 { _rMemberOrder :: !Int
@@ -122,32 +220,64 @@ makeLens "_slRotationVirtualStart" ''ScheduleLayer
122220makeLens "_slUsers" ''ScheduleLayer
123221
124222data ScheduleInfo = ScheduleInfo
125− { _sId :: ScheduleId
126− , _sName :: Text
127− , _sTimeZone :: TZ
128− , _sToday :: Date
129− , _sEscalationPolicies :: [PolicyId]
223+ { _siId' :: ScheduleId
224+ , _siName' :: Text
225+ , _siTimeZone' :: TZ
226+ , _siToday' :: Date
227+ , _siEscalationPolicies' :: [PolicyId]
130228 } deriving (Eq, Show)
131229
132−makeClassy ''ScheduleInfo
230+deriveRecord ''ScheduleInfo
231+
232+class HasScheduleInfo a where
233+ scheduleInfo :: Lens' a ScheduleInfo
234+
235+ -- | The unique identifier of the schedule.
236+ sId :: Lens' a ScheduleId
237+ -- | The name of the schedule.
238+ sName :: Lens' a Text
239+ -- | The time zone of the schedule.
240+ sTimeZone :: Lens' a TimeZone
241+ -- | The current day in the schedule's time zone.
242+ sToday :: Lens' a UTCTime
243+ -- | An array of all the escalation policies that uses this schedule.
244+ sEscalationPolicies :: Lens' a [PolicyId]
245+
246+ sId = scheduleInfo.siId'
247+ sName = scheduleInfo.siName'
248+ sTimeZone = scheduleInfo.siTimeZone'._TZ
249+ sToday = scheduleInfo.siToday'._D
250+ sEscalationPolicies = scheduleInfo.siEscalationPolicies'
251+
252+instance HasScheduleInfo ScheduleInfo where
253+ scheduleInfo = id
133254
134255data Schedule = Schedule
135− { _sInfo' :: ScheduleInfo
136− , _sScheduleLayers' :: [ScheduleLayer]
137− , _sOverridesSubschedule' :: ScheduleLayer
138− , _sFinalSchedule' :: ScheduleLayer
256+ { _sInfo :: ScheduleInfo
257+ , _sScheduleLayers :: [ScheduleLayer]
258+ , _sOverridesSubschedule :: ScheduleLayer
259+ , _sFinalSchedule :: ScheduleLayer
139260 } deriving (Eq, Show)
140261
141−deriveRecord ''Schedule
262+deriveJSON ''Schedule
142263
143264instance HasScheduleInfo Schedule where
144− scheduleInfo = sInfo'
265+ scheduleInfo = lens _sInfo (\s x -> s { _sInfo = x })
266+
267+-- | A list of schedule layers. See the schedule layers parameters for details.
268+makeLens "_sScheduleLayers" ''Schedule
269+
270+-- | The schedule layer object where all the overrides are stored.
271+makeLens "_sOverridesSubschedule" ''Schedule
272+
273+-- | The final schedule layer object.
274+makeLens "_sFinalSchedule" ''Schedule
145275
146276newtype ListSchedules = ListSchedules
147277 { _lsQuery' :: Maybe Text
148278 } deriving (Eq, Show)
149279
150−deriveQuery ''ListSchedules
280+queryRequest ''ListSchedules
151281
152282-- | Filters the result, showing only the schedules whose name matches the query.
153283lsQuery :: Lens' (Request ListSchedules s b) (Maybe Text)
@@ -177,7 +307,7 @@ data GetSchedule = GetSchedule
177307 , _gsTimeZone' :: Maybe TZ
178308 } deriving (Eq, Show)
179309
180−deriveQuery ''GetSchedule
310+queryRequest ''GetSchedule
181311
182312-- | The start of the date range over which you want to return on-call schedule
183313-- entries and on-call schedule layers.
@@ -215,7 +345,7 @@ data GetScheduleUsers = GetScheduleUsers
215345 , _gsuUntil' :: Maybe Date
216346 } deriving (Eq, Show)
217347
218−deriveQuery ''GetScheduleUsers
348+queryRequest ''GetScheduleUsers
219349
220350-- | The start of the date range over which you want to return on-call users.
221351gsuSince :: Lens' (Request GetScheduleUsers s b) (Maybe UTCTime)
@@ -245,7 +375,7 @@ data GetScheduleEntries = GetScheduleEntries
245375 , _gseUserId' :: Maybe UserId
246376 } deriving (Eq, Show)
247377
248−deriveRecord ''GetScheduleEntries
378+queryRequest ''GetScheduleEntries
249379
250380-- | The start of the date range over which you want to return on-call
251381-- schedule entries.
@@ -274,12 +404,12 @@ gseOverflow = upd.gseOverflow'._B
274404-- | Time zone in which dates in the result will be rendered.
275405--
276406-- Default: account time zone.
277−gseTimeZone :: Lens' (Request GetScheduleEntries s b) TimeZone
407+gseTimeZone :: Lens' (Request GetScheduleEntries s b) (Maybe TimeZone)
278408gseTimeZone = upd.gseTimeZone'.mapping _TZ
279409
280410-- | To filter the returned on-call schedule entries by a specific user, you
281411-- can optionally add the user_id parameter to the query.
282−gseUserId :: Lens' (Request GetScheduleEntries s b) (Maybe Text)
412+gseUserId :: Lens' (Request GetScheduleEntries s b) (Maybe UserId)
283413gseUserId = upd.gseUserId'
284414
285415-- | List schedule entries that are active for a given time range for a
@@ -288,33 +418,217 @@ gseUserId = upd.gseUserId'
288418-- @GET \/schedules\/\:id\/entries@
289419--
290420-- _See:_ <http://developer.pagerduty.com/documentation/rest/schedules/entries>
291−getScheduleEntries =
292− mk Get
421+getScheduleEntries :: UserId
422+ -> Date -- ^ 'gseSince'
423+ -> Date -- ^ 'gseUntil'
424+ -> Request GetScheduleEntries s b
425+getScheduleEntries i s u =
426+ mk GetScheduleEntries
427+ { _gseSince' = s
428+ , _gseUntil' = u
429+ , _gseOverflow' = F
430+ , _gseTimeZone' = Nothing
431+ , _gseUserId' = Nothing
432+ } & path .~ schedules % i
433+
434+data CreateSchedule = CreateSchedule
435+ { _csName' :: Text
436+ , _csOverflow' :: !Bool'
437+ , _csTimeZone' :: TZ
438+ , _csScheduleLayers' :: [ScheduleLayer]
439+ } deriving (Eq, Show)
440+
441+makeLenses ''CreateSchedule
442+
443+instance ToJSON CreateSchedule where
444+ toJSON cs = object
445+ [ "name" .= _csName' cs
446+ , "overflow" .= _csOverflow' cs
447+ , "schedule" .= object
448+ [ "time_zone" .= _csTimeZone' cs
449+ , "schedule_layers" .= _csScheduleLayers' cs
450+ ]
451+ ]
452+
453+instance QueryLike CreateSchedule where
454+ toQuery = const []
455+
456+-- | Any on-call schedule entries that pass the date range bounds will be
457+-- truncated at the bounds, unless 'csOverflow' is set to 'True'.
458+--
459+-- Default: 'False'.
460+csOverflow :: Lens' (Request CreateSchedule s b) Bool
461+csOverflow = upd.csOverflow'._B
462+
463+-- | The name of the schedule.
464+csName :: Lens' (Request CreateSchedule s b) Text
465+csName = upd.csName'
466+
467+-- | The time zone of the schedule.
468+--
469+-- Default: 'UTC'.
470+csTimeZone :: Lens' (Request CreateSchedule s b) TimeZone
471+csTimeZone = upd.csTimeZone'._TZ
472+
473+-- | A list of schedule layers.
474+csScheduleLayers :: Lens' (Request CreateSchedule s b) [ScheduleLayer]
475+csScheduleLayers = upd.csScheduleLayers'
293476
294477-- | Create a new on-call schedule.
295478--
296479-- @POST \/schedules@
297480--
298481-- _See:_ <http://developer.pagerduty.com/documentation/rest/schedules/create>
299−createSchedule = undefined
482+createSchedule :: Text -- ^ 'csName'
483+ -> TimeZone -- ^ 'csTimeZone'
484+ -> [ScheduleLayer] -- ^ 'csScheduleLayers'
485+ -> Request CreateSchedule s Schedule
486+createSchedule n z ls =
487+ mk CreateSchedule
488+ { _csName' = n
489+ , _csOverflow' = F
490+ , _csTimeZone' = TZ z
491+ , _csScheduleLayers' = ls
492+ } & path .~ schedules
493+
494+data UpdateSchedule = UpdateSchedule
495+ { _usOverflow' :: !Bool'
496+ , _usTimeZone' :: TZ
497+ , _usScheduleLayers' :: [ScheduleLayer]
498+ } deriving (Eq, Show)
499+
500+makeLenses ''UpdateSchedule
501+
502+instance ToJSON UpdateSchedule where
503+ toJSON us = object
504+ [ "overflow" .= _usOverflow' us
505+ , "schedule" .= object
506+ [ "time_zone" .= _usTimeZone' us
507+ , "schedule_layers" .= _usScheduleLayers' us
508+ ]
509+ ]
510+
511+instance QueryLike UpdateSchedule where
512+ toQuery = const []
513+
514+-- | Any on-call schedule entries that pass the date range bounds will be
515+-- truncated at the bounds, unless 'usOverflow' is set to 'True'.
516+--
517+-- Default: 'False'.
518+usOverflow :: Lens' (Request UpdateSchedule s b) Bool
519+usOverflow = upd.usOverflow'._B
520+
521+-- | The time zone of the schedule.
522+usTimeZone :: Lens' (Request UpdateSchedule s b) TimeZone
523+usTimeZone = upd.usTimeZone'._TZ
524+
525+-- | A list of schedule layers.
526+usScheduleLayers :: Lens' (Request UpdateSchedule s b) [ScheduleLayer]
527+usScheduleLayers = upd.usScheduleLayers'
300528
301529-- | Update an existing on-call schedule.
302530--
531+-- _Note:_ You cannot delete schedule layers. You must include all layers in
532+-- your update request. To delete a layer, set the end parameter to schedule its
533+-- termination.
534+--
303535-- @PUT \/schedules\/\:id@
304536--
305537-- _See:_ <http://developer.pagerduty.com/documentation/rest/schedules/update>
306−updateSchedule = undefined
538+updateSchedule :: ScheduleId
539+ -> TimeZone -- ^ 'usTimeZone'
540+ -> [ScheduleLayer] -- ^ 'usScheduleLayers'
541+ -> Request UpdateSchedule s Schedule
542+updateSchedule s z ls =
543+ mk UpdateSchedule
544+ { _usOverflow' = F
545+ , _usTimeZone' = TZ z
546+ , _usScheduleLayers' = ls
547+ } & path .~ schedules % s
548+
549+data PreviewSchedule = PreviewSchedule
550+ { _psSince' :: Maybe Date
551+ , _psUntil' :: Maybe Date
552+ , _psName' :: Text
553+ , _psOverflow' :: !Bool'
554+ , _psTimeZone' :: TZ
555+ , _psScheduleLayers' :: [ScheduleLayer]
556+ } deriving (Eq, Show)
557+
558+makeLenses ''PreviewSchedule
559+
560+instance ToJSON PreviewSchedule where
561+ toJSON ps = object
562+ [ "since" .= _psSince' ps
563+ , "until" .= _psUntil' ps
564+ , "name" .= _psName' ps
565+ , "overflow" .= _psOverflow' ps
566+ , "schedule" .= object
567+ [ "time_zone" .= _psTimeZone' ps
568+ , "schedule_layers" .= _psScheduleLayers' ps
569+ ]
570+ ]
307571
308−-- | Preview the configuration of an on-call schedule.
572+instance QueryLike PreviewSchedule where
573+ toQuery = const []
574+
575+-- | The start of the date range over which you want to return on-call schedule
576+-- entries and on-call schedule layers.
577+psSince :: Lens' (Request PreviewSchedule s b) (Maybe UTCTime)
578+psSince = upd.psSince'.mapping _D
579+
580+-- | The end of the date range over which you want to return schedule entries
581+-- and on-call schedule layers.
582+psUntil :: Lens' (Request PreviewSchedule s b) (Maybe UTCTime)
583+psUntil = upd.psUntil'.mapping _D
584+
585+-- | Any on-call schedule entries that pass the date range bounds will be
586+-- truncated at the bounds, unless 'psOverflow' is set to 'True'.
587+--
588+-- Default: 'False'.
589+psOverflow :: Lens' (Request PreviewSchedule s b) Bool
590+psOverflow = upd.psOverflow'._B
591+
592+-- | The name of the schedule.
593+psName :: Lens' (Request PreviewSchedule s b) Text
594+psName = upd.psName'
595+
596+-- | The time zone of the schedule.
597+--
598+-- Default: 'UTC'.
599+psTimeZone :: Lens' (Request PreviewSchedule s b) TimeZone
600+psTimeZone = upd.psTimeZone'._TZ
601+
602+-- | A list of schedule layers.
603+psScheduleLayers :: Lens' (Request PreviewSchedule s b) [ScheduleLayer]
604+psScheduleLayers = upd.psScheduleLayers'
605+
606+-- | Preview what a schedule would look like without saving it. This work the
607+-- same as the update or create actions, except that the result is not
608+-- persisted. Preview optionally takes two additional arguments, since and until,
609+-- deliminating the span of the preview.
309610--
310611-- @POST \/schedules\/preview@
311612--
312613-- _See:_ <http://developer.pagerduty.com/documentation/rest/schedules/preview>
313−previewSchedule = undefined
614+previewSchedule :: Text -- ^ 'psName'
615+ -> TimeZone -- ^ 'psTimeZone'
616+ -> [ScheduleLayer] -- ^ 'psScheduleLayers'
617+ -> Request PreviewSchedule s Schedule
618+previewSchedule n z ls =
619+ mk PreviewSchedule
620+ { _psSince' = Nothing
621+ , _psUntil' = Nothing
622+ , _psName' = n
623+ , _psOverflow' = F
624+ , _psTimeZone' = TZ z
625+ , _psScheduleLayers' = ls
626+ } & path .~ schedules % "preview"
314627
315628-- | Delete an on-call schedule.
316629--
317630-- @DELETE \/schedules\/\:id@
318631--
319632-- _See:_ <http://developer.pagerduty.com/documentation/rest/schedules/delete>
320−deleteSchedule = undefined
633+deleteSchedule :: ScheduleId -> Request Empty s Empty
634+deleteSchedule s = empty & path .~ schedules % s