hipbot (empty) → 0.1
raw patch · 9 files changed
+836/−0 lines, 9 filesdep +aesondep +basedep +bifunctorssetup-changed
Dependencies added: aeson, base, bifunctors, blaze-builder, bytestring, either, exceptions, http-client, http-client-tls, http-types, jwt, lens, mtl, network-uri, stm, text, time, transformers, unordered-containers, utf8-string, wai, wai-lens, webcrank-wai, wreq
Files
- LICENSE +28/−0
- Setup.hs +5/−0
- hipbot.cabal +57/−0
- src/HipBot.hs +94/−0
- src/HipBot/API.hs +52/−0
- src/HipBot/Internal/HipBot.hs +35/−0
- src/HipBot/Internal/OAuth.hs +144/−0
- src/HipBot/Internal/Resources.hs +103/−0
- src/HipBot/Internal/Types.hs +318/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2015, Richard Wallace+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of hipbot nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.hs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++import Distribution.Simple++main = defaultMain
+ hipbot.cabal view
@@ -0,0 +1,57 @@+name: hipbot+version: 0.1+license: BSD3+license-file: LICENSE+author: Richard Wallace <rwallace@atlassian.com>+maintainer: Richard Wallace <rwallace@atlassian.com>+copyright: (c) 2015 Richard Wallace+synopsis: A library for building HipChat Bots+description: A library for building HipChat Bots+category: Web+homepage: https://bitbucket.org/rwallace/hipbot+bug-reports: https://bitbucket.org/rwallace/hipbot/issues+cabal-version: >= 1.8+build-type: Simple++source-repository head+ type: git+ location: https://github.com/purefn/hipbot.git++library+ ghc-options: -Wall++ hs-source-dirs: src++ exposed-modules: HipBot+ , HipBot.API++ other-modules: HipBot.Internal.HipBot+ , HipBot.Internal.OAuth+ , HipBot.Internal.Resources+ , HipBot.Internal.Types++ build-depends: base >=4.6 && <5+ , aeson >=0.7.0.3 && <1+ , bifunctors >=3.0 && <5+ , blaze-builder >=0.2.1.4 && <0.4+ , bytestring >=0.9.1.10 && <0.11+ , either >=3.1 && <5+ , exceptions >=0.1.1 && <1+ , http-client >=0.4.6 && <1+ , http-client-tls >=0.2 && <1+ , http-types >=0.8.0 && <0.9+ , jwt >=0.5 && <1+ , lens >=4.5 && <5+ , mtl >=2.0.1 && <2.3+ , network-uri >=2.4 && <3+ , stm >=2.3 && <3+ , text >=0.11 && <1.3+ , time >=1.4 && <2+ , transformers >=0.2 && <0.5+ , unordered-containers ==0.2.*+ , utf8-string >=0.3.1 && <1.1+ , wai >=3.0 && <4+ , wai-lens >=0.1 && <1+ , webcrank-wai >=0.2 && <1+ , wreq >=0.2 && <1+
+ src/HipBot.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++module HipBot+ ( HipBot+ , HipBotAPI(..)+ , newHipBot+ , hipBotResources+ , configResource+ , verifySignature+ , sendNotification+ , module HipBot.Internal.Types+ ) where++import Control.Applicative+import Control.Lens hiding ((.=))+import Control.Monad.Catch+import Control.Monad.Trans+import Control.Monad.Trans.Either+import Data.Aeson ((.=))+import qualified Data.Aeson as A+import Data.Bifunctor+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time.Clock+import Network.HTTP.Types+import qualified Network.Wreq as Wreq++import HipBot.API+import HipBot.Internal.HipBot+import HipBot.Internal.OAuth+import HipBot.Internal.Resources+import HipBot.Internal.Types++data NotificationError+ = NoSuchRegistration OAuthId+ | TokenError OAuthError++sendNotification+ :: (Applicative m, MonadCatch m, MonadIO m)+ => HipBot m+ -> OAuthId+ -> Either RoomName RoomId+ -> Notification+ -> m (Maybe NotificationError)+sendNotification bot oid room n = getToken bot oid >>= either (return . Just) send where+ -- TODO handle failures posting, right now an exception is thrown for non-2xx responses+ -- we should turn those into more specific errors, e.g. RateLimitExceeded+ send (reg, tok) = Nothing <$ liftIO (Wreq.postWith (opts tok) (notificationUrl room reg) msg)+ opts tok = wreqDefaults bot+ & Wreq.header hAuthorization .~ [("Bearer " <>) . T.encodeUtf8 . view accessToken $ tok]+ & Wreq.header hContentType .~ ["application/json"]+ msg = case n of+ TextNotification t -> A.object+ [ "message_format" .= ("text" :: Text)+ , "message" .= t+ ]+ HtmlNotification t -> A.object+ [ "message_format" .= ("html" :: Text)+ , "message" .= t+ ]++getToken+ :: (Applicative m, MonadCatch m, MonadIO m)+ => HipBot m+ -> OAuthId+ -> m (Either NotificationError (Registration, AccessToken))+getToken bot oid = runEitherT (lookupReg >>= fetch) where+ lookupReg = EitherT .+ fmap (maybe (Left . NoSuchRegistration $ oid) Right) .+ apiLookupRegistration (view hipBotAPI bot) $+ oid+ fetch (reg, tok) = do+ now <- liftIO getCurrentTime+ tok' <- if now > addUTCTime 300 (tok ^. expires)+ then right tok+ else do+ tok' <- EitherT .+ fmap (first TokenError) .+ obtainAccessToken bot $+ reg+ lift . apiUpdateAccessToken (bot ^. hipBotAPI) oid $ tok'+ return tok'+ return (reg, tok')++notificationUrl :: Either RoomName RoomId -> Registration -> String+notificationUrl room =+ show .+ relativeTo ["room", either id (T.pack . show) room, "notification"] .+ view capabilitiesUrl+
+ src/HipBot/API.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module HipBot.API where++import Control.Concurrent.STM+import Control.Lens+import Control.Monad.IO.Class+import qualified Data.HashMap.Strict as HashMap++import HipBot.Internal.Types++data HipBotAPI m = HipBotAPI+ { apiInsertRegistration :: Registration -> AccessToken -> m ()+ , apiDeleteRegistration :: OAuthId -> m ()+ , apiLookupRegistration :: OAuthId -> m (Maybe (Registration, AccessToken))+ , apiUpdateAccessToken :: OAuthId -> AccessToken -> m ()+ }++makeClassy ''HipBotAPI++stmAPI :: MonadIO m => IO (HipBotAPI m)+stmAPI = do+ regs <- newTVarIO HashMap.empty+ return HipBotAPI+ { apiInsertRegistration = \r t ->+ liftIO .+ atomically .+ modifyTVar' regs .+ HashMap.insert (r ^. oauthId) $+ (r, t)+ , apiDeleteRegistration =+ liftIO .+ atomically .+ modifyTVar' regs .+ HashMap.delete+ , apiLookupRegistration =+ liftIO .+ atomically .+ flip fmap (readTVar regs) .+ HashMap.lookup+ , apiUpdateAccessToken = \oid t ->+ liftIO .+ atomically .+ modifyTVar' regs .+ HashMap.adjust (set _2 t) $+ oid+ }+
+ src/HipBot/Internal/HipBot.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}++module HipBot.Internal.HipBot where++import Control.Applicative+import Control.Lens+import qualified Network.HTTP.Client as HTTP+import Network.HTTP.Client.TLS+import qualified Network.Wreq as Wreq++import HipBot.API+import HipBot.Internal.Types++data HipBot m = HipBot+ { botAPI :: HipBotAPI m+ , botAddOn :: AddOn+ , botManager :: HTTP.Manager+ }++makeClassy ''HipBot++instance HasHipBotAPI (HipBot m) m where+ hipBotAPI = hipBot . api where+ api f (HipBot a b c) = fmap (\ a' -> HipBot a' b c) (f a)++newHipBot :: HipBotAPI m -> AddOn -> IO (HipBot m)+newHipBot api addon = HipBot api addon <$> HTTP.newManager tlsManagerSettings++wreqDefaults :: HipBot m -> Wreq.Options+wreqDefaults bot = Wreq.defaults+ & Wreq.manager .~ Right (botManager bot)+
+ src/HipBot/Internal/OAuth.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HipBot.Internal.OAuth+ ( obtainAccessToken+ , OAuthError(..)+ , showOAuthError+ ) where++import Control.Applicative+import Control.Lens hiding ((.=))+import Control.Monad.Catch+import Control.Monad.Trans+import Control.Monad.Trans.Either+import Data.Aeson ((.=), (.:))+import qualified Data.Aeson as A+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import Data.Time.Clock+import Network.HTTP.Client (HttpException)+import Network.HTTP.Types+import qualified Network.Wreq as Wreq++import HipBot.API+import HipBot.Internal.HipBot+import HipBot.Internal.Types++data OAuthError+ = MissingAccessTokenUrl Registration+ | FetchCapabilitiesError Registration HttpException+ | ParseCapabilitiesError Registration Wreq.JSONError+ | FetchAccessTokenError Registration AbsoluteURI HttpException+ | ParseAccessTokenError Registration AbsoluteURI Wreq.JSONError+ | InvalidOAuthCreds Registration++showOAuthError :: OAuthError -> String+showOAuthError = \case+ MissingAccessTokenUrl r -> mconcat+ [ "Cannot get access token. Server capabilities at "+ , r ^. capabilitiesUrl . to show+ , " is missing /capabilities/oauth2Provider/tokenUrl."+ ]+ FetchCapabilitiesError r err -> mconcat+ [ "Cannot get access token. Failure fetching HipChat server capabilities from "+ , r ^. capabilitiesUrl . to show+ , ": "+ , show err+ ]+ ParseCapabilitiesError r err -> mconcat+ [ "Cannot get access token. Failure parsing HipChat server capabilities from "+ , r ^. capabilitiesUrl . to show+ , ": "+ , show err+ ]+ FetchAccessTokenError _ turl err -> mconcat+ [ "Cannot get access token. Failure requesting access token from "+ , show turl+ , ": "+ , show err+ ]+ ParseAccessTokenError _ turl err -> mconcat+ [ "Cannot get access token. Failure parsing access token response from "+ , show turl+ , ": "+ , show err+ ]+ InvalidOAuthCreds _ -> mconcat+ [ "Cannot get access token. Authorization failed, indicating client is not longer valid. It has been removed."+ ]++obtainAccessToken+ :: (Applicative m, MonadCatch m, MonadIO m)+ => HipBot m+ -> Registration+ -> m (Either OAuthError AccessToken)+obtainAccessToken bot reg =+ runEitherT (getTokenUrl bot reg >>= fetchAccessToken bot reg)++getTokenUrl+ :: MonadIO m+ => HipBot m+ -> Registration+ -> EitherT OAuthError m AbsoluteURI+getTokenUrl bot r = getUrl =<< fetchCapabilities bot r where+ getUrl = maybe missing right .+ (^? capabilities . _Just . oauth2Provider . _Just . tokenUrl)+ missing = left . MissingAccessTokenUrl $ r++fetchCapabilities+ :: MonadIO m+ => HipBot m+ -> Registration+ -> EitherT OAuthError m AddOn+fetchCapabilities bot reg = EitherT . liftIO . handleErr . asAddOn . fetch $ reg where+ asAddOn = fmap (^. Wreq.responseBody . to Right) . (Wreq.asJSON =<<)+ fetch = Wreq.getWith (wreqDefaults bot) . view (capabilitiesUrl . to show)+ handleErr =+ handle (return . Left . FetchCapabilitiesError reg) .+ handle (return . Left . ParseCapabilitiesError reg)++fetchAccessToken+ :: (Applicative m, MonadCatch m, MonadIO m)+ => HipBot m+ -> Registration+ -> AbsoluteURI+ -> EitherT OAuthError m AccessToken+fetchAccessToken bot reg turl = EitherT . handleErr $ fetch where+ fetch = do+ res <- liftIO $ do+ res <- Wreq.postWith opts (show turl) body+ Wreq.asJSON res+ if res ^. Wreq.responseStatus == unauthorized401+ then Left (InvalidOAuthCreds reg) <$ apiDeleteRegistration (bot ^. hipBotAPI) (reg ^. oauthId)+ else fmap Right . liftIO . resolveExpiresIn . view Wreq.responseBody $ res+ opts = wreqDefaults bot+ & Wreq.auth ?~ Wreq.basicAuth oid osecret+ oid = reg ^. oauthId . to T.encodeUtf8+ osecret = reg ^. oauthSecret . to T.encodeUtf8+ body = A.toJSON $ A.object+ [ "grant_type" .= A.String "client_credentials"+ , "scope" .= unwords (show <$> capScopes)+ ]+ capScopes = botAddOn bot ^. capabilities . folded . hipchatApiConsumer . folded . scopes+ handleErr =+ handle (return . Left . FetchAccessTokenError reg turl) .+ handle (return . Left . ParseAccessTokenError reg turl)++data HCAccessToken = HCAccessToken+ { _hcAccessToken:: Text+ , _hcExpiresIn :: Int+ }++instance A.FromJSON HCAccessToken where+ parseJSON = A.withObject "access token" $ \o -> HCAccessToken+ <$> o .: "access_token"+ <*> o .: "expires_in"++resolveExpiresIn :: HCAccessToken -> IO AccessToken+resolveExpiresIn t = resolve <$> getCurrentTime where+ resolve = AccessToken (_hcAccessToken t) . addUTCTime diff+ diff = realToFrac . _hcExpiresIn $ t+
+ src/HipBot/Internal/Resources.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++module HipBot.Internal.Resources where++import Control.Applicative+import Control.Lens hiding ((.=))+import Control.Monad+import Control.Monad.Catch+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Lazy.UTF8 as LB+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import Network.HTTP.Types+import Network.Wai (lazyRequestBody)+import Network.Wai.Lens+import qualified Web.JWT as JWT+import Webcrank.Wai++import HipBot.API+import HipBot.Internal.HipBot+import HipBot.Internal.OAuth+import HipBot.Internal.Types++hipBotResources+ :: (Applicative m, MonadCatch m, MonadIO m)+ => HipBot m+ -> Dispatcher (WaiResource m)+hipBotResources bot = mconcat+ [ root ==> resourceWithJson' (botAddOn bot)+ , "installations" ==> installationsResource bot+ , "installations" </> param ==> installationResource bot+ ]++resourceWithJson' :: (Monad m, A.ToJSON a) => a -> Resource m+resourceWithJson' = resourceWithBody "application/json" . return . A.encode++installationsResource+ :: (Applicative m, MonadCatch m, MonadIO m)+ => HipBot m+ -> WaiResource m+installationsResource bot = resource+ { allowedMethods = return [methodPost]+ , postAction = postProcess $ do+ req <- view request+ body <- liftIO $ lazyRequestBody req+ reg <-decodeRegistration body+ tok <- lift . lift . obtainAccessToken bot $ reg+ either+ (werrorWith badGateway502 . LB.fromString . showOAuthError)+ (lift . lift . apiInsertRegistration (bot ^. hipBotAPI) reg)+ tok+ }++decodeRegistration :: Monad m => LB.ByteString -> HaltT (WaiCrankT m) Registration+decodeRegistration = either err return . A.eitherDecode where+ err = werrorWith badRequest400 . LB.fromString++installationResource+ :: MonadIO m+ => HipBot m+ -> Text+ -> WaiResource m+installationResource bot oid = resource+ { allowedMethods = return [methodDelete]+ , deleteResource = (True <$) . lift . lift . apiDeleteRegistration (bot ^. hipBotAPI) $ oid+ }++configResource+ :: (Applicative m, Monad m)+ => HipBot m+ -> (Registration -> WaiCrankT m Body)+ -> WaiResource m+configResource bot body = resource+ { contentTypesProvided = return+ [("text/html", verifySignature bot >>= lift . body)]+ }++verifySignature+ :: (Applicative m, Monad m)+ => HipBot m+ -> HaltT (WaiCrankT m) Registration+verifySignature bot = lift (runMaybeT verify) >>= handleErr where+ verify = do+ jwt <- decode =<< signature+ (reg, _) <- lookupReg =<< oid jwt+ reg <$ hoistMaybe (JWT.verify (JWT.secret (reg ^. oauthSecret)) jwt)+ signature = MaybeT sig where+ sig = join <$> preview (request . queryString . value "signed_request")+ decode = hoistMaybe . JWT.decode . T.decodeUtf8+ oid = hoistMaybe . fmap JWT.stringOrURIToText . JWT.iss . JWT.claims+ lookupReg = MaybeT . lift . apiLookupRegistration (view hipBotAPI bot)+ handleErr = maybe (halt notFound404) return++hoistMaybe :: Monad m => Maybe a -> MaybeT m a+hoistMaybe = MaybeT . return+{-# INLINE hoistMaybe #-}+
+ src/HipBot/Internal/Types.hs view
@@ -0,0 +1,318 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module HipBot.Internal.Types where++import Blaze.ByteString.Builder (toLazyByteString)+import Control.Applicative+import Control.Lens.TH+import Control.Monad+import Data.Aeson ((.=), (.:?), (.!=))+import qualified Data.Aeson as A+import qualified Data.Aeson.TH as A+import qualified Data.ByteString.Lazy.UTF8 as LB+import Data.Char+import Data.List (isSuffixOf)+import Data.Maybe+import Data.Monoid+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time.Clock+import Network.HTTP.Types+import Network.URI (URI)+import qualified Network.URI as URI++newtype AbsoluteURI = AbsoluteURI URI+ deriving Eq++parseAbsoluteURI :: String -> Maybe AbsoluteURI+parseAbsoluteURI = fmap AbsoluteURI . URI.parseAbsoluteURI++appendPath :: AbsoluteURI -> [Text] -> AbsoluteURI+appendPath (AbsoluteURI uri) xs = AbsoluteURI uri' where+ uri' = uri { URI.uriPath = URI.uriPath uri <> dropSlash (relPath xs) }+ dropSlash s = if "/" `isSuffixOf` URI.uriPath uri+ then tail s+ else s++relPath :: [Text] -> String+relPath = LB.toString . toLazyByteString . encodePathSegments++relativeTo :: [Text] -> AbsoluteURI -> AbsoluteURI+relativeTo xs (AbsoluteURI uri) = AbsoluteURI (URI.relativeTo rel uri) where+ rel = fromJust . URI.parseURIReference . drop 1 . relPath $ xs++instance Show AbsoluteURI where+ show (AbsoluteURI u) = show u++instance IsString AbsoluteURI where+ fromString s =+ fromMaybe (error $ "Not an absolute URI: " ++ s) (parseAbsoluteURI s)++instance A.ToJSON AbsoluteURI where+ toJSON = A.toJSON . show++instance A.FromJSON AbsoluteURI where+ parseJSON = A.withText "String" $ \t ->+ maybe mzero return . parseAbsoluteURI . T.unpack $ t++data AddOn = AddOn+ { _addOnKey :: Text+ , _addOnName :: Text+ , _addOnDescription :: Text+ , _addOnLinks :: Links+ , _addOnCapabilities :: Maybe Capabilities+ , _addOnVendor :: Maybe Vendor+ } deriving (Show, Eq)++addOn+ :: Text -- ^ key+ -> Text -- ^ name+ -> Text -- ^ description+ -> Links+ -> AddOn+addOn k n d ls = AddOn k n d ls Nothing Nothing++data Links = Links+ { _linksSelf :: AbsoluteURI+ , _linksHomepage :: Maybe AbsoluteURI+ } deriving (Show, Eq)++defaultLinks+ :: AbsoluteURI -- ^ self+ -> Links+defaultLinks s = Links s Nothing++data Capabilities = Capabilities+ { _capabilitiesInstallable :: Maybe Installable+ , _capabilitiesHipchatApiConsumer :: Maybe APIConsumer+ , _capabilitiesOauth2Provider :: Maybe OAuth2Provider+ , _capabilitiesWebhooks :: [Webhook]+ , _capabilitiesConfigurable :: Maybe Configurable+ } deriving (Show, Eq)++defaultCapabilities :: Capabilities+defaultCapabilities = Capabilities Nothing Nothing Nothing [] Nothing++instance A.ToJSON Capabilities where+ toJSON (Capabilities is con o hs cfg) = A.object $ catMaybes+ [ ("installable" .=) <$> is+ , ("hipchatApiConsumer" .=) <$> con+ , ("oauth2Provider" .=) <$> o+ , ("webhooks" .= hs) <$ listToMaybe hs+ , ("configurable" .=) <$> cfg+ ]++instance A.FromJSON Capabilities where+ parseJSON = A.withObject "object" $ \o -> Capabilities+ <$> o .:? "installable"+ <*> o .:? "hipchatApiConsumer"+ <*> o .:? "oauth2Provider"+ <*> o .:? "webhooks" .!= []+ <*> o .:? "configurable"++data Installable = Installable+ { _installableCallbackUrl :: Maybe AbsoluteURI+ , _installableAllowRoom :: Bool+ , _installableAllowGlobal :: Bool+ } deriving (Show, Eq)++instance A.ToJSON Installable where+ toJSON (Installable cb r g) = A.object $ catMaybes+ [ ("callbackUrl" .=) <$> cb+ ] <>+ [ "allowRoom" .= r+ , "allowGlobal" .= g+ ]++instance A.FromJSON Installable where+ parseJSON = A.withObject "object" $ \o -> Installable+ <$> o .:? "callbackUrl"+ <*> o .:? "allowRoom" .!= True+ <*> o .:? "allowGlobal" .!= True++defaultInstallable :: Installable+defaultInstallable = Installable Nothing True True++data APIConsumer = APIConsumer+ { _apiScopes :: [APIScope]+ , _apiFromName :: Maybe Text+ } deriving (Show, Eq)++defaultAPIConsumer :: APIConsumer+defaultAPIConsumer = APIConsumer [SendNotification] Nothing++data OAuth2Provider = OAuth2Provider+ { _oAuth2ProviderAuthorizationUrl :: AbsoluteURI+ , _oAuth2ProviderTokenUrl :: AbsoluteURI+ } deriving (Show, Eq)++data APIScope+ = AdminGroup+ | AdminRoom+ | ManageRooms+ | SendMessage+ | SendNotification+ | ViewGroup+ | ViewMessages+ deriving Eq++instance Show APIScope where+ show = apiScopeStr++instance A.ToJSON APIScope where+ toJSON = A.String . apiScopeStr++apiScopeStr :: IsString a => APIScope -> a+apiScopeStr = \case+ AdminGroup -> "admin_group"+ AdminRoom -> "admin_room"+ ManageRooms -> "manage_rooms"+ SendMessage -> "send_message"+ SendNotification -> "send_notification"+ ViewGroup -> "view_group"+ ViewMessages -> "view_messages"++instance A.FromJSON APIScope where+ parseJSON = A.withText "string" $ \case+ "admin_group" -> return AdminGroup+ "admin_room" -> return AdminRoom+ "manage_rooms" -> return ManageRooms+ "send_message" -> return SendMessage+ "send_notification" -> return SendNotification+ "view_group" -> return ViewGroup+ "view_messages" -> return ViewMessages+ s -> fail $ "unexpected API scope " ++ T.unpack s++data Webhook = Webhook+ { _webhookUrl :: AbsoluteURI+ , _webhookPattern :: Maybe Text+ , _webhookEvent :: RoomEvent+ } deriving (Show, Eq)++data RoomEvent+ = RoomMessage+ | RoomNotification+ | RoomExit+ | RoomEnter+ | RoomTopicChange+ deriving (Show, Eq)++instance A.ToJSON RoomEvent where+ toJSON s = A.String $ case s of+ RoomMessage -> "room_message"+ RoomNotification -> "room_notification"+ RoomExit -> "room_exit"+ RoomEnter -> "room_enter"+ RoomTopicChange -> "room_topic_change"++instance A.FromJSON RoomEvent where+ parseJSON = A.withText "string" $ \case+ "room_message" -> return RoomMessage+ "room_notification" -> return RoomNotification+ "room_exit" -> return RoomExit+ "room_enter" -> return RoomEnter+ "room_topic_change" -> return RoomTopicChange+ s -> fail $ "unexpected room event" ++ T.unpack s++data Configurable = Configurable+ { _configurableUrl :: AbsoluteURI+ } deriving (Show, Eq)++data Vendor = Vendor+ { _vendorUrl :: AbsoluteURI+ , _vendorName :: Text+ } deriving (Show, Eq)++type OAuthId = Text+type RoomId = Int+type RoomName = Text++data Registration = Registration+ { _registrationOauthId :: OAuthId+ , _registrationCapabilitiesUrl :: AbsoluteURI+ , _registrationRoomId :: Maybe RoomId+ , _registrationGroupId :: Int+ , _registrationOauthSecret :: Text+ }++data AccessToken = AccessToken+ { _accessTokenAccessToken :: Text+ , _accessTokenExpires :: UTCTime+ }++data Notification+ = TextNotification Text+ | HtmlNotification Text++makeFields ''AddOn+makeFields ''Links+makeFields ''Capabilities+makeFields ''Installable+makeLensesWith abbreviatedFields ''APIConsumer+makeFields ''OAuth2Provider+makeFields ''Configurable+makeFields ''Registration+makeFields ''AccessToken++$(A.deriveJSON+ A.defaultOptions+ { A.fieldLabelModifier = \l -> toLower (l !! 13) : drop 14 l+ , A.omitNothingFields = True+ }+ ''Configurable)++$(A.deriveJSON+ A.defaultOptions+ { A.fieldLabelModifier = \l -> toLower (l !! 4) : drop 5 l+ , A.omitNothingFields = True+ }+ ''APIConsumer)++$(A.deriveJSON+ A.defaultOptions+ { A.fieldLabelModifier = \l -> toLower (l !! 15) : drop 16 l+ , A.omitNothingFields = True+ }+ ''OAuth2Provider)++$(A.deriveJSON+ A.defaultOptions+ { A.fieldLabelModifier = \l -> toLower (l !! 6) : drop 7 l+ , A.omitNothingFields = True+ }+ ''AddOn)++$(A.deriveJSON+ A.defaultOptions+ { A.fieldLabelModifier = \l -> toLower (l !! 6) : drop 7 l+ , A.omitNothingFields = True+ }+ ''Links)++$(A.deriveJSON+ A.defaultOptions+ { A.fieldLabelModifier = \l -> toLower (l !! 7) : drop 8 l+ , A.omitNothingFields = True+ }+ ''Vendor)++$(A.deriveJSON+ A.defaultOptions+ { A.fieldLabelModifier = \l -> toLower (l !! 7) : drop 8 l+ , A.omitNothingFields = True+ }+ ''Webhook)++$(A.deriveJSON+ A.defaultOptions+ { A.fieldLabelModifier = \l -> toLower (l !! 13) : drop 14 l+ , A.omitNothingFields = True+ }+ ''Registration)+