diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2013 Gabriel McArthur + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/flowdock-api.cabal b/flowdock-api.cabal new file mode 100644 --- /dev/null +++ b/flowdock-api.cabal @@ -0,0 +1,171 @@ +-- Initial flowdock-api.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: flowdock-api +version: 0.1.0.0 +synopsis: API integration with Flowdock. +homepage: https://github.com/gabemc/flowdock-api +license: MIT +license-file: LICENSE +author: Gabriel McArthur +maintainer: gabriel.mcarthur@gmail.com +copyright: Gabriel McArthur 2013 +category: Network +build-type: Simple +cabal-version: >=1.10 + +description: This library uses the Network.HTTP.Client library to interact + with the FlowDock chat service. + . + * Push API - + . + * Streaming API - + . + * REST API - + +-- extra-source-files: + +source-repository head + type: git + location: git://github.com/gabemc/flowdock-api.git + +executable flowdock + default-language: Haskell2010 + hs-source-dirs: src + main-is: Main.hs + ghc-options: + -Wall + -fwarn-tabs + -funbox-strict-fields + -rtsopts + -threaded + -with-rtsopts=-N + default-extensions: + DeriveGeneric + , GeneralizedNewtypeDeriving + , OverloadedStrings + , TemplateHaskell + , RecordWildCards + , RankNTypes + , FlexibleContexts + , DeriveDataTypeable + , PatternGuards + , Arrows + , CPP + build-depends: + base >=4 && < 5 + , aeson + , base64-bytestring + , blaze-builder + , bytestring + , data-default + , directory + , filepath + , HsOpenSSL + , http-streams + , http-types + , io-streams + , MonadCatchIO-transformers + , optparse-applicative + , split + , text + , time + , transformers + , unordered-containers + , vector + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: + -Wall + -fwarn-tabs + -funbox-strict-fields + -rtsopts + -with-rtsopts=-N + default-extensions: + DeriveGeneric + , GeneralizedNewtypeDeriving + , OverloadedStrings + , TemplateHaskell + , RecordWildCards + , RankNTypes + , FlexibleContexts + , DeriveDataTypeable + , PatternGuards + + exposed-modules: + Flowdock + , Flowdock.MessageTypes + , Flowdock.Push + , Flowdock.REST.Flow + , Flowdock.REST.User + , Flowdock.REST.Organization + , Flowdock.REST.Invitation + , Flowdock.REST.Source + + other-modules: + Flowdock.Internal + + -- other-extensions: + build-depends: + base >=4 && < 5 + , aeson + , base64-bytestring + , blaze-builder + , bytestring + , data-default + , HsOpenSSL + , http-streams + , http-types + , io-streams + , MonadCatchIO-transformers + , monad-logger + , text + , time + , transformers + , unordered-containers + , vector + +test-suite spec + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: Spec.hs + hs-source-dirs: specs,src + ghc-options: -Wall + default-extensions: + DeriveGeneric + , GeneralizedNewtypeDeriving + , OverloadedStrings + , TemplateHaskell + , RecordWildCards + , RankNTypes + , FlexibleContexts + , DeriveDataTypeable + , PatternGuards + , QuasiQuotes + + build-depends: + -- Library + base >=4 && < 5 + , aeson + , base64-bytestring + , blaze-builder + , bytestring + , data-default + , HsOpenSSL + , http-streams + , http-types + , io-streams + , MonadCatchIO-transformers + , monad-logger + , text + , time + , transformers + , unordered-containers + , vector + + -- Tests + , heredoc + , hspec + , template-haskell diff --git a/specs/Spec.hs b/specs/Spec.hs new file mode 100644 --- /dev/null +++ b/specs/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/Flowdock.hs b/src/Flowdock.hs new file mode 100644 --- /dev/null +++ b/src/Flowdock.hs @@ -0,0 +1,4 @@ +module Flowdock where + +version :: String +version = "0.1.0" diff --git a/src/Flowdock/Internal.hs b/src/Flowdock/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Flowdock/Internal.hs @@ -0,0 +1,70 @@ +-- | +-- Module : Flowdock.Internal +-- License : MIT License +-- Maintainer : Gabriel McArthur +-- Stability : experimental +-- Portability : portable + +module Flowdock.Internal + ( createUrl + , underscoreCase + , picosecondsToUTCTime + ) where + +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char.Utf8 +import Data.ByteString (ByteString) +import Data.Char (isUpper, toLower) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (UTCTime, NominalDiffTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Maybe +import Data.Monoid +import Network.HTTP.Types.URI + +-- | Create a URL from a base URL and a list of relative paths, returning +-- the full URL +createUrl :: [Text] -- ^ Relative paths + -> [(Text, Text)] -- ^ Query parameters + -> ByteString +createUrl relativePaths params = toByteString $ + if null params + then path + else path <> queryString + where + stripSlashes txt = txt'' + where + txt' = if "/" `Text.isSuffixOf` txt + then fromJust $ Text.stripSuffix "/" txt + else txt + txt'' = if "/" `Text.isPrefixOf` txt' + then fromJust $ Text.stripPrefix "/" txt' + else txt' + + path = foldr ((\p acc -> fromText "/" <> p <> acc) . fromText . stripSlashes) mempty relativePaths + + paramToQuery (k,v) = let k' = encodeUtf8 k in + if Text.null v + then (k', Nothing) + else (k', Just $ encodeUtf8 v) + + queryString = renderQueryBuilder True $ map paramToQuery params + +underscoreCase :: String -> String +underscoreCase = underscoreCase' True + where + underscoreCase' _ [] = [] + underscoreCase' prev (x : xs) = if isUpper x + then if prev + then toLower x : underscoreCase' True xs + else '_' : toLower x : underscoreCase' True xs + else x : underscoreCase' False xs + +-- | Turns picoseconds into UTCTime +picosecondsToUTCTime :: Integer -> UTCTime +picosecondsToUTCTime pico = posixSecondsToUTCTime posixSeconds + where + posixSeconds :: NominalDiffTime + posixSeconds = fromInteger $ pico `div` (1000000 :: Integer) diff --git a/src/Flowdock/MessageTypes.hs b/src/Flowdock/MessageTypes.hs new file mode 100644 --- /dev/null +++ b/src/Flowdock/MessageTypes.hs @@ -0,0 +1,152 @@ +module Flowdock.MessageTypes where + +import Control.Applicative +import Control.Monad +import Data.Aeson +import Data.Int +import Data.Text (Text) + +-- ----------------------------------------------------------------------------- +-- Deserialized Data Types + +data EventAction = AddPeople { people :: !Text } + | Joined + | Block { userId :: !Text } + | Invite { emails :: !Text } + | Decline { emails :: !Text } + | Uninvite { emails :: !Text } + | AddRssFeed { url :: !Text } + | RemoveRssFeed { url :: !Text } + | AddTwitterFollower { twitterUser :: !Text } + | RemoveTwitterFollower { twitterFollower :: !Text } + | AddTwitterSearch { twitterTerm :: !Text } + | RemoveTwitterSearch { twitterTerm :: !Text } + deriving (Eq, Show) + +instance FromJSON EventAction where + parseJSON (Object o) = do + actionType <- o .: "type" + case (actionType :: Text) of + "add_people" -> AddPeople <$> o .: "description" + "join" -> return Joined + "block" -> Block <$> o .: "description" + "invite" -> Invite <$> o .: "descrption" + "decline" -> Decline <$> o .: "description" + "uninvite" -> Uninvite <$> o .: "description" + "add_rss_feed" -> AddRssFeed <$> o .: "description" + "remove_rss_feed" -> RemoveRssFeed <$> o .: "decription" + "add_twitter_follower" -> AddTwitterFollower <$> o .: "description" + "remove_twitter_follower" -> RemoveTwitterFollower <$> o .: "description" + "add_twitter_search" -> AddTwitterSearch <$> o .: "description" + "remove_twitter_search" -> RemoveTwitterSearch <$> o .: "description" + _ -> mzero + parseJSON _ = mzero + +data ImageDetails = ImageDetails { imageHeight :: !Int, imageWidth :: !Int } deriving (Eq, Show) + +instance FromJSON ImageDetails where + parseJSON (Object o) = ImageDetails <$> o .: "height" <*> o .: "width" + parseJSON _ = mzero + +data Thumbnail = Thumbnail { thumbnailHeight :: !Int, thumbnailWidth :: !Int, path :: !Text } deriving (Eq, Show) + +instance FromJSON Thumbnail where + parseJSON (Object o) = Thumbnail <$> o .: "height" <*> o .: "width" <*> o .: "path" + parseJSON _ = mzero + +data Attachment = Attachment + { attachmentID :: !(Maybe Text) + , attachmentContentType :: !Text + , attachmentFileName :: !Text + , attachmentFileSize :: !Int + , attachmentFilePath :: !Text + } + deriving (Eq, Show) + +instance FromJSON Attachment where + parseJSON (Object o) = do + cid <- o .:? "content_id" + ctype <- o .: "content_type" + fname <- o .: "file_name" + fsize <- o .: "file_size" + fpath <- o .: "path" + return $ Attachment cid ctype fname fsize fpath + parseJSON _ = mzero + +data EventType = Message { content :: !Text } + | Status { content :: !Text } + | Comment { title :: !Text + , text :: !Text } + | Action !EventAction + | TagChange { messageID :: !Int + , addedTags :: ![Text] + , removedTags :: ![Text] } + | MessageEdit { messageID :: !Int + , updatedContent :: !Text } + | UserActivity { lastActivity :: !Int64 } + | File { filePath :: !Text + , fileName :: !Text + , fileSize :: !Int + , contentType :: !Text + , imageDetails :: !(Maybe ImageDetails) + , thumbnail :: !(Maybe Thumbnail) + } + deriving (Eq, Show) + +instance FromJSON EventType where + parseJSON (Object o) = do + eventType <- o .: "event" + case (eventType :: Text) of + "message" -> Message <$> o .: "content" + "status" -> Status <$> o .: "content" + "comment" -> do + cnt <- o .: "content" + Comment <$> cnt .: "title" <*> cnt .: "text" + "action" -> do + ob <- o .: "content" + Action <$> parseJSON ob + "tag-change" -> do + cnt <- o .: "content" + TagChange <$> cnt .: "message" <*> cnt .: "add" <*> cnt .: "remove" + "message-edit" -> do + cnt <- o .: "content" + MessageEdit <$> cnt .: "message" <*> cnt .: "updated_content" + "activity.user" -> do + cnt <- o .: "content" + UserActivity <$> cnt .: "last_activity" + "file" -> do + cnt <- o .: "content" + File <$> cnt .: "path" + <*> cnt .: "file_name" + <*> cnt .: "file_size" + <*> cnt .: "content_type" + <*> cnt .:? "image" + <*> cnt .:? "thumbnail" + _ -> mzero + parseJSON _ = error "4" + +data Event = Event + { eventID :: !Int + , eventApp :: !(Maybe Text) + , eventTags :: ![Text] + , eventUuid :: !(Maybe Text) + , eventFlow :: !Text + , eventSent :: !Int64 + , eventAttachments :: ![Attachment] + , eventUser :: !Text + , eventType :: !EventType + } + deriving (Eq, Show) + +instance FromJSON Event where + parseJSON obj@(Object o) = do + eid <- o .: "id" + app <- o .:? "app" + tags <- o .: "tags" + uuid <- o .:? "uuid" + flow <- o .: "flow" + att <- o .: "attachments" + sent <- o .: "sent" + user <- o .: "user" + Event eid app tags uuid flow sent att user <$> parseJSON obj + parseJSON _ = mzero diff --git a/src/Flowdock/Push.hs b/src/Flowdock/Push.hs new file mode 100644 --- /dev/null +++ b/src/Flowdock/Push.hs @@ -0,0 +1,189 @@ +-- | +-- Module : Flowdock.Push +-- License : MIT License +-- Maintainer : Gabriel McArthur +-- Stability : experimental +-- Portability : portable +-- +-- This is a module for interacting with the Push API of Flowdock. +-- +-- Example usage, by sending a chat message to another user might be, +-- in the IO monad: +-- +-- > let chat = Chat { chatContent = "Hey, how are you?", +-- > , externalUserName = "ian" +-- > , chatTags = Nothing } +-- > let auth = PushApiToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" +-- > pushAPI conn $ do +-- > push chat +-- +-- If you happen to be in a monad that implements MonadIO, MonadLogger, +-- and MonadBaseControl IO (as in Yesod), you can also use +-- `runPushApiT` or `runPushApiLogging`. + +module Flowdock.Push + ( + -- * Types of messages + PushEvent(..) + + -- * Authentication + , PushApiToken(..) + , mkApiToken + + -- * Monad Transformers + , PushAPI + , pushAPI + + -- * Sending messages + , push + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.CatchIO +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Monad.Trans.Reader +import Data.Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Char (isHexDigit) +import Data.Maybe +import Data.Text (Text,unpack) +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8) +import Network.Http.Client +import OpenSSL (withOpenSSL) +import System.IO.Streams (InputStream) +import qualified System.IO.Streams as Streams + +import Flowdock.Internal + +-- ----------------------------------------------------------------------------- +-- Push Events + +data PushEvent + -- | A kind of message that is sent to a team inbox. + = TeamInbox + -- Required + { source :: !Text -- ^ Human-readable name of the application that uses Flowdock + , fromAddress :: !Text -- ^ Email address of the message sender + , subject :: !Text -- ^ Subject line of the message + , inboxContent :: !Text -- ^ HTML-like body content + -- Optional + , fromName :: !(Maybe Text) -- ^ The name of the message sender. + , replyTo :: !(Maybe Text) -- ^ The email address for replies to the message + , project :: !(Maybe Text) -- ^ Project for message categorization + , inboxTags :: !(Maybe [Text]) -- ^ A list of tags + , link :: !(Maybe Text) -- ^ Link associated with the message + } + -- | A kind of message that is sent to another user. + | Chat + { chatContent :: !Text -- ^ Content of message. + , chatUserName :: !Text -- ^ The external user. + , chatTags :: !(Maybe [Text]) -- ^ Optional tags to add to the message. + } deriving (Show, Eq) + +instance ToJSON PushEvent where + toJSON TeamInbox{..} = + object $ catMaybes [ Just $ "source" .= source + , Just $ "from_address" .= fromAddress + , Just $ "subject" .= subject + , Just $ "content" .= inboxContent + , ("from_name" .=) <$> fromName + , ("reply_to" .=) <$> replyTo + , ("content" .=) <$> project + , ("tags" .=) <$> inboxTags + , ("link" .=) <$> link + ] + toJSON Chat{..} = + object $ catMaybes [ Just $ "content" .= chatContent + , Just $ "external_user_name" .= chatUserName + , ("tags" .=) <$> chatTags + ] + +-- To get the relative URLs from the types of messages +class RelativeUrl a where + getRelativeUrl :: a -> Text + +instance RelativeUrl PushEvent where + getRelativeUrl TeamInbox{..} = "/v1/messages/team_inbox/" + getRelativeUrl Chat{..} = "/v1/messages/chat/" + +-- ----------------------------------------------------------------------------- +-- API Tokens + +-- | Flowdock tokens are 32 character hexadecimal digits. +newtype PushApiToken = PushApiToken {pushApiToken :: Text} + deriving (Eq, Show) + +-- | Parses some text into a possible Api token +mkApiToken :: Text -> Maybe PushApiToken +mkApiToken txt = + if rightLength && allHex + then Just $ PushApiToken txt + else Nothing + where + allHex = Text.all isHexDigit txt + rightLength = Text.length txt == 32 + +-- ----------------------------------------------------------------------------- +-- PushApi Requests + +data Env = Env + { apiToken :: !PushApiToken -- ^ The API token to access the server + } + +data Error + = Internal String + | External Text + +instance Show Error where + show (Internal str) = "Inernal Error: " ++ str + show (External txt) = "Exteranal Error: " ++ unpack txt + +-- ----------------------------------------------------------------------------- +-- PushApi Requests + +newtype PushAPI a = PushAPI { unwrap :: ReaderT Env IO a } + deriving (Applicative, Functor, Monad, MonadIO, MonadCatchIO, MonadPlus) + +pushAPI :: MonadIO m => PushApiToken -> PushAPI a => m a +pushAPI token api = liftIO $ runReaderT (unwrap api) conn + where + conn = Env token + +push :: PushEvent + -> PushAPI (Maybe Error) +push event = PushAPI $ do + Env{..} <- ask + liftIO $ withOpenSSL $ + bracket (open "api.flowdock.com") closeConnection (request apiToken) + where + open host = do + ctx <- baselineContextSSL + openConnectionSSL ctx host 443 + + request apiToken conn = do + enc <- Streams.fromLazyByteString $ encode event + req <- buildRequest $ do + http POST $ createUrl [getRelativeUrl event, pushApiToken apiToken] [] + setAccept "application/json" + setContentType "application/json" + sendRequest conn req $ inputStreamBody enc + receiveResponse conn response + +-- ----------------------------------------------------------------------------- +-- Internal + +response :: Response -> InputStream ByteString -> IO (Maybe Error) +response resp body = + case getStatusCode resp of + 200 -> return Nothing + 201 -> return Nothing + 400 -> failure + 500 -> failure + n -> return $ Just $ Internal $ "Flowdock returned a bad status code: " ++ show n + where + failure = do + body' <- BS.concat <$> Streams.toList body + return $ Just $ External $ decodeUtf8 body' diff --git a/src/Flowdock/REST/Flow.hs b/src/Flowdock/REST/Flow.hs new file mode 100644 --- /dev/null +++ b/src/Flowdock/REST/Flow.hs @@ -0,0 +1,178 @@ +module Flowdock.REST.Flow + ( + -- | Fetch data types + Flow(..) + , FlowOrganization(..) + , FlowAccessMode(..) + , Flows(..) + + -- | Update data types + , CreateFlow(..) + , FlowUpdate(..) + + -- | Flow API calls + , listFlows + , listAllFlows + , getFlow + , getFlowById + , createFlow + , updateFlow + ) where + +import Control.Monad +import Data.Aeson +import Data.Aeson.TH +import Data.Aeson.Types +import Data.Char (toLower) +import Data.Text (Text, pack) +import Data.Vector (toList) +import GHC.Generics +import Network.Http.Client (Method(..)) + +import Flowdock.Internal +import Flowdock.REST +import Flowdock.REST.User + +-- ----------------------------------------------------------------------------- +-- Deserialized Data Types + +-- | The organization associated with a flow. +data FlowOrganization = FlowOrganization + { organizationId :: !Int + , organizationName :: !Text + , organizationParamaterizedName :: !Text + , userLimit :: !Int + , userCount :: !Int + , organizationActive :: !Bool + , organizationUrl :: !Text + } deriving(Show, Eq) + +instance FromJSON FlowOrganization where + parseJSON (Object o) = do + oid <- o .: "id" + name <- o .: "name" + paramaterized_name <- o .: "parameterized_name" + user_limit <- o .: "user_limit" + user_count <- o .: "user_count" + active <- o .: "active" + url <- o .: "url" + return $ FlowOrganization oid name paramaterized_name user_limit user_count active url + parseJSON _ = mzero + +-- $(deriveFromJSON defaultOptions{fieldLabelModifier = flowOrganizationFromJSON} ''FlowOrganization) + +data FlowAccessMode + = Invitation + | Link + | Organization + deriving (Generic, Show, Eq) + +instance FromJSON FlowAccessMode where + -- parseJSON = genericParseJSON defaultOptions { constructorTagModifier = map toLower } + parseJSON (String s) + | s == "invitation" = return Invitation + | s == "link" = return Link + | s == "organization" = return Organization + parseJSON _ = mzero + +$(deriveToJSON defaultOptions{constructorTagModifier = Prelude.map toLower} ''FlowAccessMode) + +data Flow = Flow + { flowId :: !Text -- ^ The flow ID + , flowName :: !Text -- ^ Human readable name of the flow + , flowParameterizedName :: !Text -- ^ flow name for URLs (I think) + , flowOrganization :: !FlowOrganization -- ^ Organization information + , flowUnreadMentions :: !Int + , flowOpen :: !Bool + , flowJoined :: !Bool + , flowUrl :: !Text + , flowWebUrl :: !Text + , flowJoinUrl :: !(Maybe Text) + , flowAccessMode :: !FlowAccessMode + , flowUsers :: !(Maybe [User]) + } deriving(Show, Eq) + +instance FromJSON Flow where + parseJSON (Object o) = do + fid <- o .: "id" + name <- o .: "name" + paramaterized_name <- o .: "parameterized_name" + organization <- o .: "organization" + unread_mentions <- o .: "unread_mentions" + open <- o .: "open" + joined <- o .: "joined" + url <- o .: "url" + web_url <- o .: "web_url" + join_url <- o .:? "join_url" + access_mode <- o .: "access_mode" + users <- o .:? "users" + return $ Flow fid name paramaterized_name organization unread_mentions open joined url web_url join_url access_mode users + parseJSON _ = mzero + +-- $(deriveFromJSON defaultOptions{fieldLabelModifier = camelToUnderscoreDrop 4} ''Flow) + +newtype Flows = Flows { flows :: [Flow] } deriving(Show, Eq) + +instance FromJSON Flows where + parseJSON (Array as) = do + flows <- mapM parseJSON $ toList as :: Parser [Flow] + return $ Flows flows + parseJSON _ = mzero + +-- ----------------------------------------------------------------------------- +-- Serialized Data Types + +data CreateFlow = CreateFlow !Text deriving (Show, Eq) + +instance ToJSON CreateFlow where + toJSON (CreateFlow name) = object [ "name" .= name ] + +data FlowUpdate = FlowUpdate + { flowUpdateName :: !Text + , flowUpdateOpen :: !Bool + , flowUpdateDisabled :: !Bool + , flowUpdateAccessMode :: !FlowAccessMode + } deriving (Show, Eq) + +$(deriveToJSON defaultOptions{fieldLabelModifier = underscoreCase . drop 10} ''FlowUpdate) + +-- ----------------------------------------------------------------------------- +-- API Calls + +includeUsers :: Bool -> Text +includeUsers True = "1" +includeUsers False = "0" + +listFlows :: Bool -- ^ Whether to list the included users + -> RestAPI (Either Error Flows) +listFlows user = + request GET ["flows"] [("users", includeUsers user)] Nothing + +listAllFlows :: Bool -- ^ Whether to list the included users + -> RestAPI (Either Error Flows) +listAllFlows user = + request GET ["flows", "all"] [("users", includeUsers user)] Nothing + +getFlow :: Text -- ^ The paramaterized name of the organization + -> Text -- ^ The parameterized name of the flow + -> RestAPI (Either Error Flow) +getFlow organization flow = + request GET ["flows", organization, flow] [] Nothing + +getFlowById :: Int -- ^ The ID of the flow + -> RestAPI (Either Error Flow) +getFlowById fid = + request GET ["flows", "find"] [("id", pack $ show fid)] Nothing + +createFlow :: Text -- ^ The paramaterized name of the organization + -> CreateFlow -- ^ The name to create + -> RestAPI (Either Error Flow) +createFlow organization cf = + request POST ["flows", organization] [] (Just $ encode cf) + +updateFlow :: Text -- ^ The paramaterized name of the organization + -> Text -- ^ The paramaterized name of the flow + -> FlowUpdate -- ^ The command to update the flow + -> RestAPI (Either Error Flow) +updateFlow organization flow fu = + request PUT ["flows", organization, flow] [] (Just $ encode fu) diff --git a/src/Flowdock/REST/Invitation.hs b/src/Flowdock/REST/Invitation.hs new file mode 100644 --- /dev/null +++ b/src/Flowdock/REST/Invitation.hs @@ -0,0 +1,136 @@ +module Flowdock.REST.Invitation + ( + -- * Types + Invitation(..) + , Invitations(..) + , InvitationState(..) + , ImportAddressMessage(..) + , ImportAddressResponse(..) + , CreateInvitation(..) + + -- * API + , listInvitations + , getInvitation + , createInvitation + , importAddressList + , deleteInvitation + ) where + +import Control.Monad +import Data.Aeson +import Data.Aeson.TH +import Data.Aeson.Types +import Data.Text (Text, pack) +import Data.Vector (toList) +import Network.Http.Client (Method(..)) + +import Flowdock.Internal +import Flowdock.REST +import Flowdock.REST.User + +-- ----------------------------------------------------------------------------- +-- Deserialized Types + +data InvitationState = Pending | Accepted deriving (Eq, Show) + +instance FromJSON InvitationState where + parseJSON (String s) = + case s of + "pending" -> return Pending + "accepted" -> return Accepted + _ -> mzero + parseJSON _ = mzero + +data Invitation = Invitation + { invitationID :: !Int + , invitationState :: !InvitationState + , invitationEmail :: !Text + , flowResource :: !Text + , invitationURL :: !Text + } deriving (Eq, Show) + +instance FromJSON Invitation where + parseJSON (Object o) = do + iid <- o .: "id" + state <- o .: "state" + email <- o .: "email" + flow <- o .: "flow" + url <- o .: "url" + return $ Invitation iid state email flow url + parseJSON _ = mzero + +newtype Invitations = Invitations { invitations :: [Invitation] } deriving (Show, Eq) + +instance FromJSON Invitations where + parseJSON (Array as) = do + invitations <- mapM parseJSON $ toList as :: Parser [Invitation] + return $ Invitations invitations + parseJSON _ = mzero + +data ImportAddressResponse = ImportAddressResponse + { importInvitations :: ![Invitation] + , importAddedUsers :: ![User] + , importErroneousEmails :: ![Object] + } deriving (Eq, Show) + +instance FromJSON ImportAddressResponse where + parseJSON (Object o) = do + invitations <- o .: "invitations" + addedUsers <- o .: "added_users" + erroneousEmails <- o .: "erroneous_emails" + return $ ImportAddressResponse invitations addedUsers erroneousEmails + parseJSON _ = mzero + +-- ----------------------------------------------------------------------------- +-- Serialized Types + +data CreateInvitation = CreateInvitation + { targetEmail :: !Text + , targetMessage :: !Text + } deriving (Eq, Show) + +$(deriveToJSON defaultOptions{fieldLabelModifier = underscoreCase . drop 6} ''CreateInvitation) + +data ImportAddressMessage = ImportAddressMessage + { addressList :: !Text + , addressMessage :: !Text + } deriving (Eq, Show) + +$(deriveToJSON defaultOptions{fieldLabelModifier = underscoreCase . drop 7} ''ImportAddressMessage) + +-- ----------------------------------------------------------------------------- +-- API Calls + +listInvitations :: Text -- ^ Organization parmaterized name + -> Text -- ^ Flow paramaterized name + -> RestAPI (Either Error Invitations) +listInvitations organization flow = + request GET ["flows", organization, flow, "invitations"] [] Nothing + +getInvitation :: Text -- ^ Organization parmaterized name + -> Text -- ^ Flow paramaterized name + -> Int -- ^ Invitation ID + -> RestAPI (Either Error Invitation) +getInvitation organization flow iid = + request GET ["flows", organization, flow, "invitations", pack $ show iid] [] Nothing + +createInvitation :: Text -- ^ Organization parmaterized name + -> Text -- ^ Flow paramaterized name + -> CreateInvitation + -> RestAPI (Either Error Invitation) +createInvitation organization flow cinv = + request POST ["flows", organization, flow, "invitations"] [] (Just $ encode cinv) + +importAddressList :: Text -- ^ Organization parmaterized name + -> Text -- ^ Flow paramaterized name + -> ImportAddressMessage -- ^ The import message + -> RestAPI (Either Error ImportAddressResponse) +importAddressList organization flow iam = + request POST ["flows", organization, flow, "invitations", "import"] [] (Just $ encode iam) + +deleteInvitation :: Text -- ^ Organization parmaterized name + -> Text -- ^ Flow paramaterized name + -> Int -- ^ Invitation ID + -> RestAPI (Either Error Success) +deleteInvitation organization flow iid = + request DELETE ["flows", organization, flow, "invitations", pack $ show iid] [] Nothing diff --git a/src/Flowdock/REST/Organization.hs b/src/Flowdock/REST/Organization.hs new file mode 100644 --- /dev/null +++ b/src/Flowdock/REST/Organization.hs @@ -0,0 +1,119 @@ +module Flowdock.REST.Organization + ( Organization(..) + , Subscription(..) + , OrganizationUser(..) + , Organizations(..) + , OrgNameUpdate(..) + + -- * API Calls + , listOrganizations + , getOrganization + , getOrganizationByID + , updateOrganization + ) where + +import Control.Monad +import Data.Aeson +import Data.Aeson.TH +import Data.Aeson.Types +import Data.Text (Text, pack) +-- import Data.Time.Clock (UTCTime) +import Data.Vector (toList) +import GHC.Generics +import Network.Http.Client (Method(..)) + +import Flowdock.REST +import Flowdock.Internal + +-- ----------------------------------------------------------------------------- +-- Deserialized Types + +data Subscription = Subscription + { trial :: !Bool + , trialEnds :: !Text -- TODO: UTCTime + } deriving (Eq, Show, Generic) + +instance FromJSON Subscription where + parseJSON = genericParseJSON $ defaultOptions { fieldLabelModifier = underscoreCase } + +data OrganizationUser = OrganizationUser + { userID :: !Int + , userName :: !Text + , userEmail :: !Text + , isAdmin :: !Bool + } deriving (Eq, Show) + +instance FromJSON OrganizationUser where + parseJSON (Object o) = do + uid <- o .: "id" + name <- o .: "name" + email <- o .: "email" + isAdmin <- o .: "admin" + return $ OrganizationUser uid name email isAdmin + parseJSON _ = mzero + +data Organization = Organization + { orgID :: !Int + , paramaterizedName :: !Text + , orgName :: !Text + , orgUserLimit :: !Int + , orgUserCount :: !Int + , orgIsActive :: !Bool + , orgURL :: !Text + , orgSubscription :: !Subscription + , orgUsers :: ![OrganizationUser] + } deriving (Eq, Show) + +instance FromJSON Organization where + parseJSON (Object o) = do + oid <- o .: "id" + paramaterizedName <- o .: "parameterized_name" + name <- o .: "name" + userLimit <- o .: "user_limit" + userCount <- o .: "user_count" + isActive <- o .: "active" + url <- o .: "url" + subscription <- o .: "subscription" + users <- o .: "users" + return $ Organization oid paramaterizedName name userLimit userCount isActive url subscription users + parseJSON _ = mzero + +newtype Organizations = Organizations { organizations :: [Organization] } deriving(Show, Eq) + +instance FromJSON Organizations where + parseJSON (Array as) = do + organizations <- mapM parseJSON $ toList as :: Parser [Organization] + return $ Organizations organizations + parseJSON _ = mzero + +-- ----------------------------------------------------------------------------- +-- Serialized Types + +data OrgNameUpdate = OrgNameUpdate + { displayName :: !Text + } deriving (Eq, Show) + +$(deriveToJSON defaultOptions{fieldLabelModifier = underscoreCase . drop 7} ''OrgNameUpdate) + +-- ----------------------------------------------------------------------------- +-- API Calls + +listOrganizations :: RestAPI (Either Error Organizations) +listOrganizations = + request GET ["organizations"] [] Nothing + +getOrganization :: Text -- ^ The paramaterized organization name + -> RestAPI (Either Error Organization) +getOrganization organization = + request GET ["organizations", organization] [] Nothing + +getOrganizationByID :: Int -- ^ The organization ID + -> RestAPI (Either Error Organization) +getOrganizationByID oid = + request GET ["organizations", "find"] [("id", pack $ show oid)] Nothing + +updateOrganization :: Text -- ^ The paramaterized organization name + -> OrgNameUpdate -- ^ The name to update it to. + -> RestAPI (Either Error Organization) +updateOrganization organization update = + request PUT ["organizations", organization] [] (Just $ encode update) diff --git a/src/Flowdock/REST/Source.hs b/src/Flowdock/REST/Source.hs new file mode 100644 --- /dev/null +++ b/src/Flowdock/REST/Source.hs @@ -0,0 +1,148 @@ +module Flowdock.REST.Source + ( + -- * Types + SourceType(..) + , Source(..) + , Sources(..) + , Feed(..) + , TwitterFollower(..) + , TwitterKeyword(..) + + -- * API calls + , listSources + , getSource + , createSource + , deleteSource + ) where + +import Control.Applicative +import Control.Monad +import Data.Aeson +import Data.Aeson.TH +import Data.Aeson.Types +import Data.Text (Text) +import Data.Vector (toList) +import Network.Http.Client (Method(..)) + +import Flowdock.Internal +import Flowdock.REST + +-- ----------------------------------------------------------------------------- +-- Deserialized Types + +data Feed = Feed { feedURL :: !Text, feedTitle :: !(Maybe Text)} + deriving (Eq, Show) + +instance FromJSON Feed where + parseJSON (Object o) = do + url <- o .: "url" + title <- o .: "title" + return $ Feed url title + parseJSON _ = mzero + +$(deriveToJSON defaultOptions{fieldLabelModifier = underscoreCase . drop 4} ''Feed) + +data TwitterKeyword = TwitterKeyword + { keywordParam :: !Text + , keywordReplies :: !Bool + , keywordRetweets :: !Bool + } deriving (Eq, Show) + +instance FromJSON TwitterKeyword where + parseJSON (Object o) = do + param <- o .: "param" + replies <- o .: "replies" + retweets <- o .: "retweets" + return $ TwitterKeyword param replies retweets + parseJSON _ = mzero + +$(deriveToJSON defaultOptions{fieldLabelModifier = underscoreCase . drop 7} ''TwitterKeyword) + +data TwitterFollower = TwitterFollower + { followerTwitterUserId :: !Text + , followerParam :: !Text + , followerName :: !Text + , followerReplies :: !Bool + , followerRetweets :: !Bool + } deriving (Eq, Show) + +instance FromJSON TwitterFollower where + parseJSON (Object o) = do + tid <- o .: "twitter_user_id" + param <- o .: "param" + name <- o .: "name" + replies <- o .: "replies" + retweets <- o .: "retweets" + return $ TwitterFollower tid param name replies retweets + parseJSON _ = mzero + +$(deriveToJSON defaultOptions{fieldLabelModifier = underscoreCase . drop 8} ''TwitterFollower) + +data SourceType + = Atom Feed + | Follower TwitterFollower + | Keyword TwitterKeyword + deriving (Eq, Show) + +instance ToJSON SourceType where + toJSON (Atom feed) = object ["type" .= ("feed" :: Text), "config" .= toJSON feed] + toJSON (Follower f) = object ["type" .= ("twitter_user" :: Text), "config" .= toJSON f] + toJSON (Keyword kw) = object ["type" .= ("twitter_keyword" :: Text), "config" .= toJSON kw] + +data Source = Source + { sourceId :: !Text + , sourceType :: !SourceType + , sourceURL :: !Text + } deriving (Eq, Show) + +instance FromJSON Source where + parseJSON (Object o) = do + sid <- o .: "id" + stype <- o .: "type" + config <- + case (stype :: Text) of + "feed" -> Atom <$> o .: "config" + "twitter_keyword" -> Keyword <$> o .: "config" + "twitter_user" -> Follower <$> o .: "config" + _ -> mzero + url <- o .: "url" + return $ Source sid config url + parseJSON _ = mzero + +newtype Sources = Sources { sources :: [Source] } deriving (Eq, Show) + +instance FromJSON Sources where + parseJSON (Array as) = do + sources <- mapM parseJSON $ toList as :: Parser [Source] + return $ Sources sources + parseJSON _ = mzero + +-- ----------------------------------------------------------------------------- +-- API Calls + +listSources :: Text -- ^ Organization paramaterized name + -> Text -- ^ Flow parameterized name + -> RestAPI (Either Error Sources) +listSources organization flow = + request GET ["flows", organization, flow, "sources"] [] Nothing + +getSource :: Text -- ^ Organization paramaterized name + -> Text -- ^ Flow parameterized name + -> Text -- ^ Source ID + -> RestAPI (Either Error Source) +getSource organization flow sid = + request GET ["flows", organization, flow, "source", sid] [] Nothing + +createSource :: Text -- ^ Organization paramaterized name + -> Text -- ^ Flow parameterized name + -> SourceType -- ^ The source to create + -> RestAPI (Either Error Source) +createSource organization flow stype = + request POST ["flows", organization, flow, "sources"] [] (Just $ encode stype) + +deleteSource :: Text -- ^ Organization paramaterized name + -> Text -- ^ Flow parameterized name + -> Text -- ^ Source ID + -> RestAPI (Either Error Success) +deleteSource organization flow sid = + request DELETE ["flows", organization, flow, "source", sid] [] Nothing diff --git a/src/Flowdock/REST/User.hs b/src/Flowdock/REST/User.hs new file mode 100644 --- /dev/null +++ b/src/Flowdock/REST/User.hs @@ -0,0 +1,129 @@ +module Flowdock.REST.User + ( User(..) + , Users(..) + , UserInformation(..) + , UserStatus(..) + , UserID(..) + + -- * API functions + , getUser + , getUsers + , getFlowUsers + , updateUserInfo + , addUserToFlow + , setUserAccess + ) where + +import Control.Applicative +import Control.Monad +import Data.Aeson +import Data.Aeson.Types +import Data.Text (Text, pack) +import Data.Time.Clock (UTCTime) +import Data.Vector (toList) +import Network.Http.Client (Method(..)) + +import Flowdock.Internal +import Flowdock.REST + +-- ----------------------------------------------------------------------------- +-- Deserialized Types + +data User = User + { userId :: !Int + , userName :: !Text + , userNick :: !Text + , userEmail :: !Text + , userAvatar :: !Text + , userStatus :: !(Maybe Text) + , userDisabled :: !Bool + , userLastActivity :: !(Maybe UTCTime) + , userLastPing :: !(Maybe UTCTime) + } deriving(Show, Eq) + +instance FromJSON User where + parseJSON (Object o) = do + fid <- o .: "id" + name <- o .: "name" + nick <- o .: "nick" + email <- o .: "email" + avatar <- o .: "avatar" + status <- o .:? "status" + disabled <- o .:? "disabled" .!= False + last_activity <- o .:? "last_activity" + last_ping <- o .:? "last_ping" + return $ User fid name nick email + avatar status disabled + (picosecondsToUTCTime <$> last_activity) + (picosecondsToUTCTime <$> last_ping) + parseJSON _ = mzero + +-- $(deriveFromJSON defaultOptions{fieldLabelModifier = camelToUnderscoreDrop 4} ''FlowUser) + +newtype Users = Users { users :: [User] } deriving (Show, Eq) + +instance FromJSON Users where + parseJSON (Array as) = do + users <- mapM parseJSON $ toList as :: Parser [User] + return $ Users users + parseJSON _ = mzero + +-- ----------------------------------------------------------------------------- +-- Serialized Types + +data UserInformation = UserInformation + { nickInfo :: !Text + , emailInfo :: !Text + } deriving (Eq, Show) + +instance ToJSON UserInformation where + toJSON UserInformation{..} = object ["nick" .= nickInfo, "email" .= emailInfo] + +newtype UserID = UserID { userID :: Int } deriving (Eq, Show) + +instance ToJSON UserID where + toJSON UserID{..} = object ["id" .= userID] + +newtype UserStatus = UserStatus { isUserDisabled :: Bool } deriving (Eq, Show) + +instance ToJSON UserStatus where + toJSON UserStatus{..} = object ["disabled" .= isUserDisabled] + +-- ----------------------------------------------------------------------------- +-- API Functions + +getUser :: Int -- ^ User ID + -> RestAPI (Either Error User) +getUser uid = + request GET ["users", pack $ show uid] [] Nothing + +getUsers :: () -> RestAPI (Either Error Users) +getUsers _ = + request GET ["users"] [] Nothing + +getFlowUsers :: Text -- ^ Organization + -> Text -- ^ Flow + -> RestAPI (Either Error Users) +getFlowUsers organization flow = + request GET ["flows", organization, flow, "users"] [] Nothing + +updateUserInfo :: Int -- ^ User ID + -> UserInformation -- ^ User information to update + -> RestAPI (Either Error Success) +updateUserInfo uid userInfo = + request PUT ["users", pack $ show uid] [] (Just $ encode userInfo) + +addUserToFlow :: Text -- ^ Organization + -> Text -- ^ Flow + -> UserID + -> RestAPI (Either Error Success) +addUserToFlow organization flow userID = + request POST ["flows", organization, flow, "users"] [] (Just $ encode userID) + +setUserAccess :: Text -- ^ Organization + -> Text -- ^ Flow + -> Int -- ^ User ID + -> UserStatus + -> RestAPI (Either Error Success) +setUserAccess organization flow uid us = + request POST ["flows", organization, flow, "users", pack $ show uid] [] (Just $ encode us) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,252 @@ +module Main where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Data.Aeson +import qualified Data.ByteString.Lazy as LB +import Data.List (isPrefixOf, intercalate) +import Data.List.Split (splitOn) +import Data.Text (Text, pack) +import Options.Applicative +import Options.Applicative.Arrows +import System.Exit +import System.FilePath +import System.Directory +import System.IO + +import qualified Flowdock as Flowdock +import qualified Flowdock.Push as Push + +-- ----------------------------------------------------------------------------- +-- Option Handling + +data Args = Args GlobalOptions Command + deriving Show + +data GlobalOptions = GlobalOptions + { globalConfigFile :: !(Maybe FilePath) + } deriving Show + +data Command + = Chat ChatOptions + | Inbox InboxOptions + deriving Show + +data ChatOptions = ChatOptions + { chatUserName :: !String + , chatTags :: !(Maybe String) + , chatMessage :: !String + } deriving Show + +data InboxOptions = InboxOptions + { messageSource :: !String + , messageFrom :: !String + , messageSubject :: !String + , messageBody :: !String + , messageFromName :: !(Maybe String) + , messageReplyTo :: !(Maybe String) + , messageProject :: !(Maybe String) + , messageTags :: !(Maybe String) + , messageLink :: !(Maybe String) + } deriving Show + +version :: Parser (a -> a) +version = infoOption Flowdock.version + ( long "version" + <> help "Print the version information." ) + +parser :: Parser Args +parser = runA $ proc () -> do + opts <- asA globalOptions -< () + cmds <- (asA . hsubparser) + ( command "chat" + (info chatParser + (progDesc "Sends a chat message to another user.")) + <> command "inbox" + (info inboxParser + (progDesc "Sends a message to a team inbox."))) -< () + A version >>> A helper -< Args opts cmds + +globalOptions :: Parser GlobalOptions +globalOptions = GlobalOptions + <$> optional (strOption + ( long "config-file" + <> short 'c' + <> metavar "CONFIG" + <> help "The config file to use.")) + +chatParser :: Parser Command +chatParser = runA $ proc () -> do + config <- asA chatOptions -< () + returnA -< Chat config + +chatOptions :: Parser ChatOptions +chatOptions = ChatOptions + <$> strOption + ( long "other-user" + <> short 'u' + <> metavar "USER_NAME" + <> help "The other user to send the chat message to.") + <*> optional (strOption + ( long "tags" + <> short 't' + <> metavar "TAGS" + <> help "Tags to attach to the message, separated by commas." )) + <*> argument str (metavar "MESSAGE") + +inboxParser :: Parser Command +inboxParser = runA $ proc () -> do + config <- asA inboxOptions -< () + returnA -< Inbox config + +inboxOptions :: Parser InboxOptions +inboxOptions = InboxOptions + <$> strOption + ( long "source" + <> short 'p' + <> metavar "PROGRAM" + <> help "The source program using Flowdock." ) + <*> strOption + ( long "from" + <> short 'f' + <> metavar "EMAIL" + <> help "Email address of the message sender." ) + <*> strOption + ( long "subject" + <> short 's' + <> metavar "SUBJECT" + <> help "The subject of the message." ) + <*> argument str (metavar "CONTENT") + <*> optional (strOption + ( long "from-name" + <> short 'n' + <> metavar "NAME" + <> help "The name of the message sender." )) + <*> optional (strOption + ( long "reply-to" + <> short 'r' + <> metavar "REPLY_TO" + <> help "The email address for replies to this message." )) + <*> optional (strOption + ( long "project" + <> short 'P' + <> metavar "PROJECT" + <> help "Project for message categorization." )) + <*> optional (strOption + ( long "tags" + <> short 't' + <> metavar "TAGS" + <> help "A list of tags, separated by commas." )) + <*> optional (strOption + ( long "link" + <> short 'l' + <> metavar "LINK" + <> help "The link associated with this message." )) + +-- ----------------------------------------------------------------------------- +-- JSON Configuration + +data FlowdockConfig = FlowdockConfig + { apiToken :: Text + } deriving Show + +instance FromJSON FlowdockConfig where + parseJSON (Object o) = do + token <- o .: "api-token" + return $ FlowdockConfig token + parseJSON _ = mzero + +defaultPaths :: [FilePath] +defaultPaths = ["~/.flowdock.json", "/etc/flowdock.json"] + +expandPath :: FilePath -> IO (FilePath) +expandPath path = + if "~/" `isPrefixOf` path + then do + homeDir <- getHomeDirectory + return $ joinPath [homeDir, tail $ tail path] + else return path + +lookupConfig :: FilePath -> IO (Either String FlowdockConfig) +lookupConfig path = do + fullPath <- expandPath path + exists <- doesFileExist fullPath + if exists + then do + contents <- LB.readFile fullPath + return $ eitherDecode contents + else do + return $ Left $ "Unable to locate file: " ++ path + +findConfig :: Maybe FilePath -> IO (Either String FlowdockConfig) +findConfig (Just cf) = lookupConfig cf +findConfig Nothing = findConfig' defaultPaths + where + findConfig' :: [FilePath] -> IO (Either String FlowdockConfig) + findConfig' (f:fs) = do + config <- lookupConfig f + case config of + Left _ -> findConfig' fs + Right fc -> return $ Right fc + findConfig' [] = do + return $ Left $ "Unable to find any configuration files at: " ++ (intercalate " " defaultPaths) + +-- ----------------------------------------------------------------------------- +-- Main + +chat :: FlowdockConfig -> ChatOptions -> IO () +chat (FlowdockConfig apiToken) (ChatOptions user tags message) = do + let tags' = splitOn "," <$> tags + let msg = Push.Chat (pack message) + (pack user) + ((map pack) <$> tags') + Push.pushAPI (Push.PushApiToken apiToken) $ do + response <- Push.push msg + case response of + Nothing -> + liftIO $ exitSuccess + Just err -> do + liftIO $ hPutStrLn stderr $ show err + liftIO $ exitFailure + +inbox :: FlowdockConfig -> InboxOptions -> IO () +inbox (FlowdockConfig apiToken) (InboxOptions source from subject body name replyTo project tags link) = do + let tags' = splitOn "," <$> tags + let msg = Push.TeamInbox (pack source) + (pack from) + (pack subject) + (pack body) + (pack <$> name) + (pack <$> replyTo) + (pack <$> project) + ((map pack) <$> tags') + (pack <$> link) + Push.pushAPI (Push.PushApiToken apiToken) $ do + response <- Push.push msg + case response of + Nothing -> do + liftIO $ exitSuccess + Just err -> do + liftIO $ hPutStrLn stderr $ show err + liftIO $ exitFailure + +run :: Args -> IO () +run (Args (GlobalOptions configFile) cmd) = do + config <- findConfig configFile + case config of + Left err -> do + putStrLn err + exitFailure + Right flowdockConfig -> + case cmd of + Chat chatOpts -> chat flowdockConfig chatOpts + Inbox inboxOpts -> inbox flowdockConfig inboxOpts + +main :: IO () +main = execParser opts >>= run + where + opts = info parser + ( fullDesc + <> progDesc "Sends messages via the Flowdock API." + <> header "flowdock - a way to send messages to Flowdock.")