flowdock (empty) → 0.1.0.0

raw patch · 6 files changed

+301/−0 lines, 6 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, http-client, http-client-tls, lens, mtl, template-haskell, text, unordered-containers

Files

LICENSE +20/−0
README.md +4/−0
Setup.hs +2/−0
flowdock.cabal +34/−0
src/Chat/Flowdock.hs +216/−0
src/Chat/Flowdock/Internal.hs +25/−0

+ LICENSE view

@@ -0,0 +1,20 @@+Copyright (c) 2014 Ian Duncan++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

+ README.md view

@@ -0,0 +1,4 @@+hs-flowdock+===========++Flowdock API bindings for Haskell

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ flowdock.cabal view

@@ -0,0 +1,34 @@+-- Initial flowdock.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                flowdock+version:             0.1.0.0+synopsis:            Flowdock client library for Haskell+-- description:         +homepage:            https://github.com/brewtown/hs-flowdock+license:             MIT+license-file:        LICENSE+author:              Ian Duncan+maintainer:          ian@brewtown.co+-- copyright:           +category:            Web+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  exposed-modules:     Chat.Flowdock, Chat.Flowdock.Internal+  -- other-modules:       +  -- other-extensions:    +  build-depends:       base >=4.6 && <5,+                       aeson >= 0.8 && < 0.9,+                       lens >= 4 && < 5,+                       http-client >= 0.3 && < 0.4,+                       http-client-tls >= 0.2 && < 0.3,+                       mtl >= 2 && < 3,+                       text >= 1 && < 2,+                       bytestring >= 0.9 && < 1,+                       template-haskell,+                       unordered-containers >= 0.2 && < 0.3+  hs-source-dirs:      src+  default-language:    Haskell2010

+ src/Chat/Flowdock.hs view

@@ -0,0 +1,216 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-| A client library for the Flowdock API. Currently only implements+    the push API.+ -}+module Chat.Flowdock (+  -- * Using the client+  -- $client+  FlowdockClient,+  withFlowdockClient,+  -- ** Authentication types+  -- $auth+  Push(..),+  -- ** Pushing messages to the inbox+  pushToInbox,+  newInboxPushMessage,+  -- ** Pushing messages to the chatroom+  pushToChat,+  Content,+  ExternalUserName,+  newChatPushMessage,+  -- ** Constructing messages+  -- *** InboxPushMessage fields+  InboxPushMessage,+  source,+  fromAddress,+  subject,+  fromName,+  replyTo,+  project,+  InboxPushFormat(..),+  format,+  link,+  -- *** ChatPushMessage fields+  ChatPushMessage,+  externalUserName,+  messageId,+  -- *** Common fields+  content,+  Tag(..),+  tags,+  -- *** Exception types+  JSONError(..)+) 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 Chat.Flowdock.Internal+-- REST API+{-+listUserFlows+listAllFlows+getFlow+getFlowById+createFlow+updateFlow+sendMessage+sendComment+listMessages+showMessage+editMessage+deleteMessage+listPrivateConversations+getPrivateConversation+updatePrivateConversation+sendPrivateMessage+listPrivateMessage+showPrivateMessage+listUsers+listFlowUsers+getUser+updateUser+addUserToFlow+listOrganizations+getOrganization+getOrganizationById+updateOrganization+listSources+getSource+createSource+deleteSource+listInvitations+getInvitation+createInvitation+deleteInvitation+downloadFile+listFiles+uploadFile+-}++-- $client+--+-- The Flowdock API has different authentication mechanisms+-- for different parts of the API. Functions that depend on+-- specific authentication data are tagged with the authentication+-- type necessary to use them.+--+-- > {-# 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)++instance Exception JSONError++addPath :: ByteString -> Request -> Request+addPath p r = r { path = path r <> p }++flowdockApiBaseRequest = let (Just r) = parseUrl "https://api.flowdock.com/v1/" in r { requestHeaders = ("Content-Type", "application/json") : requestHeaders r }++-- 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+jsonizeToSnake ''InboxPushMessage++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)+              { 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)+              { method = "POST"+              , requestBody = RequestBodyLBS $ encode msg+              }+  withResponse req man $ \_ -> return ()++-- Streaming API+{-+streamFlows+streamFlow+-}

+ src/Chat/Flowdock/Internal.hs view

@@ -0,0 +1,25 @@+{-# LANGUAGE FlexibleContexts #-}+module Chat.Flowdock.Internal where+import Control.Lens+import Data.Aeson.TH+import Data.Char+import Data.Maybe+import Language.Haskell.TH.Syntax (Q, Name, Dec)++jsonize :: Name -> Q [Dec]+jsonize = deriveJSON (defaultOptions { fieldLabelModifier = \x -> let (FieldRules _ _ f _) = defaultFieldRules in fromMaybe x $ f x+                                     , omitNothingFields = True })++jsonizeAll :: (Traversable t) => MonadicFold Q (t Name) [Dec]+jsonizeAll = traverse . act jsonize++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+                                          , omitNothingFields = True })++jsonizeToSnake = deriveToJSON (defaultOptions { fieldLabelModifier = \x -> let (FieldRules _ _ f _) = defaultFieldRules in maybe (snakeCase x) snakeCase $ f x+                                              , omitNothingFields = True })+