module Network.Pushover.Request
(
Request (..)
, defaultRequest
, URL (..)
, Priority (..)
, NotificationSound (..)
, makeHttpRequest
) where
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import qualified Network.HTTP.Client as Http
import Network.Pushover.Message (Message, encodeMessage)
import Network.Pushover.Token
import Network.URI.Encode
endpoint = "https://api.pushover.net/1/messages.json"
data Request = Request
{ requestToken :: APIToken
, requestUserKey :: UserKey
, requestMessage :: Message
, devices :: [Text]
, title :: Maybe Text
, url :: Maybe URL
, priority :: Maybe Priority
, timestamp :: Maybe UTCTime
, notificationSound :: Maybe NotificationSound
} deriving (Show, Eq)
data URL = URL
{ urlPath :: Text
, urlTitle :: Maybe Text
} deriving (Show, Eq)
data Priority
= Lowest
| Low
| Normal
| High
| Emergency
deriving (Show, Eq)
data NotificationSound
= Pushover
| Bike
| Bugle
| CashRegister
| Classical
| Cosmic
| Falling
| Gamelan
| Incoming
| Intermission
| Magic
| Mechanical
| PianoBar
| Siren
| SpaceAlarm
| TugBoat
| AlienAlarm
| Climb
| Persistent
| Echo
| UpDown
| None
deriving (Show, Eq)
defaultRequest :: APIToken -> UserKey -> Message -> Request
defaultRequest apiToken usrKey msg =
Request { requestToken = apiToken
, requestUserKey = usrKey
, requestMessage = msg
, devices = []
, title = Nothing
, url = Nothing
, priority = Nothing
, timestamp = Nothing
, notificationSound = Nothing
}
makeHttpRequest :: Request -> IO Http.Request
makeHttpRequest pushoverRequest = do
initialRequest <- Http.parseRequest endpoint
return . Http.setQueryString (requestQueryPairs pushoverRequest)
$ initialRequest { Http.method = "POST" }
requestQueryPairs :: Request -> [(ByteString, Maybe ByteString)]
requestQueryPairs =
filter present . makePairs
where
makePairs :: Request -> [(ByteString, Maybe ByteString)]
makePairs request =
(fmap . fmap) ($ request)
[ ("token", Just . encodeToken . requestToken)
, ("user", Just . encodeToken . requestUserKey)
, ("message", Just . encodeMessage . requestMessage)
, ("device", encodeValue . T.intercalate "," . devices)
, ("title", encodeMaybe . title )
, ("url", encodeMaybe . reqUrl)
, ("url_title", encodeMaybe . reqUrlTitle)
, ("priority", fmap encodePriority . priority)
, ("timestamp", fmap encodeTimestamp . timestamp)
, ("sound", fmap encodeSound . notificationSound)
, ("html", const $ Just "1")
]
where
reqUrl req =
urlPath <$> url req
reqUrlTitle req =
url req >>= urlTitle
encodeMaybe =
fmap T.encodeUtf8
encodeValue =
Just . T.encodeUtf8
present (_, Nothing) = False
present (_, Just _) = True
encodeTimestamp :: UTCTime -> ByteString
encodeTimestamp =
B.pack . show . round . utcTimeToPOSIXSeconds
encodePriority :: Priority -> ByteString
encodePriority Emergency = "2"
encodePriority High = "1"
encodePriority Normal = "0"
encodePriority Low = "-1"
encodePriority Lowest = "-2"
encodeSound :: NotificationSound -> ByteString
encodeSound Pushover = "pushover"
encodeSound Bike = "bike"
encodeSound Bugle = "bugle"
encodeSound CashRegister = "cashregister"
encodeSound Classical = "classical"
encodeSound Cosmic = "cosmic"
encodeSound Falling = "falling"
encodeSound Gamelan = "gamelan"
encodeSound Incoming = "incoming"
encodeSound Intermission = "intermission"
encodeSound Magic = "magic"
encodeSound Mechanical = "mechanical"
encodeSound PianoBar = "pianobar"
encodeSound Siren = "siren"
encodeSound SpaceAlarm = "spacealarm"
encodeSound TugBoat = "tugboat"
encodeSound AlienAlarm = "alienalarm"
encodeSound Climb = "climb"
encodeSound Persistent = "persistent"
encodeSound Echo = "echo"
encodeSound UpDown = "updown"
encodeSound None = "none"