Pushover.net Haskell API

Pushover.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards     #-}
-- |
-- Module      : Network.Pushover
-- Copyright   : (c) Austin Seipp 2013
-- License     : BSD3
--
-- Maintainer  : aseipp@pobox.com
-- Stability   : experimental
-- Portability : portable
--
-- This module provides a simple, type-safe API to
-- <http://pushover.net>.
--
-- Creating a push notification is easy. First create an @'Envelope'@,
-- which designates the receipient of a message:
--
-- >>> import qualified Network.Pushover as Pushover
-- >>> let env  = Pushover.envelope applicationToken userToken
-- >>> let opts = Just $ defaultOptions { sound = Gamelan }
--
-- Where @userToken@ and @applicationToken@ are your necessary API
-- tokens (see the pushover.net homepage for more details.) Note that
-- @userToken@ can also be a group token.
--
-- Afterwords, you just send a message easily with:
--
-- >>> Pushover.send e opts Normal message
--
-- to send a message with default options but a customized sound, at
-- @'Normal'@ @'Priority'@.
--
-- Use @'MessageOptions'@ to customize priority, sounds, etc. By
-- default messages are sent with a @'Normal'@ priority (respecting
-- quiet hours in the API) with the @'Pushover'@ sound.
module Main
       ( -- * Types
         Token
       , Receipt
       , Priority(..)
       , Sound(..)

         -- * Messages
       , Envelope
       , MessageOptions(..)
       , defaultOptions

         -- * Responses
       , ReceiptResponse(..)
       , PushResponse(..)

         -- * Pushing messages
       , envelope
       , send

         -- * Checking receipts for @'Emergency'@ messages
       , checkReceipt

         -- * Envelope validation
       , validUser

       , main -- :: IO ()
       ) where
import           Control.Applicative
import           Data.Aeson
import           Data.ByteString      (ByteString)
import           Data.List
import           Data.Maybe
import           Data.Text            (Text)
import qualified Data.Text            as T
import           Data.Text.Encoding
import           Network.HTTP.Conduit

main :: IO ()
main = return ()

--------------------------------------------------------------------------------

-- | A token represents an identifier.
type Token   = Text

-- | A @'Receipt'@ is issued when you @'send'@ a message if that
-- message has @'Emergency'@ notification. You can check the receipt
-- issued from an @'Emergency'@ notification to see if the user has
-- responded to it.
type Receipt = Text

-- | Name of a mobile device to push notifications to.
type Device  = Text

data Priority
  = Low
  | Normal
  | High
  | Emergency Int Int -- ^ An @'Emergency'@ message requires a retry
                      -- and timeout limit.
  deriving (Eq, Show, Ord)

data Sound
  = Pushover     -- ^ Pushover (default)
  | Bike         -- ^ Bike
  | Bugle        -- ^ Bugle
  | CashRegister -- ^ Cash Register
  | Classical    -- ^ Classical
  | Cosmic       -- ^ Cosmic
  | Falling      -- ^ Falling
  | Gamelan      -- ^ Gamelan
  | Incoming     -- ^ Incoming
  | Intermission -- ^ Intermission
  | Magic        -- ^ Magic
  | Mechanical   -- ^ Mechanical
  | PianoBar     -- ^ Piano Bar
  | Siren        -- ^ Siren
  | SpaceAlarm   -- ^ Space Alarm
  | TugBoat      -- ^ Tug Boat
  | Alien        -- ^ Alien (long)
  | Climb        -- ^ Climb (long)
  | Persistent   -- ^ Persistent (long)
  | Echo         -- ^ Pushover Echo (long)
  | Updown       -- ^ Up Down (long)
  | None         -- ^ None (silent)
    deriving (Eq, Show, Ord, Bounded)

-- | The @'Message'@ data structure. To construct one of these, you
-- should alter the message under *defaultMessage* using record
-- syntax.
--
-- Currently, @'Message'@ does not support the @timestamp@ field.
data MessageOptions
  = MsgOpts { device   :: Maybe Device
            , title    :: Maybe Text
            , url      :: Maybe Text
            , urlTitle :: Maybe Text
            , sound    :: Sound
            , callback :: Maybe Text
            } deriving (Show,Eq, Ord)

