module Saas.Pushover (
PushMessage(..),
PushResponse(..),
ReceiptResponse(..),
Apptoken,
Receipt,
defaultMessage,
sendPushMessage,
checkReceipt
) where
import Control.Applicative
import Control.Exception
import Data.Aeson
import qualified Data.ByteString as BS
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (encodeUtf8)
import Data.Maybe
import Debug.Trace
import Network
import Network.HTTP.Conduit
type Apptoken = Text
type Receipt = Text
data PushMessage = PM { token :: Text
, user :: Text
, message :: Text
, device :: Text
, title :: Text
, url :: Text
, urlTitle :: Text
, priority :: Int
, timestamp :: Text
, sound :: Text
, callback :: Text
, expire :: Int
, retry :: Int
, html :: Int
} deriving (Show,Eq)
data PushResponse = PR { status :: Int
, request :: Text
, receipt :: Maybe Text
, errors :: Maybe [Text]
} deriving (Show,Eq)
instance FromJSON PushResponse where
parseJSON (Object o) = PR <$> o .: "status"
<*> o .: "request"
<*> o .:? "receipt"
<*> o .:? "errors"
parseJSON _ = fail "Unable to parse response from Pushover.net"
data ReceiptResponse = RR { receiptstatus :: Int
, acknowledged :: Int
, acknowledgedAt :: Int
, lastDeliveredAt :: Int
, expired :: Int
, expiresAt :: Int
, calledBack :: Int
, calledBackAt :: Int
} deriving (Show,Eq)
instance FromJSON ReceiptResponse where
parseJSON (Object o) = RR <$> o .: "status"
<*> o .: "acknowledged"
<*> o .: "acknowledged_at"
<*> o .: "last_delivered_at"
<*> o .: "expired"
<*> o .: "expires_at"
<*> o .: "called_back"
<*> o .: "called_back_at"
parseJSON _ = fail "Unable to parse response from Pushover.net"
defaultMessage :: PushMessage
defaultMessage = PM { token = "" --required
, user = "" --required
, message = "" --required
, device = ""
, title = ""
, url = ""
, urlTitle = ""
, priority = 0
, timestamp = ""
, sound = ""
, callback = ""
, expire = 0
, retry = 0
, html = 0
}
messageToBytestrings :: PushMessage -> [(BS.ByteString, BS.ByteString)]
messageToBytestrings pm = map (\(k, v) -> (encodeUtf8 k, encodeUtf8 v)) $ filter (\(x,y) -> y /= "")
[ ("token", token pm)
, ("user", user pm)
, ("message", message pm)
, ("device", device pm)
, ("title", title pm)
, ("url", url pm)
, ("url_title", urlTitle pm)
, ("priority", packIfNonzero $ priority pm)
, ("sound", sound pm)
, ("callback", callback pm)
, ("expire", packIfNonzero $ expire pm)
, ("retry", packIfNonzero $ retry pm)
, ("html", packIfNonzero $ html pm)
]
packIfNonzero :: Int -> Text
packIfNonzero i
| i == 0 = ""
| otherwise = pack . show $ i
sendPushMessage :: PushMessage -> IO PushResponse
sendPushMessage pm = do
initreq' <- parseUrl "https://api.pushover.net/1/messages.json"
let initreq = initreq' { checkStatus = \_ _ _-> Nothing }
resp <- withManager . httpLbs $ urlEncodedBody (messageToBytestrings pm) initreq
return . fromJust . decode . responseBody $ resp
checkReceipt :: Apptoken -> Receipt -> IO ReceiptResponse
checkReceipt at rc = do
resp <- simpleHttp $ "https://api.pushover.net/1/receipts/" ++ (unpack rc) ++ ".json?token=" ++ (unpack at)
return . fromJust . decode $ resp