pushover (empty) → 0.1.0.0

raw patch · 15 files changed

+1120/−0 lines, 15 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, exceptions, http-client, http-client-tls, mtl, pushover, tasty, tasty-hunit, text, time, transformers, uri-encode

Files

• LICENSE +30/−0
• README.md +48/−0
• Setup.hs +2/−0
• pushover.cabal +60/−0
• src/Lib.hs +6/−0
• src/Network/Pushover.hs +64/−0
• src/Network/Pushover/Exceptions.hs +43/−0
• src/Network/Pushover/Execute.hs +121/−0
• src/Network/Pushover/Message.hs +217/−0
• src/Network/Pushover/Reader.hs +62/−0
• src/Network/Pushover/Request.hs +215/−0
• src/Network/Pushover/Response.hs +51/−0
• src/Network/Pushover/Token.hs +118/−0
• test/Network/Pushover/RequestTest.hs +73/−0
• test/Spec.hs +10/−0

@@ -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.

@@ -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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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

@@ -0,0 +1,6 @@+module Lib+    ( someFunc+    ) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"

@@ -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

@@ -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"

@@ -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  

@@ -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 [ "</"+                   , tagName+                   , ">"+                   ]++        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

@@ -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

@@ -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"

@@ -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+

@@ -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

@@ -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"

@@ -0,0 +1,10 @@+import Network.Pushover.RequestTest++import Test.Tasty++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+  testGroup "Tests" [unitTests]