-- | Default Pushover.net API options.
defaultOptions :: MessageOptions
defaultOptions = MsgOpts Nothing
                         Nothing
                         Nothing
                         Nothing
                         Pushover
                         Nothing

-- | An @'Envelope'@ is an abstract type which signifies the recepient
-- of a push message.
data Envelope = Envelope !Text !Text
              deriving (Eq, Show, Ord)

--------------------------------------------------------------------------------
-- Types

-- | When you send a @'Message'@, the server replies with at least a
-- status code and a request number. See the pushover API
-- documentation for what each field means.
data PushResponse
  = PushResp { status  :: Int
             , request :: ByteString
             , receipt :: Maybe ByteString
             , errors  :: Maybe [ByteString]
             } deriving (Show,Eq)

instance FromJSON PushResponse where
    parseJSON (Object o) =
      PushResp <$> o .:  T.pack "status"
               <*> o .:  T.pack "request"
               <*> o .:? T.pack "receipt"
               <*> o .:? T.pack "errors"
    parseJSON _ = fail "Unable to parse response from Pushover.net"

-- | The reponse you get when you inquire about a receipt for a
-- priority 2 message. See the pushover API documentation for what
-- each field means.
data ReceiptResponse
  = ReceiptResp { 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) =
      ReceiptResp <$> o .: T.pack "status"
                  <*> o .: T.pack "acknowledged"
                  <*> o .: T.pack "acknowledged_at"
                  <*> o .: T.pack "last_delivered_at"
                  <*> o .: T.pack "expired"
                  <*> o .: T.pack "expires_at"
                  <*> o .: T.pack "called_back"
                  <*> o .: T.pack "called_back_at"
    parseJSON _ = fail "Unable to parse response from Pushover.net"

data VerifyResponse
  = VerifyResp { verifyStatus  :: Int
               , verifyErr     :: Maybe [Text]
               , verifyDevices :: Maybe [Text]
               }
  deriving (Eq, Show, Ord)

instance FromJSON VerifyResponse where
  parseJSON (Object v) =
    VerifyResp <$> v .:  T.pack "status"
               <*> v .:? T.pack "errors"
               <*> v .:? T.pack "devices"
  parseJSON _ = fail "Unable to parse response from Pushover.net"

--------------------------------------------------------------------------------
-- Message sending

-- | Create an @'Envelope'@ given an application token and a
-- user/group token.
--
-- You can ensure your @'Envelope'@ is valid by calling @'validUser'@.
envelope :: Token    -- ^ Application token
         -> Token    -- ^ User/group token
         -> Envelope -- ^ Envelope for messages
envelope = Envelope

-- | Sends a push message to the Pushover servers.
send :: Envelope             -- ^ An @'Envelope'@ specifying the receiver
     -> Maybe MessageOptions -- ^ Extra options
     -> Priority             -- ^ Message priority
     -> Text                 -- ^ Message
     -> IO (Maybe PushResponse)
send env opts prio msg = postIt "https://api.pushover.net/1/messages.json" m
  where m = messageToFields env prio msg $ fromMaybe defaultOptions opts

--------------------------------------------------------------------------------
-- Receipt inquiry

-- | Inquire about a receipt.
checkReceipt :: Token -> Receipt -> IO (Maybe ReceiptResponse)
checkReceipt at rc = decode <$> simpleHttp resp
  where
    resp = Prelude.concat [ "https://api.pushover.net/1/receipts/"
                          , T.unpack rc
                          , ".json?token=", T.unpack at
                          ]

--------------------------------------------------------------------------------
-- User validation

-- | Check if a user/group is valid, and optionally check for a
-- specific device. Returns either an error, or the list of the
-- devices for the specified user/group
validUser :: Envelope
          -> Maybe Device -- ^ Optional device to look for
          -> IO (Either String [Device])
