Push.hs

-- |
-- Module       : Flowdock.Push
-- License      : MIT License
-- Maintainer   : Gabriel McArthur <gabriel.mcarthur@gmail.com>
-- 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'