diff --git a/example/CounterBot.hs b/example/CounterBot.hs new file mode 100644 --- /dev/null +++ b/example/CounterBot.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell, CPP #-} +module Main where + +import qualified Data.Text as T (pack) + +import Web.Slack +import Web.Slack.Message + +import System.Environment (lookupEnv) +import Data.Maybe (fromMaybe) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Control.Lens + +myConfig :: String -> SlackConfig +myConfig apiToken = SlackConfig + { _slackApiToken = apiToken + } + +data CounterState = CounterState + { _messageCount :: Int + } + +makeLenses ''CounterState + +-- Count how many messages the bot recieves +counterBot :: SlackBot CounterState +counterBot (Message cid _ _ _ _ _) = do + num <- userState . messageCount <%= (+1) + sendMessage cid (T.pack . show $ num) +counterBot _ = return () + +main :: IO () +main = do + apiToken <- fromMaybe (error "SLACK_API_TOKEN not set") + <$> lookupEnv "SLACK_API_TOKEN" + runBot (myConfig apiToken) counterBot startState + where + startState = CounterState 0 diff --git a/example/EchoBot.hs b/example/EchoBot.hs new file mode 100644 --- /dev/null +++ b/example/EchoBot.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE CPP #-} + +module Main where + +import Web.Slack +import Web.Slack.Message +import System.Environment (lookupEnv) +import Data.Maybe (fromMaybe) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +myConfig :: String -> SlackConfig +myConfig apiToken = SlackConfig + { _slackApiToken = apiToken -- Specify your API token here + } + +echoBot :: SlackBot () +echoBot (Message cid _ msg _ _ _) = sendMessage cid msg +echoBot _ = return () + +main :: IO () +main = do + apiToken <- fromMaybe (error "SLACK_API_TOKEN not set") + <$> lookupEnv "SLACK_API_TOKEN" + runBot (myConfig apiToken) echoBot () + + + diff --git a/slack-api.cabal b/slack-api.cabal --- a/slack-api.cabal +++ b/slack-api.cabal @@ -1,5 +1,5 @@ Name: slack-api -Version: 0.9 +Version: 0.10 Synopsis: Bindings to the Slack RTM API. Description: This library provides bindings to the . Users should find it easy to program their own Slack bots using the functionality found in `Web.Slack`. @@ -20,73 +20,88 @@ Stability: Experimental Category: Web Build-type: Simple -Cabal-version: >=1.8 +Cabal-version: >=1.10 source-repository head type: git location: https://github.com/mpickering/slack-api.git - -Library +library + default-language: Haskell2010 hs-source-dirs: src ghc-options: -Wall -fno-warn-unused-do-bind - Exposed-Modules: Web.Slack, - Web.Slack.Message, - Web.Slack.State, - Web.Slack.Types, - Web.Slack.Config - Web.Slack.Types.Bot, - Web.Slack.Types.Comment, - Web.Slack.Types.File, - Web.Slack.Types.IM, - Web.Slack.Types.Topic, - Web.Slack.Types.Channel, - Web.Slack.Types.Event, - Web.Slack.Types.Event.Subtype, - Web.Slack.Types.Item, - Web.Slack.Types.User, - Web.Slack.Types.ChannelOpt, - Web.Slack.Types.Id, - Web.Slack.Types.Time, - Web.Slack.Types.Error, - Web.Slack.Types.Preferences, - Web.Slack.Types.TeamPreferences, - Web.Slack.Types.Team, - Web.Slack.Types.Session, - Web.Slack.Types.Self, - Web.Slack.Types.Presence, - Web.Slack.Types.Base - + exposed-modules: + Web.Slack + , Web.Slack.Message + , Web.Slack.State + , Web.Slack.Types + , Web.Slack.Types.Base + , Web.Slack.Types.Bot + , Web.Slack.Types.Channel + , Web.Slack.Types.ChannelOpt + , Web.Slack.Types.Comment + , Web.Slack.Types.Error + , Web.Slack.Types.Event + , Web.Slack.Types.Event.Subtype + , Web.Slack.Types.File + , Web.Slack.Types.IM + , Web.Slack.Types.Id + , Web.Slack.Types.Item + , Web.Slack.Types.Message + , Web.Slack.Types.Preferences + , Web.Slack.Types.Presence + , Web.Slack.Types.Self + , Web.Slack.Types.Session + , Web.Slack.Types.Team + , Web.Slack.Types.TeamPreferences + , Web.Slack.Types.Time + , Web.Slack.Types.Topic + , Web.Slack.Types.User + , Web.Slack.WebAPI other-modules: Web.Slack.Utils - Build-depends: - -- corePackages (see [cabal2nix/src/Cabal2Nix/CorePackages.hs]) - base >= 4.4 && < 5, - bytestring >= 0.9.1 && < 0.11, - containers >= 0.4, + build-depends: + -- corePackages (see [cabal2nix/src/Cabal2Nix/CorePackages.hs]) + base >= 4.4 && < 5 + , bytestring >= 0.9.1 && < 0.11 + , containers >= 0.4 + -- Normal Packages + , aeson >= 0.8 + , errors >= 1.4 && < 3.0 + , hashable >= 1.2 + , io-streams >= 1.2 + , lens >= 4.8 + , lens-aeson >= 1.0 + , monad-loops >= 0.4 + , mtl >= 2.1 + , network >= 2.6 + , network-uri >= 2.6 + , text >= 1.2 + , time >= 1.4 + , time-locale-compat >= 0.1 && < 0.2 + , tls >= 1.3 + , transformers >= 0.3 + , websockets > 0.9 + , wreq >= 0.2 + , wuss >= 1.0 +test-suite tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: tests-main.hs + ghc-options: -threaded -Wall + hs-source-dirs: tests . + build-depends: slack-api, base + other-modules: Tests.ConnectionTest - -- Normal Packages - websockets > 0.9, - wreq >= 0.2, - text >= 1.2, - lens >= 4.8, - lens-aeson >= 1.0 , - network >= 2.6, - network-uri >= 2.6, - openssl-streams >= 1.2, - HsOpenSSL >= 0.11 , - io-streams >= 1.2, - mtl >= 2.1, - aeson >= 0.8 , - time-locale-compat >= 0.1 && < 0.2, - errors >= 1.4 && < 3.0, - monad-loops >= 0.4, - transformers >= 0.3, - time >= 1.4 +executable example_echobot + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: example + main-is: EchoBot.hs + build-depends: base, slack-api -Test-Suite tests - Type: exitcode-stdio-1.0 - Main-Is: tests-main.hs - ghc-options: -threaded -Wall - HS-Source-Dirs: tests . - Build-Depends: slack-api, base - Other-Modules: Tests.ConnectionTest +executable example_counterbot + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: example + main-is: CounterBot.hs + build-depends: base, slack-api, text, mtl, lens diff --git a/src/Web/Slack.hs b/src/Web/Slack.hs --- a/src/Web/Slack.hs +++ b/src/Web/Slack.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} ------------------------------------------ -- | -- This module exposes functionality to write bots which responds @@ -38,33 +39,26 @@ , userState , session , module Web.Slack.Types - , module Web.Slack.Config + , SlackConfig(..) ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative +#endif import Control.Lens -import Control.Monad (forever, unless) +import Control.Monad.Except import qualified Control.Monad.State as S -import Control.Monad.Trans -import Data.Aeson.Lens -import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Char8 as BC import qualified Data.Text as T -import qualified Network.Socket as S import qualified Network.URI as URI import qualified Network.WebSockets as WS -import qualified Network.WebSockets.Stream as WS -import Network.Wreq -import qualified OpenSSL as SSL -import qualified OpenSSL.Session as SSL -import qualified System.IO.Streams.Internal as StreamsIO -import qualified System.IO.Streams.SSL as Streams import Data.Aeson -import Web.Slack.Config import Web.Slack.State import Web.Slack.Types +import Web.Slack.WebAPI +import Wuss -- | Run a `SlackBot`. The supplied bot will respond to all events sent by -- the Slack RTM API. @@ -73,45 +67,23 @@ -- to the Slack API fails. runBot :: forall s . SlackConfig -> SlackBot s -> s -> IO () runBot conf bot start = do - r <- get rtmStartUrl - let Just (BoolPrim ok) = r ^? responseBody . key "ok" . _Primitive - unless ok (do - putStrLn "Unable to connect" - ioError . userError . T.unpack $ r ^. responseBody . key "error" . _String) - let Just url = r ^? responseBody . key "url" . _String - (sessionInfo :: SlackSession) <- - case eitherDecode (r ^. responseBody) of - Left e -> print (r ^. responseBody) >> (ioError . userError $ e) - Right res -> return res + (url, sessionInfo) <- crashOnError $ rtm_start conf let partialState :: Metainfo -> SlackState s partialState metainfo = SlackState metainfo sessionInfo start conf putStrLn "rtm.start call successful" case parseWebSocketUrl (T.unpack url) of Just (host, path) -> - SSL.withOpenSSL $ do - ctx <- SSL.context - is <- S.getAddrInfo Nothing (Just host) (Just $ show port) - let a = S.addrAddress $ head is - f = S.addrFamily $ head is - s <- S.socket f S.Stream S.defaultProtocol - S.connect s a - ssl <- SSL.connection ctx s - SSL.connect ssl - (i,o) <- Streams.sslToStreams ssl - (stream :: WS.Stream) <- WS.makeStream (StreamsIO.read i) (\b -> StreamsIO.write (B.toStrict <$> b) o ) - WS.runClientWithStream stream host path WS.defaultConnectionOptions [] - (mkBot partialState bot) + runSecureClient host port path (mkBot partialState bot) Nothing -> error $ "Couldn't parse WebSockets URL: " ++ T.unpack url where - port = 443 :: Int - rtmStartUrl :: String - rtmStartUrl = "https://slack.com/api/rtm.start?token=" - ++ (conf ^. slackApiToken) + port = 443 parseWebSocketUrl :: String -> Maybe (String, String) parseWebSocketUrl url = do uri <- URI.parseURI url name <- URI.uriRegName <$> URI.uriAuthority uri return (name, URI.uriPath uri) + crashOnError :: ExceptT T.Text IO a -> IO a + crashOnError = either (ioError . userError . T.unpack) return <=< runExceptT mkBot :: (Metainfo -> SlackState s) -> SlackBot s -> WS.ClientApp () mkBot partialState bot conn = do diff --git a/src/Web/Slack/Config.hs b/src/Web/Slack/Config.hs deleted file mode 100644 --- a/src/Web/Slack/Config.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Web.Slack.Config (SlackConfig(..), slackApiToken) where - -import Control.Lens.TH - --- | Configuration options needed to connect to the Slack API -data SlackConfig = SlackConfig - { _slackApiToken :: String -- ^ API Token for Bot - } deriving (Show) - -makeLenses ''SlackConfig diff --git a/src/Web/Slack/Message.hs b/src/Web/Slack/Message.hs --- a/src/Web/Slack/Message.hs +++ b/src/Web/Slack/Message.hs @@ -7,8 +7,6 @@ import Control.Lens import Control.Monad.State import Data.Aeson (encode) -import Data.Aeson.TH -import Data.Char import qualified Data.Text as T import qualified Network.WebSockets as WS import Web.Slack.State @@ -17,14 +15,6 @@ import Prelude -data MessagePayload = MessagePayload - { messageId :: Int - , messageType :: T.Text - , messageChannel :: ChannelId - , messageText :: T.Text } deriving Show - -$(deriveToJSON defaultOptions {fieldLabelModifier = map toLower . drop 7} ''MessagePayload) - -- | Send a message to the specified channel. -- -- If the message is longer than 4000 bytes then the connection will be @@ -36,14 +26,6 @@ let payload = MessagePayload uid "message" cid message slackLog payload liftIO $ WS.sendTextData conn (encode payload) - -data PingPayload = PingPayload - { pingId :: Int - , pingType :: T.Text - , pingTimestamp :: Int - } deriving Show - -$(deriveToJSON defaultOptions {fieldLabelModifier = map toLower . drop 4} ''PingPayload) makePingPacket :: Slack s (IO ()) makePingPacket = do diff --git a/src/Web/Slack/State.hs b/src/Web/Slack/State.hs --- a/src/Web/Slack/State.hs +++ b/src/Web/Slack/State.hs @@ -15,7 +15,7 @@ import qualified Control.Monad.State as S import qualified Network.WebSockets as WS import Web.Slack.Types -import Web.Slack.Config +import Web.Slack.WebAPI (SlackConfig) import Prelude newtype Slack s a = Slack {runSlack :: S.StateT (SlackState s) IO a} diff --git a/src/Web/Slack/Types.hs b/src/Web/Slack/Types.hs --- a/src/Web/Slack/Types.hs +++ b/src/Web/Slack/Types.hs @@ -1,45 +1,47 @@ -module Web.Slack.Types ( - module Web.Slack.Types.Bot, - module Web.Slack.Types.Comment, - module Web.Slack.Types.File, - module Web.Slack.Types.IM, - module Web.Slack.Types.Topic, - module Web.Slack.Types.Channel, - module Web.Slack.Types.Event.Subtype, - module Web.Slack.Types.Item, - module Web.Slack.Types.User, - module Web.Slack.Types.ChannelOpt, - module Web.Slack.Types.Event, - module Web.Slack.Types.Id, - module Web.Slack.Types.Time, - module Web.Slack.Types.Error, - module Web.Slack.Types.Preferences, - module Web.Slack.Types.TeamPreferences, - module Web.Slack.Types.Team, - module Web.Slack.Types.Self, - module Web.Slack.Types.Session, - module Web.Slack.Types.Presence, - module Web.Slack.Types.Base - ) where +module Web.Slack.Types + ( module Web.Slack.Types.Base + , module Web.Slack.Types.Bot + , module Web.Slack.Types.Channel + , module Web.Slack.Types.ChannelOpt + , module Web.Slack.Types.Comment + , module Web.Slack.Types.Error + , module Web.Slack.Types.Event + , module Web.Slack.Types.Event.Subtype + , module Web.Slack.Types.File + , module Web.Slack.Types.IM + , module Web.Slack.Types.Id + , module Web.Slack.Types.Item + , module Web.Slack.Types.Message + , module Web.Slack.Types.Preferences + , module Web.Slack.Types.Presence + , module Web.Slack.Types.Self + , module Web.Slack.Types.Session + , module Web.Slack.Types.Team + , module Web.Slack.Types.TeamPreferences + , module Web.Slack.Types.Time + , module Web.Slack.Types.Topic + , module Web.Slack.Types.User + ) where import Web.Slack.Types.Base import Web.Slack.Types.Bot -import Web.Slack.Types.Comment -import Web.Slack.Types.File -import Web.Slack.Types.IM -import Web.Slack.Types.Topic import Web.Slack.Types.Channel -import Web.Slack.Types.Event.Subtype -import Web.Slack.Types.Item -import Web.Slack.Types.User import Web.Slack.Types.ChannelOpt +import Web.Slack.Types.Comment +import Web.Slack.Types.Error import Web.Slack.Types.Event +import Web.Slack.Types.Event.Subtype +import Web.Slack.Types.File +import Web.Slack.Types.IM import Web.Slack.Types.Id -import Web.Slack.Types.Time -import Web.Slack.Types.Error +import Web.Slack.Types.Item +import Web.Slack.Types.Message import Web.Slack.Types.Preferences -import Web.Slack.Types.TeamPreferences -import Web.Slack.Types.Team +import Web.Slack.Types.Presence import Web.Slack.Types.Self import Web.Slack.Types.Session -import Web.Slack.Types.Presence +import Web.Slack.Types.Team +import Web.Slack.Types.TeamPreferences +import Web.Slack.Types.Time +import Web.Slack.Types.Topic +import Web.Slack.Types.User diff --git a/src/Web/Slack/Types/Event.hs b/src/Web/Slack/Types/Event.hs --- a/src/Web/Slack/Types/Event.hs +++ b/src/Web/Slack/Types/Event.hs @@ -21,9 +21,8 @@ import Control.Lens.TH import Control.Applicative +import Control.Monad import Data.Text (Text) -import qualified Data.Text as T -import Data.Monoid import Prelude type Domain = Text @@ -70,8 +69,8 @@ PrefChange :: Pref -> Event UserChange :: User -> Event TeamJoin :: User -> Event - ReactionAdded :: UserId -> Maybe Text -> Item -> SlackTimeStamp -> Event - ReactionRemoved :: UserId -> Maybe Text -> Item -> SlackTimeStamp -> Event + ReactionAdded :: UserId -> Text -> UserId {- item author -} -> EmbeddedItem -> SlackTimeStamp -> Event + ReactionRemoved :: UserId -> Maybe Text -> EmbeddedItem -> SlackTimeStamp -> Event StarAdded :: UserId -> Item -> SlackTimeStamp -> Event StarRemoved :: UserId -> Item -> SlackTimeStamp -> Event EmojiChanged :: SlackTimeStamp -> Event @@ -125,7 +124,7 @@ submitter <- case subt of Just (SBotMessage bid _ _) -> return $ BotComment bid _ -> maybe System UserComment <$> v .:? "user" - (v .: "channel") :: Parser ChannelId + void $ (v .: "channel" :: Parser ChannelId) hidden <- (\case {Just True -> True; _ -> False}) <$> v .:? "hidden" if not hidden then Message <$> v .: "channel" <*> pure submitter <*> v .: "text" <*> v .: "ts" <*> pure subt <*> v .:? "edited" @@ -169,7 +168,7 @@ "pref_change" -> curry PrefChange <$> v .: "name" <*> v .: "value" "user_change" -> UserChange <$> v .: "user" "team_join" -> TeamJoin <$> v .: "user" - "reaction_added" -> ReactionAdded <$> v .: "user" <*> v .:? "name" <*> v .: "item" <*> v .: "event_ts" + "reaction_added" -> ReactionAdded <$> v .: "user" <*> v .: "reaction" <*> v .: "item_user" <*> v .: "item" <*> v .: "event_ts" "reaction_removed" -> ReactionRemoved <$> v .: "user" <*> v .:? "name" <*> v .: "item" <*> v .: "event_ts" "star_added" -> StarAdded <$> v .: "user" <*> v .: "item" <*> v .: "event_ts" "star_removed" -> StarRemoved <$> v .: "user" <*> v .: "item" <*> v .: "event_ts" diff --git a/src/Web/Slack/Types/Event/Subtype.hs b/src/Web/Slack/Types/Event/Subtype.hs --- a/src/Web/Slack/Types/Event/Subtype.hs +++ b/src/Web/Slack/Types/Event/Subtype.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase, GADTs, OverloadedStrings, TemplateHaskell #-} +{-# LANGUAGE LambdaCase, GADTs, OverloadedStrings, TemplateHaskell, CPP #-} module Web.Slack.Types.Event.Subtype (Subtype(..), subtype) where import Data.Aeson @@ -9,7 +9,9 @@ import Web.Slack.Types.Comment import Web.Slack.Types.Bot import Web.Slack.Types.Item +#if !MIN_VERSION_base(4,8,0) import Control.Applicative +#endif import Data.Text (Text) import Control.Lens.TH diff --git a/src/Web/Slack/Types/IM.hs b/src/Web/Slack/Types/IM.hs --- a/src/Web/Slack/Types/IM.hs +++ b/src/Web/Slack/Types/IM.hs @@ -3,6 +3,7 @@ import Data.Aeson import Data.Aeson.Types +import Data.Coerce import Control.Applicative import Control.Lens.TH @@ -30,3 +31,9 @@ <*> o .: "is_open" <*> o .: "is_im" <*> (pure $ parseMaybe parseJSON (Object o) :: Parser (Maybe ChannelOpt))) + +imToChannel :: IMId -> ChannelId +imToChannel = coerce + +channelToIM :: ChannelId -> IMId +channelToIM = coerce diff --git a/src/Web/Slack/Types/Id.hs b/src/Web/Slack/Types/Id.hs --- a/src/Web/Slack/Types/Id.hs +++ b/src/Web/Slack/Types/Id.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, KindSignatures, TemplateHaskell #-} +{-# LANGUAGE DataKinds, KindSignatures, TemplateHaskell, DeriveGeneric #-} module Web.Slack.Types.Id ( UserId, BotId, @@ -14,10 +14,12 @@ import Data.Aeson import Data.Text (Text) import Control.Lens.TH +import Data.Hashable +import GHC.Generics data FieldType = TUser | TBot | TChannel | TFile | TComment | TIM | TTeam deriving (Eq, Show) -newtype Id (a :: FieldType) = Id { _getId :: Text } deriving (Show, Eq) +newtype Id (a :: FieldType) = Id { _getId :: Text } deriving (Show, Eq, Ord, Generic) instance ToJSON (Id a) where @@ -25,6 +27,8 @@ instance FromJSON (Id a) where parseJSON = withText "Id" (return . Id) + +instance Hashable (Id a) type UserId = Id 'TUser type BotId = Id 'TBot diff --git a/src/Web/Slack/Types/Item.hs b/src/Web/Slack/Types/Item.hs --- a/src/Web/Slack/Types/Item.hs +++ b/src/Web/Slack/Types/Item.hs @@ -20,6 +20,12 @@ | IMItem ChannelId | GroupItem ChannelId deriving Show +data EmbeddedItem + = EmbeddedMessageItem ChannelId SlackTimeStamp + | EmbeddedFileItem FileId + | EmbeddedFileCommentItem FileId CommentId + deriving Show + instance FromJSON Item where parseJSON = withObject "item" (\o -> do (typ :: String) <- o .: "type" @@ -31,6 +37,15 @@ "im" -> IMItem <$> o .: "channel" "group" -> GroupItem <$> o .: "group" _ -> fail $ "Unrecognised item type: " ++ typ) + +instance FromJSON EmbeddedItem where + parseJSON = withObject "item" $ \o -> do + (typ :: String) <- o .: "type" + case typ of + "message" -> EmbeddedMessageItem <$> o .: "channel" <*> o .: "ts" + "file" -> EmbeddedFileItem <$> o .: "file" + "file_comment" -> EmbeddedFileCommentItem <$> o .: "file" <*> o .: "file_comment" + _ -> fail $ "Unrecognised item type: " ++ typ data MessageUpdate = MessageUpdate { _messageUpdateUser :: UserId diff --git a/src/Web/Slack/Types/Message.hs b/src/Web/Slack/Types/Message.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Types/Message.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +module Web.Slack.Types.Message where + +import Data.Aeson +import Data.Aeson.TH +import qualified Data.Text as T +import Data.Time.Clock.POSIX +import GHC.Generics +import Web.Slack.Types.Base +import Web.Slack.Types.Id +import Web.Slack.Utils + +data MessagePayload = MessagePayload + { messageId :: Int + , messageType :: T.Text + , messageChannel :: ChannelId + , messageText :: T.Text + } deriving (Show) + +data PingPayload = PingPayload + { pingId :: Int + , pingType :: T.Text + , pingTimestamp :: Int + } deriving (Show) + +data Attachment = Attachment + { attachmentFallback :: T.Text + -- ^ A plain-text summary of the attachment. + , attachmentColor :: AttachmentColor + -- ^ Used to color the border along the left side of the message + -- attachment. + , attachmentPretext :: Maybe T.Text + -- ^ Optional text that appears above the message attachment block. + , attachmentAuthorName :: Maybe T.Text + -- ^ Small text used to display the author's name. + , attachmentAuthorLink :: Maybe URL + -- ^ A valid URL that will hyperlink the author_name text mentioned + -- above. + , attachmentAuthorIcon :: Maybe URL + -- ^ A valid URL that displays a small 16x16px image to the left of + -- the author_name text. + , attachmentTitle :: Maybe T.Text + -- ^ The title is displayed as larger, bold text near the top of + -- a message attachment. + , attachmentTitleLink :: Maybe URL + -- ^ By passing a valid URL, the title text will be hyperlinked. + , attachmentText :: Maybe T.Text + -- ^ This is the main text in a message attachment, and can contain + -- standard message markup. + , attachmentFields :: [Field] + , attachmentImageUrl :: Maybe URL + -- ^ An image file that will be displayed inside a message + -- attachment. GIF, JPEG, PNG, or BMP; scaled down to 400x500px. + , attachmentThumbUrl :: Maybe URL + -- ^ Displayed as a thumbnail on the right side of a message + -- attachment. GIF, JPEG, PNG, or BMP; scaled down to 75x75px. + , attachmentFooter :: Maybe T.Text + -- ^ Add some brief text to help contextualize and identify an + -- attachment. + , attachmentFooterIcon :: Maybe URL + -- ^ Render a small icon beside your footer text. Scaled to 16x16px. + , attachmentTs :: Maybe POSIXTime + -- ^ Display an additional timestamp value as part of the + -- attachment's footer. + } + +data Field = Field + { fieldTitle :: Maybe T.Text + -- ^ Shown as a bold heading above the value text. It cannot + -- contain markup and will be escaped for you. + , fieldValue :: T.Text + -- ^ The text value of the field. It may contain standard message + -- markup and must be escaped as normal. May be multi-line. + , fieldShort :: Bool + -- ^ Whether the value is short enough to be displayed side-by-side + -- with other values. + } + +data AttachmentColor + = DefaultColor -- grey + | GoodColor -- green + | WarningColor -- yellow + | DangerColor -- red + | CustomColor T.Text -- hexadecimal RGB colour, eg. CustomColor "#439FE0" + deriving (Generic) + +defaultAttachment :: Attachment +defaultAttachment = Attachment + { attachmentFallback = "" + , attachmentColor = DefaultColor + , attachmentPretext = Nothing + , attachmentAuthorName = Nothing + , attachmentAuthorLink = Nothing + , attachmentAuthorIcon = Nothing + , attachmentTitle = Nothing + , attachmentTitleLink = Nothing + , attachmentText = Nothing + , attachmentFields = [] + , attachmentImageUrl = Nothing + , attachmentThumbUrl = Nothing + , attachmentFooter = Nothing + , attachmentFooterIcon = Nothing + , attachmentTs = Nothing + } + +instance ToJSON AttachmentColor where + toEncoding x = toEncoding $ case x of + DefaultColor -> Nothing + GoodColor -> Just "good" + WarningColor -> Just "warning" + DangerColor -> Just "danger" + CustomColor c -> Just c + +$(deriveToJSON defaultOptions {fieldLabelModifier = toSnake . drop 7} ''MessagePayload) +$(deriveToJSON defaultOptions {fieldLabelModifier = toSnake . drop 4} ''PingPayload) +$(deriveToJSON defaultOptions {fieldLabelModifier = toSnake . drop 10} ''Attachment) +$(deriveToJSON defaultOptions {fieldLabelModifier = toSnake . drop 5} ''Field) diff --git a/src/Web/Slack/Types/Preferences.hs b/src/Web/Slack/Types/Preferences.hs --- a/src/Web/Slack/Types/Preferences.hs +++ b/src/Web/Slack/Types/Preferences.hs @@ -29,7 +29,6 @@ , _prefLoudChannels :: Text , _prefNeverChannels :: Text , _prefLoudChannelsSet :: Text - , _prefShowMemberPresence :: Bool , _prefSearchSort :: Text , _prefExpandInlineImgs :: Bool , _prefExpandSnippets :: Bool diff --git a/src/Web/Slack/WebAPI.hs b/src/Web/Slack/WebAPI.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/WebAPI.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Web.Slack.WebAPI + ( SlackConfig(..) + , makeSlackCall + + -- * Methods + , rtm_start + , chat_postMessage + ) where + +import Control.Lens hiding ((??)) +import Control.Monad.Except +import Data.Aeson +import Data.Aeson.Lens +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Network.Wreq as W +import Web.Slack.Types + +-- | Configuration options needed to connect to the Slack API +data SlackConfig = SlackConfig + { _slackApiToken :: String -- ^ API Token for Bot + } deriving (Show) + +makeLenses ''SlackConfig + +makeSlackCall + :: (MonadError T.Text m, MonadIO m) + => SlackConfig + -> String + -> (W.Options -> W.Options) + -> m Value +makeSlackCall conf method setArgs = do + let url = "https://slack.com/api/" ++ method + let setToken = W.param "token" .~ [T.pack (conf ^. slackApiToken)] + let opts = W.defaults & setToken & setArgs + rawResp <- liftIO $ W.getWith opts url + resp <- rawResp ^? W.responseBody . _Value ?? "Couldn't parse response" + case resp ^? key "ok" . _Bool of + Just True -> return resp + Just False -> throwError $ resp ^. key "error" . _String + Nothing -> throwError "Couldn't parse key 'ok' from response" + +------------------------------------------------------------------------------- +-- Methods + +-- See https://api.slack.com/methods for the docs. + +rtm_start + :: (MonadError T.Text m, MonadIO m) + => SlackConfig + -> m (T.Text, SlackSession) +rtm_start conf = do + resp <- makeSlackCall conf "rtm.start" id + url <- resp ^? key "url" . _String ?? "rtm_start: No url!" + sessionInfo <- fromJSON' resp + return (url, sessionInfo) + +chat_postMessage + :: (MonadError T.Text m, MonadIO m) + => SlackConfig + -> ChannelId + -> T.Text + -> [Attachment] + -> m () +chat_postMessage conf (Id cid) msg as = + void $ makeSlackCall conf "chat.postMessage" $ + (W.param "channel" .~ [cid]) . + (W.param "text" .~ [msg]) . + (W.param "attachments" .~ [encode' as]) . + (W.param "as_user" .~ ["true"]) + +------------------------------------------------------------------------------- +-- Helpers + +encode' :: ToJSON a => a -> T.Text +encode' = T.decodeUtf8 . BL.toStrict . encode + +fromJSON' :: (FromJSON a, MonadError T.Text m) => Value -> m a +fromJSON' x = case fromJSON x of + Error e -> throwError (T.pack e) + Success r -> return r + +-- | Like '(??)' from Control.Error, but a bit more general and with the +-- right precedence. +infixl 7 ?? +(??) :: MonadError e m => Maybe a -> e -> m a +x ?? e = maybe (throwError e) return x + diff --git a/tests/tests-main.hs b/tests/tests-main.hs --- a/tests/tests-main.hs +++ b/tests/tests-main.hs @@ -2,4 +2,5 @@ import qualified Tests.ConnectionTest as C +main :: IO () main = C.main