validUser (Envelope app usr) dev = act >>= \resp -> case resp of
  -- The user is valid, return the list of devices
  Just x | verifyStatus x == 1        -- Valid response
         , not (isJust (verifyErr x)) -- No errors
         -> return (Right (fromMaybe [] $ verifyDevices x))

  -- The user is invalid, return error.
  Just x | verifyStatus x == 0       -- Error
         , isJust (verifyErr x)      -- Error msgs
         -> return (squeezeErr $ fromJust (verifyErr x))

  -- Decoding err
  Nothing -> return $ Left "Couldn't decode Pushover.net JSON response."

  -- Unknown error
  _       -> return $ Left "Unknown Pushover.net error occurred."
  where
    squeezeErr = Left . concat . intersperse " " . map T.unpack

    act = postIt "https://api.pushover.net/1/users/validate.json" body
    body = [ ("token", encodeUtf8 app)
           , ("user", encodeUtf8 usr)
           ]
           ++ liftField "device" dev

--------------------------------------------------------------------------------
-- Utilities

-- | Helper that does a generic lifting operation for @POST@ bodies.
liftField :: ByteString -> Maybe Text -> [(ByteString, ByteString)]
liftField name = maybe [] (\x -> [(name, encodeUtf8 x)])

-- | Helper which @POST@s a response to a URL, then gets back a JSON
-- response.
postIt :: FromJSON t
       => String                           -- ^ URL
       -> [(ByteString, ByteString)] -- ^ @POST@ body
       -> IO (Maybe t)                     -- ^ Decoded JSON
postIt posturl bod = (decode . responseBody) <$> act
  where
    act = initreq >>= withManager . httpLbs . urlEncodedBody bod
    -- Don't throw exceptions for non-2xx HTTP responses
    setEx x = x { checkStatus = \_ _ _-> Nothing }
    initreq = setEx <$> parseUrl posturl

-- | Turn messages into @POST@-able bodies.
messageToFields :: Envelope
                -> Priority
                -> Text
                -> MessageOptions
                -> [(ByteString, ByteString)]
messageToFields (Envelope tok usr) prio msg opts
  = [ ("token",     encodeUtf8 $ tok)
    , ("user",      encodeUtf8 $ usr)
    , ("message",   encodeUtf8 $ msg)
    , ("priority",  encodeUtf8 $ prioText  prio)
    , ("sound",     encodeUtf8 $ soundText (sound opts))
    ]
  -- Encode optional fields
  ++ liftField "device"    (device opts)
  ++ liftField "title"     (title opts)
  ++ liftField "url"       (url opts)
  ++ liftField "url_title" (urlTitle opts)
  ++ liftField "retry"     (retryField prio)
  ++ liftField "expire"    (expireField prio)
  where
    retryField (Emergency n _) = Just (T.pack $ show n)
    retryField _               = Nothing

    expireField (Emergency _ n) = Just (T.pack $ show n)
    expireField _               = Nothing

    soundText :: Sound -> Text
    soundText = T.pack . go where
      go Pushover     = "pushover"
      go Bike         = "bike"
      go Bugle        = "bugle"
      go CashRegister = "cashregister"
      go Classical    = "classical"
      go Cosmic       = "cosmic"
      go Falling      = "falling"
      go Gamelan      = "gamelan"
      go Incoming     = "incoming"
      go Intermission = "intermission"
      go Magic        = "magic"
      go Mechanical   = "mechanical"
      go PianoBar     = "pianobar"
      go Siren        = "siren"
      go SpaceAlarm   = "spacealarm"
      go TugBoat      = "tugboat"
      go Alien        = "alien"
      go Climb        = "climb"
      go Persistent   = "persistent"
      go Echo         = "echo"
      go Updown       = "updown"
      go None         = "none"

    prioText :: Priority -> Text
    prioText = T.pack . go where
      go Low             = "-1"
      go Normal          = "0"
      go High            = "1"
      go (Emergency _ _) = "2"