diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Dan Meakin (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Dan Meakin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,48 @@ +# Pushover + +This is a small library for interacting with the Pushover API from within +Haskell. + +Pushover exposes a straightforward API for sending notifications to users of +the Android and iOS Pushover app. Details of the API can be found at +https://pushover.net/api. + +## Usage + +This library exposes a number of types which represent a `Request` and a +`Response`, and fields contained within these values. It provides functions +which can be used to create and make requests. + +### Basic + +A basic request can be made as follows:- + +``` +>>> apiKey = makeTokenOrError "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" +>>> userKey = makeTokenOrError "yyyyyyyyyyyyyyyyyyyyyyyyyyyyyy" +>>> sendMessage apiK usrK $ text "This is a test" +``` + +Assuming the keys are correct, this should immediately send the notification +to the user with `userKey`. + +The `makeTokenOrError` function shown here should not generally be used. +Instead, the `makeToken` function checks the validity of the token and wraps +the output in Either. + +### Reader-based + +A more useful approach is to integrate Pushover into your existing Monad stack. +This can be accomplished using the `createKeys` and `sendMessageM` functions:- + +``` +>>> keys = createKeys "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "yyyyyyyyyyyyyyyyyyyyyyyyyyyyyy" +>>> keys >>= runReaderT (sendMessageM $ text "This is a test") +``` + +The Monad-based functions (all with a trailing `M` in their name) require that +a request is executed within a stack including an instance of MonadError and +MonadIO. `sendMessageM` additionally requires a MonadReader and an instance of +`PushoverReader`. See +[the Reader module](https://github.com/DanMeakin/pushover/blob/master/src/Network/Pushover/Reader.hs) +for more details. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/pushover.cabal b/pushover.cabal new file mode 100644 --- /dev/null +++ b/pushover.cabal @@ -0,0 +1,60 @@ +name: pushover +version: 0.1.0.0 +synopsis: A Haskell Pushover API library +description: This package provides functionality to allow Haskell + developers to interact with the Pushover API + (https://pushover.net). +homepage: https://github.com/DanMeakin/pushover#readme +license: BSD3 +license-file: LICENSE +author: Dan Meakin +maintainer: dan@danmeakin.com +copyright: 2017 Dan Meakin +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Lib + , Network.Pushover + , Network.Pushover.Exceptions + , Network.Pushover.Execute + , Network.Pushover.Message + , Network.Pushover.Reader + , Network.Pushover.Request + , Network.Pushover.Response + , Network.Pushover.Token + build-depends: base >= 4.7 && < 5 + , aeson + , bytestring + , exceptions + , http-client + , http-client-tls + , mtl + , text + , time + , transformers + , uri-encode + default-language: Haskell2010 + +test-suite pushover-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Network.Pushover.RequestTest + build-depends: base + , bytestring + , http-client + , pushover + , tasty + , tasty-hunit + , text + , time + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/DanMeakin/pushover diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,6 @@ +module Lib + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/src/Network/Pushover.hs b/src/Network/Pushover.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushover.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| This library provides functionality for interacting with the Pushover API +(@https://www.pushover.net@) from within a Haskell codebase. + +Pushover exposes a straightforward API for sending notifications to users of +the Android and iOS Pushover app. Details of the API can be found at +@https://pushover.net/api@. + +Requests are defined by the 'Request' type. The 'defaultRequest' function is +provided to allow for the easy creation of simple requests. Each request +requires an API token, user token and a message to be passed. All other +fields are optional and can be set as required. + +-} +module Network.Pushover + ( -- * Sending a notification + -- ** Regular functions + sendMessage + , sendRequest + , createRequest + -- ** Monadic functions + , sendMessageM + , sendRequestM + , createRequestM + -- * Requests + -- ** Constructing a request + , Request + , defaultRequest + -- ** Constructing a request's message + , Message + , message + , bold + , italic + , underline + , color + , link + , text + -- ** Authenticating a request + , APIToken + , UserKey + , PushoverToken + , makeToken + -- ** Other request fields + , URL (..) + , Priority (..) + , NotificationSound (..) + -- * Response + , Response (..) + -- * Reader + , PushoverReader (..) + , PushoverKeys (..) + , createKeys + -- * Exceptions + , PushoverException + , errorMessage + ) where + +import Network.Pushover.Exceptions +import Network.Pushover.Execute +import Network.Pushover.Message +import Network.Pushover.Reader +import Network.Pushover.Request +import Network.Pushover.Response +import Network.Pushover.Token diff --git a/src/Network/Pushover/Exceptions.hs b/src/Network/Pushover/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushover/Exceptions.hs @@ -0,0 +1,43 @@ +module Network.Pushover.Exceptions where + +import Control.Monad.Catch +import Control.Monad.Error.Class +import Control.Monad.Except +import Data.Typeable + +-- | Defines possible exceptions which can be thrown from execution commands. +data PushoverException + = ResponseDecodeException + -- ^ This exception is thrown when a response is malformed and cannot be + -- decoded. + | InvalidTokenCharactersException + -- ^ This exception is thrown when a token cannot be constructed because it + -- contains invalid characters. + | InvalidTokenLengthException + -- ^ This exception is thrown when a token cannot be constructed because it + -- is an incorrect length. + | PushoverException String + -- ^ This is a generic exception for other errors in Pushover. + deriving (Show, Typeable) + +instance Exception PushoverException + +instance Error PushoverException where + noMsg = + PushoverException "Unknown exception" + + strMsg = + PushoverException + + +-- | Display a description error message for each 'PushoverException' +-- constructor. +errorMessage :: PushoverException -> String +errorMessage InvalidTokenLengthException = + "token must be exactly 30 characters long" + +errorMessage InvalidTokenCharactersException = + "token must contain only alphanumeric characters" + +errorMessage ResponseDecodeException = + "unexpected format of Pushover response" diff --git a/src/Network/Pushover/Execute.hs b/src/Network/Pushover/Execute.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushover/Execute.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| This module exposes a set of functions used for constructing and submitting +requests to the Pushover API. + +Each function has two versions: a monadic version and a non-monadic version. +The monadic versions are designed for use within an existing monad transformer +stack within an existing application. The non-monadic versions are designed +for standalone use. + +-} +module Network.Pushover.Execute + ( -- * Regular functions + sendMessage + , sendRequest + , createRequest + -- * Monadic functions + , sendMessageM + , sendRequestM + , createRequestM + , PushoverException (..) + ) where + +import Control.Exception (throw) +import Control.Monad.Error.Class +import Control.Monad.Except +import Control.Monad.Reader +import Data.Aeson (decode) +import Network.Pushover.Message (Message) +import Network.Pushover.Request hiding (userKey) +import Network.Pushover.Response (Response) +import Network.Pushover.Reader (PushoverReader (..)) +import Network.Pushover.Exceptions +import Network.Pushover.Token + +import qualified Network.HTTP.Client as Http +import Network.HTTP.Client.TLS (newTlsManager) + +-- | Send a request to the Pushover API. +-- +-- Requires a pair of Pushover tokens, together with a 'Message' value. These +-- are used to construct a 'defaultRequest' which is then sent to the API. +sendMessage :: APIToken -> UserKey -> Message -> IO Response +sendMessage apiTk userK = + sendRequest . defaultRequest apiTk userK + +-- | Send a request to the Pushover API. +-- +-- This is similar to 'sendMessage', except that a constructed 'Request' must +-- be passed instead of the tokens and message. +sendRequest :: Request -> IO Response +sendRequest = + sendRequestM + +-- | Send a request to the Pushover API. +-- +-- This function is designed for use within an existing monad transformer +-- stack to make it easy to send Pushover notifications from inside existing +-- software. +-- +-- The relevant tokens are read from a 'PushoverReader' MonadReader instance. +-- These are then used to construct a 'defaultRequest' containing the passed +-- 'Message' value. +sendMessageM :: ( Error e + , MonadError e m + , MonadIO m + , MonadReader r m + , PushoverReader r + ) + => Message + -> m Response +sendMessageM message = do + pushoverRequest <- createRequestM message + liftIO $ sendRequest pushoverRequest + + +-- | Send a request to the Pushover API. +-- +-- This function is designed for use within an existing monad transformer +-- stack to make it easy to send Pushover notifications from inside existing +-- software. +-- +-- This is similar to 'sendMessageM', except that a constructed 'Request' must +-- be passed instead of just the message. +sendRequestM :: ( Error e + , MonadError e m + , MonadIO m + ) + => Request + -> m Response +sendRequestM pushoverRequest = do + manager <- newTlsManager + request <- liftIO $ makeHttpRequest pushoverRequest + response <- liftIO $ Http.httpLbs request manager + case decode $ Http.responseBody response of + Just resp -> + return resp + + Nothing -> + throwError . strMsg $ "response decoder error" + + +-- | Create a standard Pushover request. +-- +-- This is an alias of the 'defaultRequest' function. +createRequest :: APIToken -> UserKey -> Message -> Request +createRequest = + defaultRequest + +-- | Create a standard Pushover request. +-- +-- This is similar to 'createRequest', except that token information is read +-- from within the monad stack. +createRequestM :: ( MonadReader r m + , PushoverReader r + ) + => Message + -> m Request +createRequestM message = do + apiTk <- asks apiToken + usrK <- asks userKey + return $ defaultRequest apiTk usrK message diff --git a/src/Network/Pushover/Message.hs b/src/Network/Pushover/Message.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushover/Message.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| This module provides functions for creating and encoding messages for use +within Pushover requests. + +Pushover messages contain a very limited subset of HTML. Users can insert bold, +italic, underlined, and colored text, and URLs within messages. The 'Message' +type represents all of these possible formatting options. + +Constructing a 'Message' is done through the use of the 'message', 'bold', +'italic', 'underline', 'color', 'link', and 'text' functions. The 'message' +function takes a list of parts created using the other functions, and +concatenates these into a single message. Different types of formatting can +be nested within each other by simply calling the functions on the results of +other function calls. For example:- + +@ + bold + [ italic + [ text "This is bold & italic" + ] + , text "This is bold" + , underline + [ text "This is bold & underlined" + ] + ] +@ + +will create a message with the text values formatted as described. + +-} +module Network.Pushover.Message + ( -- * Creating a Message + Message + , message + , bold + , italic + , underline + , color + , link + , text + -- * Encoding for inclusion in request + , encodeMessage + -- * Attributes + , ColorCode + , makeColorCode + , Url + ) 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 Numeric (showHex) + +-- | Represents a message sent to the Pushover API. +-- +-- A Pushover message can be constructed with a very small subset of HTML. +-- This type represents the available HTML formatting for a message. +data Message + = Parts [Message] + | Bold [Message] + | Italic [Message] + | Underline [Message] + | Color ColorCode [Message] + | Link Url [Message] + | MessageText Text + deriving (Show, Eq) + +-- | Represents an HTML color code. +-- +-- A ColorCode consists of a red, a green and a blue element, each of which +-- must have a value of between 0 and 255. This type cannot enforce this +-- constraint, but see 'makeColorCode' which does. +data ColorCode = ColorCode + { red :: Integer + , green :: Integer + , blue :: Integer + } deriving (Show, Eq) + +type Url + = Text + +-- | Make a message from a list of message parts. +message :: [Message] -> Message +message = + Parts + +-- | Make a bold message. +bold :: [Message] -> Message +bold = + Bold + +-- | Make an italic message. +italic :: [Message] -> Message +italic = + Italic + +-- | Make an underlined message. +underline :: [Message] -> Message +underline = + Underline + +-- | Make a message with colored text. +-- +-- Accepts three integer arguments for red, green and blue color elements, +-- respectively. +color :: Integer -> Integer -> Integer -> [Message] -> Message +color r g b = + Color (makeColorCode r g b) + +-- | Make a url message. +link :: Url -> [Message] -> Message +link = + Link + +-- | Make a textual message. +text :: Text -> Message +text = + MessageText + +-- | Construct a 'ColorCode' value. +-- +-- A 'ColorCode' requires a red, a green and a blue value for construction. +-- This function takes these as arguments and returns a constructed +-- 'ColorCode'. +-- +-- This function checks that each element is within the required 0-255 range. +-- Any element which is not is rounded to the nearest extrema (0 for negative +-- values; 255 for values larger than that number). +makeColorCode :: Integer -> Integer -> Integer -> ColorCode +makeColorCode r g b = + ColorCode + { red = f r + , green = f g + , blue = f b + } + + where + f = + max 0 . min 255 + +-- | Encode a 'Message' into a bytestring. +-- +-- This function is intended to convert a 'Message' into a form useable within +-- a 'Request'. It generates a bytestring containing the HTML for the message. +encodeMessage :: Message -> ByteString +encodeMessage = + enc + + where + enc msg = + case msg of + Parts msg -> + encInner msg + + Bold msg -> + wrapTag "b" "" msg + + Italic msg -> + wrapTag "i" "" msg + + Underline msg -> + wrapTag "u" "" msg + + Color colorCode msg -> + wrapTag "font" (colorAttr colorCode) msg + + Link url msg -> + wrapTag "a" (linkAttr url) msg + + MessageText txt -> + T.encodeUtf8 txt + + encInner = + B.concat . map enc + + wrapTag tagName attr inner = + B.concat [ openTag tagName attr + , encInner inner + , closeTag tagName + ] + + openTag tagName attr = + B.concat [ "<" + , tagName + , attr + , ">" + ] + + closeTag tagName = + B.concat [ "" + ] + + colorAttr = + B.append " color=" . encodeColorCode + + linkAttr = + B.append " href=" . T.encodeUtf8 + +-- | Encode a 'ColorCode' into a bytestring. +-- +-- This converts a 'ColorCode' value into its corresponding hexadecimal +-- representation. +encodeColorCode :: ColorCode -> ByteString +encodeColorCode (ColorCode r g b) = + B.pack $ '#':hexCode + + where + hexCode = + padShow r . padShow g . padShow b $ "" + + padShow = + (\hex rest -> replicate (2 - length (hex "")) '0' ++ hex rest) + <$> showHex diff --git a/src/Network/Pushover/Reader.hs b/src/Network/Pushover/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushover/Reader.hs @@ -0,0 +1,62 @@ +{-| This module exposes types intended to make it easy to incorporate Pushover +request functionality within an existing application. + +The 'PushoverReader' class is designed to make it easy to extend an existing +reader environment to include the information required by Pushover in the making +of requests. + +'PushoverKeys' is a simple type available for immediate use should a developer +not yet have a reader environment and wants quickly to use Pushover. +-} +module Network.Pushover.Reader where + +import Control.Monad.Error.Class +import Control.Monad.Except +import Data.Text (Text) +import Network.Pushover.Exceptions +import Network.Pushover.Token + +-- | The 'PushoverReader' class is intended to make it straightforward to +-- incorporate the making of Pushover requests within an existing monad +-- stack. +-- +-- This class is intended to make it easy to add an API token and user key +-- to an existing reader monad environment. +class PushoverReader r where + apiToken :: r -> APIToken + userKey :: r -> UserKey + +-- | A basic type for use in storing the pair of keys required for making +-- a request. +data PushoverKeys = PushoverKeys + { _apiToken :: APIToken + , _userKey :: UserKey + } deriving Show + +instance PushoverReader PushoverKeys where + apiToken = + _apiToken + + userKey = + _userKey + +-- | An unvalidated API token. +type UnvalidatedAPIToken + = Text + +-- | An unvalidated user key. +type UnvalidatedUserKey + = Text + +-- | Construct a 'PushoverKeys' value. +-- +-- This attempts to create valid tokens/keys from a pair of unvalidated +-- tokens/keys, returning the result wrapped within a MonadError. +createKeys :: (Error e, MonadError e m) + => UnvalidatedAPIToken + -> UnvalidatedUserKey + -> m PushoverKeys +createKeys apiTkn usrKey = + PushoverKeys + <$> makeTokenM apiTkn + <*> makeTokenM usrKey diff --git a/src/Network/Pushover/Request.hs b/src/Network/Pushover/Request.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushover/Request.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Pushover.Request + ( -- * Constructing a request + Request (..) + , defaultRequest + -- * Other request parameters + , URL (..) + , Priority (..) + , NotificationSound (..) + -- * HTTP request helper + , 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 + +-- | Pushover API endpoint. +endpoint = "https://api.pushover.net/1/messages.json" + +-- | Contains the contents of a Pushover notification request. This follows +-- the API specification at @https://pushover.net/api@. +data Request = Request + { requestToken :: APIToken + -- ^ The API token provided by your Pushover app's dashboard at + -- @https://pushover.net/apps@. + , requestUserKey :: UserKey + -- ^ The user key of the user receiving this notification, found in the + -- Pushover dashboard at @https://pushover.net/dashboard@. + , requestMessage :: Message + -- ^ The notification message to push to the user. + , devices :: [Text] + -- ^ An optional list of devices to which to send the notification. If empty, + -- it will be sent to all of the user's devices. + , title :: Maybe Text + -- ^ An optional title for the message. + , url :: Maybe URL + -- ^ An optional URL for inclusion with the message. + , priority :: Maybe Priority + -- ^ The priority of this message. This affects way in which the notification + -- is presented to the receiving user. See 'Priority' for more information. + , timestamp :: Maybe UTCTime + -- ^ An optional timestamp for the notification. If no timestamp is provided, + -- the time the request is received by the Pushover API is used. + , notificationSound :: Maybe NotificationSound + -- ^ The notification sound to use. The default is 'Pushover', with 'None' + -- provided for a silent notification. + } deriving (Show, Eq) + +-- | A URL for sending within a notification request. +-- +-- A Pushover URL is optional within a request; if present, it may optionally +-- contain a title to display instead of the URL itself. +data URL = URL + { urlPath :: Text + , urlTitle :: Maybe Text + } deriving (Show, Eq) + +-- | Describes the priority of a particular message. +-- +-- The different priority settings affect the way in which a notification is +-- presented to the user. See @https://pushover.net/api#priority@ for specific +-- details. +data Priority + = Lowest + | Low + | Normal + | High + | Emergency + deriving (Show, Eq) + +-- | Describes the notification sound for a notification. +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) + +-- | Construct a default request value. +-- +-- As a request requires, at a minimum, an API token, a user key and a +-- message, this function requires each of these values as an argument. Other +-- fields can then be initialised using the regular Haskell record syntax. +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 + } + +-- | Construct an HTTP request out of a Pushover request value. +-- +-- This function is exposed for use by the functions in the +-- "Network.Pushover.Execute" module. It is unlikely that the user will +-- require to call it directly. +makeHttpRequest :: Request -> IO Http.Request +makeHttpRequest pushoverRequest = do + initialRequest <- Http.parseRequest endpoint + return . Http.setQueryString (requestQueryPairs pushoverRequest) + $ initialRequest { Http.method = "POST" } + +-- | Create a set of HTTP query pairs from a 'Request'. +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") -- Flag that HTML will be sent. + ] + + 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 + +-- | Encode a timestamp into a bytestring. +-- +-- Used when converting a 'Request' for sending. +encodeTimestamp :: UTCTime -> ByteString +encodeTimestamp = + B.pack . show . round . utcTimeToPOSIXSeconds + +-- | Encode a priority into a bytestring. +-- +-- Used when converting a 'Request' for sending. +encodePriority :: Priority -> ByteString +encodePriority Emergency = "2" +encodePriority High = "1" +encodePriority Normal = "0" +encodePriority Low = "-1" +encodePriority Lowest = "-2" + +-- | Encode a notification sound into a bytestring. +-- +-- Used when converting a 'Request' for sending. +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" diff --git a/src/Network/Pushover/Response.hs b/src/Network/Pushover/Response.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushover/Response.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Pushover.Response where + +import Data.Aeson hiding (Success) +import Data.Text (Text) +import qualified Data.Text as T + +-- | Describes a response received to a notification request. This follows the +-- specification at @https://pushover.net/api#response@. +-- +-- A request will either be successful or it will be unsuccessful. Where it is +-- successful, an appropriate status indicator is returned. Where unsuccessful, +-- the response will contain an errors key with a list of errors within the +-- request. +-- +-- In both cases, a request parameter is returned which uniquely identifies the +-- request leading to the response. +data Response = Response + { status :: ResponseStatus + , request :: Text + } deriving Show + +instance FromJSON Response where + parseJSON (Object v) = + Response + <$> parseJSON (Object v) + <*> v .: "request" + +-- | Describes a Pushover response status. +-- +-- A request is either successful or unsuccessful. This is reflected in this +-- type. Success has no additional data associated with it; failure has a list +-- of errors associated. +data ResponseStatus + = Success + | Failure [RequestError] + deriving Show + +instance FromJSON ResponseStatus where + parseJSON (Object v) = do + status <- v .: "status" + case (status :: Integer) of + 1 -> + pure Success + + 0 -> + Failure <$> v .: "errors" + +type RequestError = + Text + diff --git a/src/Network/Pushover/Token.hs b/src/Network/Pushover/Token.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushover/Token.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| This module contains functionality and types concerning tokens used to +authenticate and direct communications with the Pushover API. + +The API requires that an API token be sent with every request for +authentication purposes, and a user key be sent with every request for the +purpose of identifying the recipient of the message. Both types of token/key +are of the same format, and the 'makeToken' functions work for constructing +both types of token/key. +-} +module Network.Pushover.Token + ( -- * Token type + PushoverToken + -- ** Aliases + , APIToken + , UserKey + -- * Constructing a token + , makeToken + , makeTokenM + , makeTokenOrError + -- * Encoding for use in HTTP request + , encodeToken + ) where + +import Control.Arrow (left) +import Control.Monad (unless) +import Control.Monad.Error.Class +import Control.Monad.Except +import Data.Aeson +import Data.ByteString.Char8 (ByteString) +import Data.Char (isAlphaNum) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.Pushover.Exceptions + +-- | Define a type to represent the different types of token or key Pushover +-- requires. +-- +-- Pushover requires API token and user keys to be send with requests. This is +-- intended to represent these tokens. It is intended that the 'makeToken' +-- function is used to construct validated tokens. +newtype PushoverToken = PushoverToken + { getToken :: Text + } deriving (Show, Eq) + +instance ToJSON PushoverToken where + toJSON = + toJSON . getToken + +instance FromJSON PushoverToken where + parseJSON (String tkn) = + case makeToken tkn of + Right tok -> + return tok + + Left err -> + fail $ errorMessage err + + -- | API token for making a Pushover request. +type APIToken + = PushoverToken + +-- | User key for the user receiving a notification. +type UserKey + = PushoverToken + +-- | Construct a 'PushoverToken' value. +-- +-- A 'PushoverToken' consists of exactly 30 alphanumeric characters (both +-- uppercase and lowercase). The input key text is validated to ensure it is +-- the correct length and contains valid characters. +-- +-- A descriptive error is returned where validation fails. +makeToken :: Text -> Either PushoverException PushoverToken +makeToken = + makeTokenM + +-- | Construct a 'PushoverToken' value. +-- +-- This is similar to the 'makeToken' function, except that it is generalised +-- over the 'MonadError' monad. +makeTokenM :: (Error e, MonadError e m) + => Text + -> m PushoverToken +makeTokenM tokenText = do + unless validateLength $ + throwError . strMsg $ errorMessage InvalidTokenLengthException + unless validateChars $ + throwError . strMsg $ errorMessage InvalidTokenCharactersException + return $ PushoverToken tokenText + + where + validateLength = + T.length tokenText == 30 + + validateChars = + T.all isAlphaNum tokenText + +-- | Construct a 'PushoverToken' value. +-- +-- This is a version of 'makeToken' in which an invalid token will raise an +-- error. It should generally not be used, with 'makeToken' the preferred means +-- to create a token. +makeTokenOrError :: Text -> PushoverToken +makeTokenOrError tokenText = + case makeToken tokenText of + Right tkn -> + tkn + + Left err -> + error $ errorMessage err + +-- | Encode a 'PushoverToken' into a bytestring for sending within an HTTP +-- request. +encodeToken :: PushoverToken -> ByteString +encodeToken = + T.encodeUtf8 . getToken diff --git a/test/Network/Pushover/RequestTest.hs b/test/Network/Pushover/RequestTest.hs new file mode 100644 --- /dev/null +++ b/test/Network/Pushover/RequestTest.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Pushover.RequestTest where + +import Data.ByteString.Char8 (ByteString) +import Network.HTTP.Client hiding (defaultRequest) +import Network.Pushover.Message (text) +import Network.Pushover.Request +import Network.Pushover.Token +import Test.Tasty +import Test.Tasty.HUnit + +unitTests = testGroup "Unit tests" + [ testCase "Default request initialises only passed fields" testDefaultRequest + , testCase "Correct query string encoded from request" testQueryStrings + ] + +testRequest = Request + { requestToken = makeTokenOrError "KzGDORePKggMaC0QOYAMyEEuzJnyUi" + , requestUserKey = makeTokenOrError "e9e1495ec75826de5983cd1abc8031" + , requestMessage = text "Backup of database \"example\" finished in 16 minutes." + , devices = ["droid4"] + , title = Just "Backup finished - SQL1" + , url = Nothing + , priority = Nothing + , timestamp = Nothing + , notificationSound = Nothing + } + +-------------------------------------------------------------------------------- + +testDefaultRequest = + let tkn = + makeTokenOrError "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" + + usrK = + makeTokenOrError "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" + + msg = + text "Msg" + + in + actualDefaultRequest tkn usrK msg @?= expectedDefaultRequest tkn usrK msg + +expectedDefaultRequest tkn usrK msg = Request + { requestToken = tkn + , requestUserKey = usrK + , requestMessage = msg + , devices = [] + , title = Nothing + , url = Nothing + , priority = Nothing + , timestamp = Nothing + , notificationSound = Nothing + } + +actualDefaultRequest = + defaultRequest + +-------------------------------------------------------------------------------- + +testQueryStrings = + actualQueryString >>= (@?= expectedQueryString) + +actualQueryString = + fmap queryString . makeHttpRequest $ testRequest + +expectedQueryString = + "?token=KzGDORePKggMaC0QOYAMyEEuzJnyUi&\ + \user=e9e1495ec75826de5983cd1abc8031&\ + \message=Backup%20of%20database%20%22example%22%20finished%20in%2016%20minutes.&\ + \device=droid4&\ + \title=Backup%20finished%20-%20SQL1&\ + \html=1" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,10 @@ +import Network.Pushover.RequestTest + +import Test.Tasty + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup "Tests" [unitTests]