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