diff --git a/flowdock.cabal b/flowdock.cabal --- a/flowdock.cabal +++ b/flowdock.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: flowdock -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Flowdock client library for Haskell -- description: homepage: https://github.com/brewtown/hs-flowdock @@ -29,6 +29,12 @@ text >= 1 && < 2, bytestring >= 0.9 && < 1, template-haskell, - unordered-containers >= 0.2 && < 0.3 + unordered-containers >= 0.2 && < 0.3, + base64-bytestring, + uuid, + pipes, + pipes-http, + pipes-parse, + pipes-aeson hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Chat/Flowdock.hs b/src/Chat/Flowdock.hs --- a/src/Chat/Flowdock.hs +++ b/src/Chat/Flowdock.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-| A client library for the Flowdock API. Currently only implements the push API. -} @@ -15,14 +17,58 @@ -- ** Authentication types -- $auth Push(..), + User(..), + -- ** General types + Flow(..), + flow, + organization, + -- ** REST API + MessageType, + Message, + MessageId(..), + message, + comment, + flow, + event, + tags, + externalUserName, + uuid, + Chat, + content, + FileUpload, + content, + contentType, + Status, + content, + fileName, + sendMessage, + Comment, + content, + messageId, + sendComment, -- ** Pushing messages to the inbox pushToInbox, newInboxPushMessage, + MessageResponse, + messageId, + sent, + app, -- ** Pushing messages to the chatroom pushToChat, Content, ExternalUserName, newChatPushMessage, + -- ** Streaming events + FlowFilter, + allFlows, + justFlows, + StreamQuery, + user, + Event, + active, + streamOptions, + streamFlow, + streamFlows, -- ** Constructing messages -- *** InboxPushMessage fields InboxPushMessage, @@ -44,26 +90,57 @@ Tag(..), tags, -- *** Exception types - JSONError(..) + JSONError(..), + -- *** Lens field classes + HasActive, + HasApp, + HasContent, + HasContentType, + HasEvent, + HasExternalUserName, + HasFileName, + HasFlow, + HasFormat, + HasFromAddress, + HasFromName, + HasLink, + HasMessageId, + HasOrganization, + HasProject, + HasReplyTo, + HasSent, + HasSource, + HasSubject, + HasTags, + HasUser, + HasUuid ) where -import Control.Exception -import Control.Monad -import Control.Lens hiding ((.=)) -import Control.Lens.TH -import Data.Aeson -import Data.Aeson.TH -import Data.ByteString (ByteString) -import Data.ByteString.Lazy (fromChunks) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM -import Data.Monoid -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -import Data.Typeable -import Network.HTTP.Client -import Network.HTTP.Client.TLS +import Control.Applicative +import Control.Exception +import Control.Lens hiding ((.=)) +import Control.Lens.TH +import Control.Monad +import Data.Aeson +import Data.Aeson.TH +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BC +import Data.ByteString.Lazy (fromChunks) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.Maybe +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Typeable +import Data.UUID +import Pipes +import qualified Pipes.Aeson as A +import Pipes.HTTP +import Pipes.Parse -import Chat.Flowdock.Internal +import Chat.Flowdock.Internal -- REST API {- listUserFlows @@ -72,8 +149,196 @@ getFlowById createFlow updateFlow -sendMessage -sendComment +-} + +-- wrapper to work around orphan instance for ToJSON +newtype WrapUUID = Wrap UUID + +instance ToJSON WrapUUID where + toJSON (Wrap u) = String $ decodeUtf8 $ toASCIIBytes u + +data Flow + = QualifiedFlow + { _qfOrganization :: Text + , _qfFlow :: Text + } + | FlowId Text + +data Tag = UserTag Text | HashTag Text + deriving (Read, Show) + +instance ToJSON Tag where + toJSON (UserTag t) = String ("@" <> t) + toJSON (HashTag t) = String ("#" <> t) + +data Message a = Message + { _mFlow :: Flow + , _mEvent :: a + , _mTags :: [Tag] + , _mExternalUserName :: Maybe Text + , _mUuid :: Maybe UUID + } + +data Chat = Chat + { _chatContent :: Text + } + +data FileUpload = FileUpload + { _fContent :: ByteString + , _fContentType :: Text + , _fFileName :: Text + } + +newtype MessageId = MessageId Int + deriving (Show, ToJSON, FromJSON) + +data Comment = Comment + { _commentContent :: Text + , _commentMessageId :: MessageId + } + +message qf e = Message qf e [] Nothing Nothing + +comment = Comment + +data Status = Status + { _statusContent :: Text + } + +type Event = Object + +newtype FlowFilter = FlowFilter (Maybe [Flow]) + +data StreamQuery a = StreamQuery + { _sqSource :: a + , _sqUser :: Maybe Bool + , _sqActive :: Maybe Bool + } + +data MessageResponse c = MessageResponse + { _mrMessageId :: MessageId + , _mrSent :: Int + , _mrApp :: Text + -- , _mr + } deriving (Show) + +instance FromJSON (MessageResponse r) where + parseJSON (Object o) = MessageResponse <$> (MessageId <$> o .: "id") <*> o .: "sent" <*> o .: "app" + parseJSON _ = mzero + +makeFields ''Flow +makeFields ''Message +makeFields ''Chat +makeFields ''FileUpload +makeFields ''Comment +makeFields ''Status +makeFields ''StreamQuery +makeFields ''MessageResponse + +class StreamParams a where + streamParams :: a -> [(ByteString, Maybe ByteString)] + +instance StreamParams Flow where + streamParams = const [] + +instance StreamParams FlowFilter where + streamParams (FlowFilter s) = [("filter", Just $ encodeUtf8 $ T.intercalate "," $ s ^.. _Just . traverse . to (\f -> (f ^. organization) <> "/" <> (f ^. flow)))] + + +class MessageType a where + messageJSON :: Message a -> Value + +instance MessageType Chat where + messageJSON m = Object . HM.insert "content" (m ^. event . content . to toJSON) $ baseMessage "message" m + +instance ToJSON (Message Comment) where + toJSON m = let e = m ^. event in Object + . HM.insert "content" (e ^. content . to toJSON) + . HM.insert "message" (e ^. messageId . to toJSON) + $ baseMessage "comment" m + +instance MessageType Status where + messageJSON m = Object . HM.insert "content" (m ^. event . content . to toJSON) $ baseMessage "status" m + +instance MessageType FileUpload where + messageJSON m = Object . HM.insert "content" co $ baseMessage "file" m + where + e = m ^. event + co = object [ "data" .= decodeUtf8 (B64.encode (e ^. content)) + , "content_type" .= (e ^. contentType) + , "file_name" .= (e ^. fileName) + ] + +data InboxPushFormat = Html + deriving (Read, Show) + +instance ToJSON InboxPushFormat where + toJSON = const $ String "html" + +data InboxPushMessage = InboxPushMessage + { _ipSource :: Text + , _ipFromAddress :: Text + , _ipSubject :: Text + , _ipContent :: Text + , _ipFromName :: Maybe Text + , _ipReplyTo :: Maybe Text + , _ipProject :: Maybe Text + , _ipFormat :: Maybe InboxPushFormat + , _ipTags :: Maybe [Tag] + , _ipLink :: Maybe Text + } deriving (Read, Show) + +data ChatPushMessage = ChatPushMessage + { _cpContent :: Text + , _cpExternalUserName :: Text + , _cpTags :: Maybe [Tag] + , _cpMessageId :: Maybe Text + } deriving (Read, Show) + +data JSONError = JSONError String + deriving (Show, Typeable) + +instance Exception JSONError + +addPath :: ByteString -> Request -> Request +addPath p r = r { path = path r <> p } + +flowdockRestBaseRequest = let (Just r) = parseUrl "https://api.flowdock.com/" in r { requestHeaders = ("Content-Type", "application/json") : requestHeaders r } +flowdockPushBaseRequest = let (Just r) = parseUrl "https://api.flowdock.com/v1/" in r { requestHeaders = ("Content-Type", "application/json") : requestHeaders r } + +flowdockStreamBaseRequest = let (Just r) = parseUrl "https://stream.flowdock.com/" in r { requestHeaders = ("Content-Type", "application/json") : requestHeaders r } + +-- Push API +newtype Push = Push { pushFlowApiToken :: Text } + +newtype User = User { userAccessToken :: Text } + +class ClientManagerSettings a where + managerSettings :: a -> ManagerSettings + +instance ClientManagerSettings Push where + managerSettings = const tlsManagerSettings + +instance ClientManagerSettings User where + managerSettings = const (tlsManagerSettings { managerResponseTimeout = Nothing }) + +data FlowdockClient a = FlowdockClient + { clientAuth :: a + , clientManager :: Manager + } + +type Content = Text +type ExternalUserName = Text + +baseMessage :: Text -> Message a -> HashMap Text Value +baseMessage e m = HM.fromList (("event", String e) : ("tags", m ^. tags . to toJSON) : catMaybes [mk externalUserName "external_user_name", mk (uuid . _Just . to Wrap) "uuid"]) + where + mk l k = preview (l . jk k) m + jk k = to (\x -> (k, toJSON x)) + + + +{- listMessages showMessage editMessage @@ -116,60 +381,39 @@ -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > import Chat.Flowdock --- > +-- > -- > -- The push API uses the 'Push' authentication type -- > main = withFlowdockClient (Push "YOUR_FLOW_TOKEN_HERE") $ \client -> do -- > let msg = newChatPushMessage "Hello World Bot" "Hello, world!" -- > pushToChat client msg -- > -data JSONError = JSONError String - deriving (Show, Typeable) +decodeAesonStream br = do + mr <- (eitherDecode . fromChunks) <$> brConsume br + case mr of + Left e -> throw $ JSONError e + Right r -> return r -instance Exception JSONError +withFlowdockClient :: ClientManagerSettings auth => auth -> (FlowdockClient auth -> IO a) -> IO a +withFlowdockClient a f = withManager (managerSettings a) $ \m -> f (FlowdockClient a m) -addPath :: ByteString -> Request -> Request -addPath p r = r { path = path r <> p } +sendMessage :: MessageType a => FlowdockClient User -> Message a -> IO (MessageResponse a) +sendMessage (FlowdockClient (User token) man) m = do + let req = applyBasicAuth (encodeUtf8 token) "" $ (addPath ("flows/" <> (m ^. flow . organization . to encodeUtf8) <> "/" <> (m ^. flow . flow . to encodeUtf8) <> "/messages") flowdockRestBaseRequest) + { method = "POST" + , requestBody = RequestBodyLBS $ encode $ messageJSON m + } + withResponse req man (decodeAesonStream . responseBody) -flowdockApiBaseRequest = let (Just r) = parseUrl "https://api.flowdock.com/v1/" in r { requestHeaders = ("Content-Type", "application/json") : requestHeaders r } +sendComment :: FlowdockClient User -> Message Comment -> IO (MessageResponse Comment) +sendComment (FlowdockClient (User token) man) m = do + let req = applyBasicAuth (encodeUtf8 token) "" $ (addPath ("flows/" <> (m ^. flow . organization . to encodeUtf8) <> "/" <> (m ^. flow . flow . to encodeUtf8) <> "/messages/" <> (m ^. event . messageId . to (\(MessageId i) -> BC.pack (show i))) <> "/comments") flowdockRestBaseRequest) + { method = "POST" + , requestBody = RequestBodyLBS $ encode m + } + withResponse req man (decodeAesonStream . responseBody) --- Push API -newtype Push = Push { pushFlowApiToken :: Text } -data FlowdockClient a = FlowdockClient - { clientAuth :: a - , clientManager :: Manager - } - -withFlowdockClient :: auth -> (FlowdockClient auth -> IO a) -> IO a -withFlowdockClient a f = withManager tlsManagerSettings $ \m -> f (FlowdockClient a m) - -data InboxPushFormat = Html - deriving (Read, Show) - -instance ToJSON InboxPushFormat where - toJSON = const $ String "html" - -data Tag = UserTag Text | HashTag Text - deriving (Read, Show) - -instance ToJSON Tag where - toJSON (UserTag t) = String ("@" <> t) - toJSON (HashTag t) = String ("#" <> t) - -data InboxPushMessage = InboxPushMessage - { _ipSource :: Text - , _ipFromAddress :: Text - , _ipSubject :: Text - , _ipContent :: Text - , _ipFromName :: Maybe Text - , _ipReplyTo :: Maybe Text - , _ipProject :: Maybe Text - , _ipFormat :: Maybe InboxPushFormat - , _ipTags :: Maybe [Tag] - , _ipLink :: Maybe Text - } deriving (Read, Show) - newInboxPushMessage = InboxPushMessage "" "" "" "" Nothing Nothing Nothing (Just Html) Nothing Nothing makeFields ''InboxPushMessage @@ -178,39 +422,87 @@ pushToInbox :: FlowdockClient Push -> InboxPushMessage -> IO () pushToInbox (FlowdockClient (Push token) man) msg = do -- post $ encode $ Authenticated t m - let req = (addPath ("messages/team_inbox/" <> encodeUtf8 token) flowdockApiBaseRequest) + let req = (addPath ("messages/team_inbox/" <> encodeUtf8 token) flowdockPushBaseRequest) { method = "POST" , requestBody = RequestBodyLBS $ encode msg } withResponse req man $ \_ -> return () -data ChatPushMessage = ChatPushMessage - { _cpContent :: Text - , _cpExternalUserName :: Text - , _cpTags :: Maybe [Tag] - , _cpMessageId :: Maybe Text - } deriving (Read, Show) - makeFields ''ChatPushMessage jsonizeToSnake ''ChatPushMessage -type Content = Text -type ExternalUserName = Text - newChatPushMessage :: ExternalUserName -> Content -> ChatPushMessage newChatPushMessage eun c = ChatPushMessage c eun Nothing Nothing pushToChat :: FlowdockClient Push -> ChatPushMessage -> IO () pushToChat (FlowdockClient (Push token) man) msg = do -- post $ encode $ Authenticated t m - let req = (addPath ("messages/chat/" <> encodeUtf8 token) flowdockApiBaseRequest) + let req = (addPath ("messages/chat/" <> encodeUtf8 token) flowdockPushBaseRequest) { method = "POST" , requestBody = RequestBodyLBS $ encode msg } withResponse req man $ \_ -> return () -- Streaming API -{- -streamFlows -streamFlow --} +streamQueryString :: StreamParams a => StreamQuery a -> [(ByteString, Maybe ByteString)] +streamQueryString q = streamParams (q ^. source) ++ catMaybes [aq, uq] + where + aq = do + a <- q ^. active + return $ if a + then ("active", Just "true") + else ("active", Just "idle") + uq = case q ^. user of + Nothing -> Nothing + Just u -> if u then Just ("user", Just "1") else Nothing + +allFlows :: FlowFilter +allFlows = FlowFilter Nothing + +justFlows :: [Flow] -> FlowFilter +justFlows = FlowFilter . Just + +streamOptions :: a -> StreamQuery a +streamOptions x = StreamQuery x Nothing Nothing + +streamFlow :: FlowdockClient User -> StreamQuery Flow -> (Producer Event IO () -> IO a) -> IO a +streamFlow (FlowdockClient (User token) man) q cb = do + let req = applyBasicAuth (encodeUtf8 token) "" $ addPath ("flows/" <> org <> "/" <> flow) flowdockStreamBaseRequest + withHTTP req man $ \r -> do + let responseStream = responseBody r + cb $ streamJSON responseStream + where + org = encodeUtf8 $ _qfOrganization $ _sqSource q + flow = encodeUtf8 $ _qfFlow $ _sqSource q + +streamFlows :: FlowdockClient User -> StreamQuery FlowFilter -> (Producer Event IO () -> IO a) -> IO a +streamFlows (FlowdockClient (User token) man) q cb = do + let req = setQueryString (streamQueryString q) $ applyBasicAuth (encodeUtf8 token) "" $ addPath "flows" flowdockStreamBaseRequest + withHTTP req man $ \r -> do + let responseStream = responseBody r + cb $ streamJSON responseStream + +parseJSONStream :: Monad m => Parser ByteString m (Maybe (Either A.DecodingError Object)) +parseJSONStream = do + mStr <- draw + case mStr of + Nothing -> return () + Just str -> unDraw $ BC.dropWhile (== '\n') str + A.decode + +streamJSON :: MonadIO m => Producer ByteString m () -> Producer Object m () +streamJSON = go + where + go p = do + (r, p') <- lift $ runStateT parseJSONStream p + case r of + Nothing -> return () + Just v -> do + case v of + Left err -> liftIO $ putStrLn ("Decoding error: " ++ show err) + Right ok -> yield ok + go p' + + +getParentMessageId :: MessageResponse Comment -> MessageId +getParentMessageId = undefined diff --git a/src/Chat/Flowdock/Internal.hs b/src/Chat/Flowdock/Internal.hs --- a/src/Chat/Flowdock/Internal.hs +++ b/src/Chat/Flowdock/Internal.hs @@ -3,23 +3,28 @@ import Control.Lens import Data.Aeson.TH import Data.Char -import Data.Maybe import Language.Haskell.TH.Syntax (Q, Name, Dec) +adjustNames :: String -> String +adjustNames = snakeCase . dropWhile (not . isUpper) + jsonize :: Name -> Q [Dec] -jsonize = deriveJSON (defaultOptions { fieldLabelModifier = \x -> let (FieldRules _ _ f _) = defaultFieldRules in fromMaybe x $ f x +jsonize = deriveJSON (defaultOptions { fieldLabelModifier = adjustNames , omitNothingFields = True }) jsonizeAll :: (Traversable t) => MonadicFold Q (t Name) [Dec] jsonizeAll = traverse . act jsonize +snakeCase :: String -> String snakeCase (a:b:c) | isAlpha a, isUpper b = a : '_' : snakeCase (toLower b : c) snakeCase (a:b) = a : snakeCase b snakeCase x = x -jsonizeSnake = deriveJSON (defaultOptions { fieldLabelModifier = \x -> let (FieldRules _ _ f _) = defaultFieldRules in maybe (snakeCase x) snakeCase $ f x +jsonizeSnake :: Name -> Q [Dec] +jsonizeSnake = deriveJSON (defaultOptions { fieldLabelModifier = adjustNames , omitNothingFields = True }) -jsonizeToSnake = deriveToJSON (defaultOptions { fieldLabelModifier = \x -> let (FieldRules _ _ f _) = defaultFieldRules in maybe (snakeCase x) snakeCase $ f x +jsonizeToSnake :: Name -> Q [Dec] +jsonizeToSnake = deriveToJSON (defaultOptions { fieldLabelModifier = adjustNames , omitNothingFields = True })