@@ -0,0 +1,497 @@
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