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.")