@@ -1,497 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE KindSignatures #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PatternSynonyms #-}
11−{-# LANGUAGE RankNTypes #-}
12−{-# LANGUAGE StandaloneDeriving #-}
13−{-# LANGUAGE TemplateHaskell #-}
14−{-# LANGUAGE TupleSections #-}
15−{-# LANGUAGE ViewPatterns #-}
16−
17−-- Module : Network.PagerDuty.Internal.Types
18−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
19−-- License : This Source Code Form is subject to the terms of
20−-- the Mozilla Public License, v. 2.0.
21−-- A copy of the MPL can be found in the LICENSE file or
22−-- you can obtain it at http://mozilla.org/MPL/2.0/.
23−-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
24−-- Stability : experimental
25−-- Portability : non-portable (GHC extensions)
26−
27−module Network.PagerDuty.Internal.Types where
28−
29−import Control.Applicative
30−import Control.Lens hiding ((.=), Empty)
31−import Control.Monad.IO.Class
32−import Data.Aeson hiding (Error, Key)
33−import qualified Data.Aeson.KeyMap as Map
34−import Data.Aeson.Types (Parser)
35−import Data.ByteString (ByteString)
36−import qualified Data.ByteString.Char8 as BS
37−import Data.ByteString.Conversion hiding (List)
38−import Data.Default.Class
39−import Data.Function (on)
40−import Data.List (deleteBy, intersperse)
41−import Data.Monoid
42−import Data.String
43−import Data.Text (Text)
44−import qualified Data.Text as Text
45−import qualified Data.Text.Encoding as Text
46−import Data.Time (UTCTime, TimeZone, formatTime, utc, timeZoneName)
47−import GHC.TypeLits
48−import Network.HTTP.Client (Manager)
49−import Network.HTTP.Types
50−import Network.HTTP.Types.QueryLike
51−import Network.PagerDuty.Internal.Query
52−import Network.PagerDuty.Internal.TH
53−import Data.Time.Locale.Compat
54−
55−newtype CSV a = CSV [a]
56− deriving (Eq, Show, Semigroup, Monoid)
57−
58−makePrisms ''CSV
59−
60−instance ToByteString a => QueryValues (CSV a)
61−
62−instance ToByteString a => ToByteString (CSV a) where
63− builder (CSV xs) = mconcat . intersperse "," $ map builder xs
64−
65−instance FromJSON a => FromJSON (CSV a) where
66− parseJSON = withText "comma_separated_value" $
67− fmap CSV . traverse (parseJSON . String) . Text.split (== ',')
68−
69−instance ToByteString a => ToJSON (CSV a) where
70− toJSON = String . Text.decodeUtf8 . toByteString'
71−
72−newtype List a = L [a]
73− deriving (Eq, Show, Semigroup, Monoid)
74−
75−deriveJSON ''List
76−makePrisms ''List
77−
78−instance QueryValues a => QueryValues (List a) where
79− queryValues (L xs) = concatMap queryValues xs
80−
81−newtype Bool' = B Bool
82− deriving (Eq, Show)
83−
84−deriveJSON ''Bool'
85−makePrisms ''Bool'
86−
87−instance ToByteString Bool' where
88− builder (B True) = "true"
89− builder (B False) = "false"
90−
91−instance QueryValues Bool'
92−
93−pattern T = B True
94−pattern F = B False
95−
96−newtype Date = D UTCTime
97− deriving (Eq, Ord, Show)
98−
99−makePrisms ''Date
100−
101−instance FromJSON Date where
102− parseJSON = fmap D . parseJSON
103−
104−instance ToJSON Date where
105− toJSON (D d) = toJSON d
106−
107−instance ToByteString Date where
108− builder (D d) = builder
109− (formatTime defaultTimeLocale ("%Y-%m-%dT%XZ") d)
110−
111−instance QueryValues Date
112−
113−newtype TZ = TZ TimeZone
114− deriving (Eq, Show)
115−
116−makePrisms ''TZ
117−
118−instance FromJSON TZ where
119− parseJSON = undefined
120−
121−instance ToJSON TZ where
122− toJSON = toJSON . Text.decodeUtf8 . toByteString'
123−
124−instance ToByteString TZ where
125− builder (TZ tz) = builder (timeZoneName tz)
126−
127−instance QueryValues TZ
128−
129−instance Default TZ where
130− def = TZ utc
131−
132−data Security = Basic | Token
133− deriving (Eq, Show)
134−
135−data Auth (a :: Security) where
136− AuthBasic :: ByteString -> ByteString -> Auth 'Basic
137− AuthToken :: ByteString -> Auth 'Token
138−
139−deriving instance Eq (Auth a)
140−deriving instance Show (Auth a)
141−
142−newtype SubDomain = SubDomain { subDomain :: ByteString }
143− deriving (Eq, Show, IsString, ToByteString)
144−
145−mkSubDomain :: ByteString -> SubDomain
146−mkSubDomain = SubDomain
147−
148−domain :: SubDomain -> ByteString
149−domain (SubDomain s)
150− | base `BS.isSuffixOf` s = s
151− | otherwise = s <> base
152− where
153− base = ".pagerduty.com"
154−
155−-- | The log level and associated logger function.
156−data Logger
157− = None
158− | Debug (Text -> IO ())
159−
160−-- | Log a message using the debug logger, or if none is specified noop.
161−debug :: MonadIO m => Logger -> Text -> m ()
162−debug None = const (return ())
163−debug (Debug f) = liftIO . f
164−
165−-- | The environment containing the parameters required to
166−-- make PagerDuty requests.
167−data Env (s :: Security) = Env
168− { _envDomain :: SubDomain
169− , _envAuth' :: Auth s
170− , _envManager :: Manager
171− , _envLogger :: Logger
172− }
173−
174−makeLenses ''Env
175−
176−envAuth :: forall s s'. Lens (Env s) (Env s') (Auth s) (Auth s')
177−envAuth = lens _envAuth' (\s x -> s { _envAuth' = x })
178−
179−prod :: SubDomain -> Auth s -> Manager -> Env s
180−prod d a m = Env d a m None
181−
182−newtype Code = Code Integer
183− deriving (Eq, Show, Num)
184−
185−deriveJSON ''Code
186−
187−description :: Code -> Text
188−description (Code c) =
189− case c of
190− 2000 -> "Internal Error"
191− 2001 -> "Invalid Input Provided"
192− 2002 -> "Arguments Caused Error"
193− 2003 -> "Missing Arguments"
194− 2004 -> "Invalid 'since' or 'until' Parameter Values"
195− 2005 -> "Invalid Query Date Range"
196− 2006 -> "Authentication Failed"
197− 2007 -> "Account Not Found"
198− 2008 -> "Account Locked"
199− 2009 -> "Only HTTPS Allowed For This Call"
200− 2010 -> "Access Denied"
201− 2011 -> "The action requires a 'requester_id' to be specified"
202− 2012 -> "Your account is expired and cannot use the API"
203− _ -> "Unrecognised error code"
204−
205−class HasMessage s a | s -> a where
206− -- | A short human-readable message describing the error.
207− message :: Lens' s a
208−
209−class HasErrors s a | s -> a where
210− -- | A list of human-readable reasons for the error. These values,
211− -- and even their format, are subject to change.
212− errors :: Lens' s a
213−
214−data IntegrationError = IntegrationError
215− { _ieStatus :: Text
216− , _ieMessage :: Text
217− , _ieErrors :: [Text]
218− } deriving (Eq, Show)
219−
220−deriveRecord ''IntegrationError
221−
222−instance HasMessage IntegrationError Text where message = ieMessage
223−instance HasErrors IntegrationError [Text] where errors = ieErrors
224−
225−status :: Lens' IntegrationError Text
226−status = ieStatus
227−
228−data RESTError = RESTError
229− { _reCode :: Code
230− , _reMessage :: Text
231− , _reErrors :: [Text]
232− } deriving (Eq, Show)
233−
234−deriveRecord ''RESTError
235−
236−instance HasMessage RESTError Text where message = reMessage
237−instance HasErrors RESTError [Text] where errors = reErrors
238−
239−-- | In the case of an error, the PagerDuty error code can give further details
240−-- on the nature of the error.
241−--
242−-- /See:/ 'description'
243−code :: Lens' RESTError Code
244−code = reCode
245−
246−data Error
247− = Internal Text
248− | Integration IntegrationError
249− | REST RESTError
250− deriving (Eq, Show)
251−
252−instance FromJSON Error where
253− parseJSON o = (REST <$> parseJSON o)
254− <|> (Integration <$> parseJSON o)
255−
256−makePrisms ''Error
257−
258−instance HasMessage Error Text where
259− message = lens f g
260− where
261− f (Internal x) = x
262− f (Integration s) = _ieMessage s
263− f (REST s) = _reMessage s
264−
265− g (Internal _) x = Internal x
266− g (Integration s) x = Integration $ s { _ieMessage = x }
267− g (REST s) x = REST $ s { _reMessage = x }
268−
269−data Pager = Pager
270− { _pgOffset :: !Int
271− -- ^ The offset used in the execution of the query.
272− , _pgLimit :: !Int
273− -- ^ The limit used in the execution of the query.
274− , _pgTotal :: !Int
275− -- ^ The total number of records available.
276− , _pgQuery :: Maybe Text
277− -- ^ An optional query= value to be added to the query string.
278− } deriving (Eq, Show)
279−
280−makeLenses ''Pager
281−
282−data Page a = Page
283− { _pgItem :: a
284− , _pgPager :: Maybe Pager
285− }
286−
287−instance FromJSON a => FromJSON (Page a) where
288− parseJSON = withObject "paginated" $ \o -> Page
289− <$> parseJSON (Object o)
290− <*> optional (parse o)
291− where
292− parse o = Pager
293− -- The offset of the first record returned.
294− -- Default is 0.
295− <$> o .: "offset" .!= 0
296− -- The number of records returned.
297− -- Default (and max limit) is 100 for most APIs.
298− <*> o .: "limit" .!= 100
299− <*> o .: "total"
300− <*> o .:? "query"
301−
302−instance ToJSON Pager where
303− toJSON p = object
304− [ "offset" .= _pgOffset p
305− , "limit" .= _pgLimit p
306− ]
307−
308−-- | A path segment.
309−data Path where
310− Path :: Path
311− Seg :: ToByteString a => a -> Path
312−
313−instance Semigroup Path where
314− x <> Path = x
315− Path <> y = y
316− Seg x <> Seg y = Seg (builder x <> "/" <> builder y)
317−
318−instance Monoid Path where
319− mempty = Path
320−
321−instance IsString Path where
322− fromString = Seg
323−
324−instance ToByteString Path where
325− builder Path = mempty
326− builder (Seg x) = builder x
327−
328−(%) :: ToByteString a => Path -> a -> Path
329−a % b = a <> Seg b
330−
331−renderPath :: Path -> ByteString
332−renderPath = toByteString' . mappend v1
333− where
334− v1 :: Path
335− v1 = "/api/v1"
336−
337−data Request a (s :: Security) b where
338− Request :: (QueryLike a, ToJSON a)
339− => { _rqMeth :: !StdMethod
340− , _rqPath :: Path
341− , _rqQuery :: Query
342− , _rqBody :: a
343− , _rqPager :: Maybe Pager
344− , _rqUnwrap :: Value -> Parser Value
345− }
346− -> Request a s b
347−
348−instance ToJSON (Request a s b) where
349− -- Manually unwrapped to ensure GADT constraint holds.
350− toJSON (Request _ _ _ b p _) = Object $
351− let Object x = toJSON b
352− in case toJSON p of
353− (Object y) -> x <> y
354− _ -> x
355−
356−type Unwrap = Getting (First Value) Value Value
357−
358−-- | Create a defaulted request from the payload type.
359−mk :: (QueryLike a, ToJSON a) => a -> Request a s b
360−mk x = Request GET mempty mempty x Nothing pure
361−
362−empty :: Request Empty s r
363−empty = mk Empty
364−
365−-- | Lens into the body of a request.
366−upd :: (QueryLike a, ToJSON a) => Lens' (Request a s b) a
367−upd = lens _rqBody (\(Request m p q _ g u) x -> Request m p q x g u)
368−
369−-- | Drop the security constraint.
370−auth :: Request a s b -> Request a t b
371−auth (Request x m p q g u) = Request x m p q g u
372−
373−meth :: Lens' (Request a s b) StdMethod
374−meth = lens _rqMeth (\r x -> r { _rqMeth = x })
375−
376−path :: Lens' (Request a s b) Path
377−path = lens _rqPath (\r x -> r { _rqPath = x })
378−
379−query :: QueryValueLike v
380− => Lens (Request a s b) (Request a s b) Query [(ByteString, v)]
381−query = lens _rqQuery (\r x -> r { _rqQuery = toQuery x })
382−
383−pager :: Lens' (Request a s b) (Maybe Pager)
384−pager = lens _rqPager (\r x -> r { _rqPager = x })
385−
386−unwrap :: Setter (Request a s b) (Request a s b) (Value -> Parser Value) Unwrap
387−unwrap f r = f (_rqUnwrap r) <&> \k -> r { _rqUnwrap = g k }
388− where
389− g k x = maybe (fail "Failed to extract nested keys.") return (x ^? k)
390−
391−-- | Exists primarily to obtain a constraint for the 'paginate' function.
392−class Paginate a where
393− next :: Request a s b -> Maybe Pager -> Maybe (Request a s b)
394− next rq = maybe Nothing go
395− where
396− go x | x ^. pgTotal == 0 = Nothing
397− | otherwise = Just $
398− rq & pager ?~ (x & pgOffset +~ x ^. pgTotal)
399− & query %~ (add . clear)
400− where
401− add :: Query -> Query
402− add = maybe id ((:) . (k,) . Just . Text.encodeUtf8) (x ^. pgQuery)
403−
404− clear :: Query -> Query
405− clear = deleteBy ((==) `on` fst) (k, Nothing)
406−
407− k :: ByteString
408− k = "query"
409−
410−newtype Key (a :: Symbol) = Key Text
411− deriving (Eq, Show, IsString)
412−
413−mkKey :: Text -> Key a
414−mkKey = Key
415−
416−instance FromJSON (Key a) where
417− parseJSON = withText "key" (return . Key)
418−
419−instance ToJSON (Key a) where
420− toJSON (Key k) = toJSON k
421−
422−instance ToByteString (Key a) where
423− builder (Key k) = builder k
424−
425−instance QueryValues (Key a)
426−
427−instance QueryValueLike (Key a) where
428− toQueryValue = Just . toByteString'
429−
430−type ServiceKey = Key "service"
431−type IncidentKey = Key "incident"
432−
433−newtype Id (a :: Symbol) = Id Text
434− deriving (Eq, Show, IsString)
435−
436−mkId :: Text -> Id a
437−mkId = Id
438−
439−instance FromJSON (Id a) where
440− parseJSON = withText "id" (return . Id)
441−
442−instance ToJSON (Id a) where
443− toJSON (Id i) = toJSON i
444−
445−instance ToByteString (Id a) where
446− builder (Id i) = builder i
447−
448−instance QueryValues (Id a)
449−
450−instance QueryValueLike (Id a) where
451− toQueryValue = Just . toByteString'
452−
453−type AlertId = Id "alert"
454−type ContactId = Id "contact"
455−type EmailFilterId = Id "email-filter"
456−type EscalationPolicyId = Id "escalation-policy"
457−type EscalationRuleId = Id "escalation-rule"
458−type IncidentId = Id "incident"
459−type LogEntryId = Id "log-entry"
460−type NoteId = Id "note"
461−type NotificationRuleId = Id "notification-rule"
462−type OverrideId = Id "schedule-override"
463−type RequesterId = Id "requester"
464−type ScheduleId = Id "schedule"
465−type ServiceId = Id "service"
466−type UserId = Id "user"
467−type VendorId = Id "vendor"
468−type WebhookId = Id "webhook"
469−type WindowId = Id "maintenance-window"
470−
471−data Empty = Empty
472−
473−instance ToJSON Empty where
474− toJSON = const (object [])
475−
476−instance FromJSON Empty where
477− parseJSON = withObject "empty" f
478− where
479− f !o | Map.null o = pure Empty
480− | otherwise = fail "Unexpected non-empty JSON object."
481−
482−instance QueryLike Empty where
483− toQuery = const []
484−
485−newtype Address = Address Text
486− deriving (Eq, Show, IsString)
487−
488−mkAddress :: Text -> Address
489−mkAddress = Address
490−
491−deriveJSON ''Address
492−makePrisms ''Address
493−
494−instance ToByteString Address where
495− builder (Address a) = builder a
496−
497−instance QueryValues Address