flowdock 0.1.0.0 → 0.2.0.0

raw patch · 3 files changed

+394/−91 lines, 3 filesdep +base64-bytestringdep +pipesdep +pipes-aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: base64-bytestring, pipes, pipes-aeson, pipes-http, pipes-parse, uuid

API changes (from Hackage documentation)

Files

• flowdock.cabal +8/−2
• src/Chat/Flowdock.hs +377/−85
• src/Chat/Flowdock/Internal.hs +9/−4

@@ -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

@@ -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

@@ -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 })