diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell + +import Distribution.Simple + +main = defaultMain diff --git a/hipbot.cabal b/hipbot.cabal new file mode 100644 --- /dev/null +++ b/hipbot.cabal @@ -0,0 +1,57 @@ +name: hipbot +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Richard Wallace +maintainer: Richard Wallace +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 + diff --git a/src/HipBot.hs b/src/HipBot.hs new file mode 100644 --- /dev/null +++ b/src/HipBot.hs @@ -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 + diff --git a/src/HipBot/API.hs b/src/HipBot/API.hs new file mode 100644 --- /dev/null +++ b/src/HipBot/API.hs @@ -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 + } + diff --git a/src/HipBot/Internal/HipBot.hs b/src/HipBot/Internal/HipBot.hs new file mode 100644 --- /dev/null +++ b/src/HipBot/Internal/HipBot.hs @@ -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) + diff --git a/src/HipBot/Internal/OAuth.hs b/src/HipBot/Internal/OAuth.hs new file mode 100644 --- /dev/null +++ b/src/HipBot/Internal/OAuth.hs @@ -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 + diff --git a/src/HipBot/Internal/Resources.hs b/src/HipBot/Internal/Resources.hs new file mode 100644 --- /dev/null +++ b/src/HipBot/Internal/Resources.hs @@ -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 #-} + diff --git a/src/HipBot/Internal/Types.hs b/src/HipBot/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/HipBot/Internal/Types.hs @@ -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) +