diff --git a/hipbot.cabal b/hipbot.cabal --- a/hipbot.cabal +++ b/hipbot.cabal @@ -1,5 +1,5 @@ name: hipbot -version: 0.3.0.2 +version: 0.5 license: BSD3 license-file: LICENSE author: Richard Wallace @@ -32,7 +32,11 @@ hs-source-dirs: src exposed-modules: HipBot + , HipBot.AbsoluteURI , HipBot.API + , HipBot.Descriptor + , HipBot.Notification + , HipBot.Webhooks other-modules: HipBot.Internal.HipBot , HipBot.Internal.OAuth @@ -64,6 +68,7 @@ , utf8-string >=0.3.1 && <1.1 , wai >=3.0 && <4 , wai-lens >=0.1 && <1 - , webcrank-wai >=0.2 && <1 + , webcrank >=0.2.2 && <1 + , webcrank-wai >=0.2.1 && <1 , wreq >=0.2 && <1 diff --git a/src/HipBot.hs b/src/HipBot.hs --- a/src/HipBot.hs +++ b/src/HipBot.hs @@ -7,12 +7,20 @@ module HipBot ( HipBot , HipBotAPI(..) + , OnUninstall + , OAuthId + , RoomName + , RoomId + , RoomEvent(..) , newHipBot + , newHipBot' , hipBotResources , configResource , verifySignature , sendNotification - , module HipBot.Internal.Types + , module HipBot.AbsoluteURI + , module HipBot.Descriptor + , module HipBot.Notification ) where import Control.Applicative @@ -20,13 +28,11 @@ 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 qualified Data.ByteString.UTF8 as B import qualified Data.List as List import Data.Monoid -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time.Clock @@ -37,11 +43,14 @@ import Prelude import Safe +import HipBot.AbsoluteURI import HipBot.API +import HipBot.Descriptor import HipBot.Internal.HipBot import HipBot.Internal.OAuth import HipBot.Internal.Resources import HipBot.Internal.Types +import HipBot.Notification data NotificationError = NoSuchRegistration OAuthId @@ -59,15 +68,7 @@ -> m (Maybe NotificationError) sendNotification bot oid room n = let - msg = case n of - TextNotification t -> A.object - [ "message_format" .= ("text" :: Text) - , "message" .= t - ] - HtmlNotification t -> A.object - [ "message_format" .= ("html" :: Text) - , "message" .= t - ] + msg = A.encode n opts tok = wreqDefaults bot & Wreq.header hAuthorization .~ [("Bearer " <>) . T.encodeUtf8 . view accessToken $ tok] diff --git a/src/HipBot/API.hs b/src/HipBot/API.hs --- a/src/HipBot/API.hs +++ b/src/HipBot/API.hs @@ -26,6 +26,8 @@ import Prelude import Safe +import HipBot.AbsoluteURI +import HipBot.Descriptor import HipBot.Internal.Types data HipBotAPI m = HipBotAPI diff --git a/src/HipBot/AbsoluteURI.hs b/src/HipBot/AbsoluteURI.hs new file mode 100644 --- /dev/null +++ b/src/HipBot/AbsoluteURI.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module HipBot.AbsoluteURI where + +import Blaze.ByteString.Builder (toLazyByteString) +import Control.Monad +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy.UTF8 as LB +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.Typeable +import Network.HTTP.Types +import Network.URI (URI) +import qualified Network.URI as URI +import Prelude + +newtype AbsoluteURI = AbsoluteURI URI + deriving (Eq, Typeable) + +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 + diff --git a/src/HipBot/Descriptor.hs b/src/HipBot/Descriptor.hs new file mode 100644 --- /dev/null +++ b/src/HipBot/Descriptor.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module HipBot.Descriptor where + +import Control.Applicative +import Control.Lens.TH +import Data.Aeson ((.=), (.:?), (.!=)) +import qualified Data.Aeson as A +import qualified Data.Aeson.TH as A +import Data.Char +import Data.Maybe +import Data.Monoid +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock +import Prelude + +import HipBot.AbsoluteURI +import HipBot.Internal.Types + +data AddOn = AddOn + { _addOnKey :: Text + , _addOnName :: Text + , _addOnDescription :: Text + , _addOnLinks :: Links + , _addOnCapabilities :: Maybe Capabilities + , _addOnVendor :: Maybe Vendor + } deriving (Show, Eq) + +defaultAddOn + :: Text -- ^ key + -> Text -- ^ name + -> Text -- ^ description + -> Links + -> AddOn +defaultAddOn 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 + , ("webhook" .= 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) + +webhook :: AbsoluteURI -> RoomEvent -> Webhook +webhook url = Webhook url Nothing + +data Configurable = Configurable + { _configurableUrl :: AbsoluteURI + } deriving (Show, Eq) + +data Vendor = Vendor + { _vendorUrl :: AbsoluteURI + , _vendorName :: Text + } deriving (Show, Eq) + +data Registration = Registration + { _registrationOauthId :: OAuthId + , _registrationCapabilitiesUrl :: AbsoluteURI + , _registrationRoomId :: Maybe RoomId + , _registrationGroupId :: Int + , _registrationOauthSecret :: Text + } + +data AccessToken = AccessToken + { _accessTokenAccessToken :: Text + , _accessTokenExpires :: UTCTime + } + +makeFields ''AddOn +makeFields ''Links +makeFields ''Capabilities +makeFields ''Installable +makeLensesWith abbreviatedFields ''APIConsumer +makeFields ''OAuth2Provider +makeFields ''Configurable +makeFields ''Registration +makeFields ''AccessToken +makeFields ''Webhook + +$(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 !! 8) : drop 9 l + , A.omitNothingFields = True + } + ''Webhook) + +$(A.deriveJSON + A.defaultOptions + { A.fieldLabelModifier = \l -> toLower (l !! 13) : drop 14 l + , A.omitNothingFields = True + } + ''Registration) + diff --git a/src/HipBot/Internal/HipBot.hs b/src/HipBot/Internal/HipBot.hs --- a/src/HipBot/Internal/HipBot.hs +++ b/src/HipBot/Internal/HipBot.hs @@ -13,6 +13,7 @@ import Prelude import HipBot.API +import HipBot.Descriptor import HipBot.Internal.Types type OnUninstall m = OAuthId -> m () diff --git a/src/HipBot/Internal/OAuth.hs b/src/HipBot/Internal/OAuth.hs --- a/src/HipBot/Internal/OAuth.hs +++ b/src/HipBot/Internal/OAuth.hs @@ -25,9 +25,10 @@ import qualified Network.Wreq as Wreq import Prelude +import HipBot.AbsoluteURI import HipBot.API +import HipBot.Descriptor import HipBot.Internal.HipBot -import HipBot.Internal.Types data OAuthError = MissingAccessTokenUrl Registration diff --git a/src/HipBot/Internal/Resources.hs b/src/HipBot/Internal/Resources.hs --- a/src/HipBot/Internal/Resources.hs +++ b/src/HipBot/Internal/Resources.hs @@ -26,7 +26,7 @@ import HipBot.API import HipBot.Internal.HipBot import HipBot.Internal.OAuth -import HipBot.Internal.Types +import HipBot.Descriptor hipBotResources :: (Applicative m, MonadCatch m, MonadIO m) diff --git a/src/HipBot/Internal/Types.hs b/src/HipBot/Internal/Types.hs --- a/src/HipBot/Internal/Types.hs +++ b/src/HipBot/Internal/Types.hs @@ -1,202 +1,17 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# 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 Data.Typeable -import Network.HTTP.Types -import Network.URI (URI) -import qualified Network.URI as URI import Prelude -newtype AbsoluteURI = AbsoluteURI URI - deriving (Eq, Typeable) - -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) - -defaultAddOn - :: Text -- ^ key - -> Text -- ^ name - -> Text -- ^ description - -> Links - -> AddOn -defaultAddOn 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) +type OAuthId = Text +type RoomId = Int +type RoomName = Text data RoomEvent = RoomMessage @@ -222,101 +37,4 @@ "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 - deriving (Show, Typeable) - -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) diff --git a/src/HipBot/Notification.hs b/src/HipBot/Notification.hs new file mode 100644 --- /dev/null +++ b/src/HipBot/Notification.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module HipBot.Notification where + +import Control.Lens hiding ((.=)) +import Data.Aeson ((.=)) +import qualified Data.Aeson as A +import Data.Monoid +import Data.Text (Text) +import Data.Typeable +import Prelude + +data NotificationColor + = Yellow + | Green + | Red + | Purple + | Gray + | Random + deriving (Show, Eq, Typeable) + +instance A.ToJSON NotificationColor where + toJSON = \case + Yellow -> "yellow" + Green -> "green" + Red -> "red" + Purple -> "purple" + Gray -> "gray" + Random -> "random" + +data NotificationMessage + = TextNotification Text + | HtmlNotification Text + deriving (Show, Eq, Typeable) + +data Notification = Notification + { _notificationColor :: Maybe NotificationColor + , _notificationNotify :: Bool + , _notificationMessage :: NotificationMessage + } deriving (Show, Eq, Typeable) + +makeFields ''Notification + +instance A.ToJSON Notification where + toJSON n = + let + c = case n ^. color of + Just x | x /= Yellow -> [ "color" .= x ] + _ -> [] + nu = [ "notify" .= True | n ^. notify ] + m = case n ^. message of + TextNotification t -> + [ "message_format" .= ("text" :: Text) + , "message" .= t + ] + HtmlNotification t -> + [ "message_format" .= ("html" :: Text) + , "message" .= t + ] + in + A.object (c <> nu <> m) + +defaultNotification :: NotificationMessage -> Notification +defaultNotification = Notification Nothing False + +textNotification :: Text -> Notification +textNotification = defaultNotification . TextNotification + +htmlNotification :: Text -> Notification +htmlNotification = defaultNotification . HtmlNotification + diff --git a/src/HipBot/Webhooks.hs b/src/HipBot/Webhooks.hs new file mode 100644 --- /dev/null +++ b/src/HipBot/Webhooks.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module HipBot.Webhooks + ( RoomLinks(..) + , Room(..) + , MessageItem(..) + , WebhookRoomItem(..) + , WebhookRoomEvent(..) + , HasMembers(..) + , HasParticipants(..) + , HasSelf(..) + , HasWebhooks(..) + , HasRoomId(..) + , HasName(..) + , HasLinks(..) + , HasMessage(..) + , HasWebhookId(..) + , HasOauthId(..) + , HasItem(..) + , decodeWebhookRoomEvent + , webhookResource + , roomMessageWebhookResource + , simpleWebhookResource + ) where + +import Control.Applicative +import Control.Lens hiding ((.=)) +import Control.Monad.Reader +import Control.Monad.State +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as A +import qualified Data.Aeson.TH as A +import qualified Data.Aeson.Types as A +import Data.Char (toLower) +import Data.Foldable +import Data.Maybe +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Network.Wai as Wai +import Prelude hiding (foldl1) + +import Webcrank +import Webcrank.Wai + +import HipBot.AbsoluteURI +import HipBot.Internal.Types +import HipBot.Notification + +data RoomLinks = RoomLinks + { _roomLinksMembers :: Maybe AbsoluteURI + , _roomLinksParticipants :: AbsoluteURI + , _roomLinksSelf :: AbsoluteURI + , _roomLinksWebhooks :: AbsoluteURI + } deriving (Show, Eq) + +makeFields ''RoomLinks + +data Room = Room + { _roomRoomId :: RoomId + , _roomName :: RoomName + , _roomLinks :: RoomLinks + } deriving (Show, Eq) + +makeFields ''Room + +instance A.FromJSON Room where + parseJSON = A.withObject "object" $ \o -> Room + <$> o .: "id" + <*> o .: "name" + <*> o .: "links" + +data MessageItem = MessageItem + { _messageItemMessage :: Text + } deriving (Show, Eq) + +makeFields ''MessageItem + +data WebhookRoomItem + = WebhookRoomMessage Room MessageItem + -- WebhookRoomArchived + -- WebhookRoomDeleted + -- WebhookRoomEnter + -- WebhookRoomExit + -- WebhookRoomNotification + -- WebhookRoomTopicChange + -- WebhookRoomUnarchived + deriving (Show, Eq) + +data WebhookRoomEvent = WebhookRoomEvent + { _webhookRoomEventWebhookId :: Int + , _webhookRoomEventOauthId :: Maybe String + , _webhookRoomEventItem :: WebhookRoomItem + } deriving (Show, Eq) + +makeFields ''WebhookRoomEvent + +instance A.FromJSON WebhookRoomEvent where + parseJSON = A.withObject "object" $ \o -> WebhookRoomEvent + <$> o .: "webhook_id" + <*> o .:? "oauth_client_id" + <*> readItem o + +readItem :: A.Object -> A.Parser WebhookRoomItem +readItem o = do + oi <- o .: "item" + o .: "event" >>= \case + RoomMessage -> WebhookRoomMessage <$> oi .: "room" <*> oi .: "message" + _ -> A.typeMismatch "only supports room_message events at this time" (A.Object o) + +decodeWebhookRoomEvent :: (Functor m, MonadIO m, MonadReader s m, HasRequest s Wai.Request) => m (Either String WebhookRoomEvent) +decodeWebhookRoomEvent = A.eitherDecode <$> getRequestBodyLBS + +$(A.deriveFromJSON + A.defaultOptions + { A.fieldLabelModifier = \l -> toLower (l !! 10) : drop 11 l + , A.omitNothingFields = True + } + ''RoomLinks) + +$(A.deriveFromJSON + A.defaultOptions + { A.fieldLabelModifier = \l -> toLower (l !! 12) : drop 13 l + , A.omitNothingFields = True + } + ''MessageItem) + +webhookResource + :: (MonadIO m, MonadReader r m, HasRequest r Wai.Request, MonadState s m, HasReqData s) + => String -- ^ webhook name + -> (WebhookRoomEvent -> HaltT m (Maybe Notification)) -- ^ event processor + -> Resource m +webhookResource hookName f = resource + { allowedMethods = return [ methodPost ] + , postAction = postProcess $ + decodeWebhookRoomEvent >>= \case + Left e -> liftIO . putStrLn . mconcat $ + [ "[ERROR] Failed to parse event to " + , hookName + , " webhook: " + , e + ] + Right ev -> f ev >>= traverse_ (writeLBS . A.encode) + } + +roomMessageWebhookResource + :: (MonadIO m, MonadReader r m, MonadState s m, HasReqData s, HasRequest r Wai.Request) + => String + -> (Room -> MessageItem -> HaltT m (Maybe Notification)) + -> Resource m +roomMessageWebhookResource hookName f = webhookResource hookName $ \ev -> + case ev ^. item of + WebhookRoomMessage room msg -> f room msg + +-- | Creates a simple "command" processing webhook resource. +-- Commands processes are limited to pure functions that may +-- or may not produce a reply. +simpleWebhookResource + :: MonadIO m + => String -- ^ webhook name + -> [Text] -- ^ command aliases, they will be removed before calling the processing function + -> (Text -> Maybe Text) -- ^ processing function, the result will become a room notification + -> WaiResource m +simpleWebhookResource hookName aliases f = + let + expr t = T.strip <$> foldl1 (<|>) (fmap (`T.stripPrefix` t) aliases) + command = views message (return . fmap textNotification . (f =<<) . expr) + in + roomMessageWebhookResource hookName (const command) +