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.5 +Version: 0.6 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`. @@ -79,7 +79,7 @@ mtl >= 2.1, aeson >= 0.8 , time-locale-compat >= 0.1 && < 0.2, - errors >= 1.4 && < 2.0, + errors >= 1.4 && < 3.0, monad-loops >= 0.4, transformers >= 0.3, time >= 1.4 diff --git a/src/Web/Slack.hs b/src/Web/Slack.hs --- a/src/Web/Slack.hs +++ b/src/Web/Slack.hs @@ -3,7 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} + {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -81,13 +81,13 @@ let Just url = r ^? responseBody . key "url" . _String (sessionInfo :: SlackSession) <- case eitherDecode (r ^. responseBody) of - Left e -> (print (r ^. responseBody)) >> (ioError . userError $ e) + Left e -> print (r ^. responseBody) >> (ioError . userError $ e) Right res -> return res 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) -> do + Just (host, path) -> SSL.withOpenSSL $ do ctx <- SSL.context is <- S.getAddrInfo Nothing (Just host) (Just $ show port) @@ -116,6 +116,7 @@ mkBot :: (Metainfo -> SlackState s) -> SlackBot s -> WS.ClientApp () mkBot partialState bot conn = do let initMeta = Meta conn 0 + WS.forkPingThread conn 10 botLoop (partialState initMeta) bot botLoop :: forall s . SlackState s -> SlackBot s -> IO () @@ -132,5 +133,11 @@ liftIO $ BC.putStrLn raw liftIO $ putStrLn e liftIO . putStrLn $ "Please report this failure to the github issue tracker" + Right event@(UnknownEvent e) -> do + liftIO . print $ e + liftIO . putStrLn $ "Failed to parse to a known event" + liftIO . putStrLn $ "Please report this failure to the github issue tracker" + -- Still handle the event if a user wants to + f event Right event -> f event diff --git a/src/Web/Slack/Types/Channel.hs b/src/Web/Slack/Types/Channel.hs --- a/src/Web/Slack/Types/Channel.hs +++ b/src/Web/Slack/Types/Channel.hs @@ -6,6 +6,7 @@ import Control.Applicative import Data.Text (Text) import Control.Lens.TH +import Data.Maybe (fromMaybe) import Web.Slack.Types.Id import Web.Slack.Types.Time @@ -17,7 +18,7 @@ , _channelName :: Text , _channelCreated :: Time , _channelCreator :: UserId - , _channelIsArchived :: Bool + , _channelIsArchived :: Maybe Bool , _channelIsGeneral :: Bool , _channelMembers :: Maybe [UserId] , _channelTopic :: Maybe Topic @@ -28,10 +29,13 @@ makeLenses ''Channel +defaultToFalse :: Object -> Text -> Parser Bool +defaultToFalse o tag = fmap (fromMaybe False) $ o .:? tag + instance FromJSON Channel where parseJSON = withObject "Channel" (\o -> Channel <$> o .: "id" <*> o .: "name" <*> o .: "created" <*> o .:"creator" - <*> o .: "is_archived" <*> o .: "is_general" + <*> o .:? "is_archived" <*> defaultToFalse o "is_general" <*> o .:? "members" <*> o .:? "topic" - <*> o .:? "purpose" <*> o .: "is_member" + <*> o .:? "purpose" <*> defaultToFalse o "is_member" <*> (pure $ parseMaybe parseJSON (Object o) :: Parser (Maybe ChannelOpt))) 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 @@ -71,6 +71,8 @@ PrefChange :: Pref -> Event UserChange :: User -> Event TeamJoin :: User -> Event + ReactionAdded :: UserId -> Maybe Text -> Item -> SlackTimeStamp -> Event + ReactionRemoved :: UserId -> Maybe Text -> Item -> SlackTimeStamp -> Event StarAdded :: UserId -> Item -> SlackTimeStamp -> Event StarRemoved :: UserId -> Item -> SlackTimeStamp -> Event EmojiChanged :: SlackTimeStamp -> Event @@ -85,8 +87,14 @@ UserTyping :: ChannelId -> UserId -> Event MessageResponse :: Int -> SlackTimeStamp -> Text -> Event MessageError :: Int -> SlackError -> Event + StatusChange :: UserId -> Text -> SlackTimeStamp -> Event Pong :: Time -> Event + -- Unstable + PinAdded :: Event + PinRemoved :: Event NoEvent :: Event + -- Parsing failing of an event + UnknownEvent :: Value -> Event deriving (Show) type Pref = (Text, Value) @@ -160,6 +168,8 @@ "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_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" "emoji_changed" -> EmojiChanged <$> v .: "event_ts" @@ -171,8 +181,11 @@ "bot_added" -> BotAdded <$> v .: "bot" "bot_changed" -> BotChanged <$> v .: "bot" "accounts_changed" -> pure AccountsChanged + "status_change" -> StatusChange <$> v .: "user" <*> v .: "status" <*> v .: "event_ts" "pong" -> Pong <$> v .: "timestamp" - _ -> fail $ "Unrecognised type: " <> T.unpack typ + "pin_added" -> pure PinAdded + "pin_removed" -> pure PinRemoved + _ -> return $ UnknownEvent o parseType _ _ = error "Expecting object" 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 @@ -36,6 +36,11 @@ SFileShare :: File -> Bool -> Subtype SFileComment :: File -> Comment -> Subtype SFileMention :: File -> Subtype + -- These two subtypes are documented as unstable, so they shouldn't + -- be used. See https://api.slack.com/events/message/pinned_item + -- for more detail and updates. + SPinnedItem :: Subtype + SUnpinnedItem :: Subtype deriving Show subtype :: String -> Value -> Parser Subtype @@ -63,5 +68,7 @@ "file_share" -> SFileShare <$> v .: "file" <*> v .: "upload" "file_comment" -> SFileComment <$> v .: "file" <*> v .: "comment" "file_mention" -> SFileMention <$> v .: "file" + "pinned_item" -> pure SPinnedItem + "unpinned_item" -> pure SUnpinnedItem _ -> fail $ "Unrecognised subtype: " ++ s) diff --git a/src/Web/Slack/Types/User.hs b/src/Web/Slack/Types/User.hs --- a/src/Web/Slack/Types/User.hs +++ b/src/Web/Slack/Types/User.hs @@ -18,7 +18,6 @@ { _userId :: UserId , _userName :: Text , _userDeleted :: Bool - , _userStatus :: Maybe Text , _userColor :: Text , _userProfile :: Profile , _userPermission :: Permissions @@ -28,7 +27,7 @@ instance FromJSON User where parseJSON = withObject "User" (\o -> User <$> o .: "id" <*> o .: "name" <*> o .: "deleted" - <*> o .:? "status" <*> (o .:? "color" .!= "000000") + <*> (o .:? "color" .!= "000000") <*> o .: "profile" <*> (parseJSON (Object o) :: Parser Permissions) <*> fmap (fromMaybe False) (o .:? "has_files") <*> ((return $ fromMaybe defaultTimezone (parseMaybe parseJSON (Object o))) :: Parser Timezone))