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
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
-> (WebhookRoomEvent -> HaltT m (Maybe Notification))
-> 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
simpleWebhookResource
:: MonadIO m
=> String
-> [Text]
-> (Text -> Maybe Text)
-> 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)