pinpon (empty) → 0.2.0.1
raw patch · 27 files changed
+1773/−0 lines, 27 filesdep +QuickCheckdep +aesondep +aeson-prettysetup-changed
Dependencies added: QuickCheck, aeson, aeson-pretty, amazonka, amazonka-core, amazonka-sns, base, bytestring, containers, doctest, exceptions, hlint, hpio, hspec, http-client, http-client-tls, http-types, lens, lucid, mtl, network, optparse-applicative, optparse-text, pinpon, protolude, quickcheck-instances, resourcet, servant, servant-client, servant-docs, servant-lucid, servant-server, servant-swagger, servant-swagger-ui, swagger2, text, time, transformers, transformers-base, wai, warp
Files
- LICENSE +30/−0
- README.md +31/−0
- Setup.hs +2/−0
- changelog.md +41/−0
- package.yaml +288/−0
- pinpon-gpio/Main.hs +172/−0
- pinpon-ring/Main.hs +92/−0
- pinpon.cabal +294/−0
- pinpon/Main.hs +91/−0
- src/Network/PinPon.hs +3/−0
- src/Network/PinPon/API.hs +46/−0
- src/Network/PinPon/API/Topic.hs +65/−0
- src/Network/PinPon/AWS.hs +38/−0
- src/Network/PinPon/Client.hs +29/−0
- src/Network/PinPon/Config.hs +89/−0
- src/Network/PinPon/Notification.hs +78/−0
- src/Network/PinPon/SwaggerAPI.hs +66/−0
- src/Network/PinPon/Util.hs +27/−0
- src/Network/PinPon/WireTypes/APNS.hs +104/−0
- src/Network/PinPon/WireTypes/SNS.hs +78/−0
- stack-lts-10.yaml +5/−0
- stack-lts-9.yaml +7/−0
- stack.yaml +5/−0
- swagger.json +73/−0
- test/Spec.hs +1/−0
- test/doctest.hs +7/−0
- test/hlint.hs +11/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, Quixoftic, LLC++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 Quixoftic, LLC, 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.
+ README.md view
@@ -0,0 +1,31 @@+# pinpon++`pinpon` is a silly little service that implements an+Internet-enabled doorbell in Haskell, using+[Amazon Simple Notification Service](https://aws.amazon.com/sns/) to notify+subscribers that the button has been pushed. Effectively, it's a+simple REST service which, when `POST`ed to, will send a notification+to an SNS topic. You can then build a client application which+subscribes to that topic and notifies the user when the doorbell has+been pressed. No such client application is included in the `pinpon`+package, but an iOS app may be made available at some point in the+future.++The package provides a `pinpon-gpio` executable, intended for use on+Linux systems with GPIO functionality. When the specified GPIO pin is+triggered (e.g., via a momentary switch such as+[this one](https://www.e-switch.com/product-catalog/anti-vandal/product-lines/pv3-series-illuminated-sealed-long-life-anti-vandal-switches#.WHW8_7GZNE4)),+`pinpon-gpio` will `POST` a notification to the specified `pinpon`+server.++Why not simply build the Amazon SNS functionality into the+`pinpon-gpio` executable and eliminate the `pinpon` REST service?+Chiefly because the host system running the `pinpon-gpio` executable+may be particularly vulnerable to physical attacks (after all, it is+presumably hooked up to a doorbell button that is exposed in a public+space). I did not feel comfortable storing my Amazon AWS credentials+on such a device, nor even allowing such a device to communicate+directly with the public Internet. By proxying the AWS access via a+more physically secure host running the `pinpon` server on my internal+network, I can better protect my AWS credentials and limit network+access on the GPIO device to just the `pinpon` service.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
@@ -0,0 +1,41 @@+# pinpon changelog++## 0.2.0.1++Changes:++ - This package now uses Protolude.++ - Switch to hpack.++ - We only support GHC 8.0.2 and 8.2.2 now.++ - The `test-hlint` cabal flag is now disabled by default.++ - Updated copyright year.++ - Requires `hlint` 2.0.*.++ - Much improved Nix support, including a default fixed nixpkgs+ revision, Hydra jobsets, and Nix/Hydra builds against LTS package+ sets.++ - Test on `armv7l`.++Fixes:++ - All dependencies should now have PVP bounds.++ - `swagger.json` must be a `data-file` for Stack tests.++ - Remove an unused `mellon-core` dependency from stack.yaml.++## 0.2.0.0++- Requires Servant 0.11+.++- Other minor fixes.++## 0.1.0.0++Initial release.
+ package.yaml view
@@ -0,0 +1,288 @@+name: pinpon+version: 0.2.0.1+synopsis: A gateway for various cloud notification services+category: Network+stability: experimental+author: Drew Hess <dhess-src@quixoftic.com>+maintainer: Drew Hess <dhess-src@quixoftic.com>+copyright: Copyright (c) 2018, Quixoftic, LLC+license: BSD3+github: quixoftic/pinpon++description: ! '@pinpon@ is a gateway for various cloud notification services, such++ as the Amazon AWS SNS service.+++ Think of @pinpon@ as a hub for dispatching notifications originating++ from multiple notification sources. Clients of the @pinpon@ service++ create topics and send notifications via the REST-ish @pinpon@++ service, and the @pinpon@ server takes care of the per-service++ details and communicating with the upstream cloud services.+++ Advantages of this approach, compared to programming directly to the++ individual notification services'' interfaces, are:+++ * A common API for all supported notification services.+++ * The secret credentials required to communicate with each cloud++ notification service can be kept in a central location (namely,++ the @pinpon@ server), rather than being distributed to each++ notification source host, therefore reducing the attack surface.+++ * Hosts which send notifications via the @pinpon@ gateway can be++ firewalled from the public Internet. This is especially useful in++ IoT applications.+++ Currently-supported notification services:+++ * Amazon AWS SNS'++tested-with: GHC==8.0.2 GHC==8.2.2++flags:+ test-hlint:+ description: Build hlint test+ manual: true+ default: false+ test-doctests:+ description: Build doctests+ manual: true+ default: true+ pinpon-ring-executable:+ description: Build pinpon-ring program+ manual: true+ default: true+ pinpon-gpio-executable:+ description: Build pinpon-gpio program+ manual: true+ default: true+ pinpon-executable:+ description: Build pinpon program+ manual: true+ default: true++ghc-options:+- -Wall+- -Wincomplete-uni-patterns+- -Wincomplete-record-updates++default-extensions:+ - NoImplicitPrelude++library:+ ghc-options:+ - -Wcompat+ - -Wnoncanonical-monad-instances+ - -Wnoncanonical-monadfail-instances+ source-dirs: src+ other-extensions:+ - DataKinds+ - DeriveGeneric+ - DuplicateRecordFields+ - MultiParamTypeClasses+ - OverloadedStrings+ - Safe+ - TemplateHaskell+ - Trustworthy+ - TypeOperators+ dependencies:+ - base >=4 && <5+ - aeson >=1.1 && <1.3+ - aeson-pretty ==0.8.*+ - amazonka >=1.4.5 && <1.6+ - amazonka-core >=1.4.5 && <1.6+ - amazonka-sns >=1.4.5 && <1.6+ - bytestring >=0.10.8 && <0.11+ - containers >=0.5.7 && <0.6+ - exceptions >=0.8.3 && <0.9+ - http-client >=0.5.7 && <0.6+ - http-types >=0.9.1 && <0.10+ - lens ==4.15.*+ - lucid >=2.9.9 && <3+ - mtl ==2.2.1 && <2.3+ - protolude ==0.2.*+ - resourcet >=1.1.9 && <1.2+ - servant ==0.11.*+ - servant-client ==0.11.*+ - servant-docs ==0.11.*+ - servant-lucid >=0.7.1 && <0.8+ - servant-server ==0.11.*+ - servant-swagger >=1.1.4 && <1.2+ - servant-swagger-ui >=0.2.4 && <0.3+ - swagger2 >=2.1.6 && <2.3+ - text >=1.2.2 && <1.3+ - time >=1.6 && <1.9+ - transformers >=0.5.2 && <0.6+ - transformers-base >=0.4.4 && <0.5+ - wai ==3.2.*+ - warp ==3.2.*++executables:+ pinpon: &executable+ main: Main.hs+ source-dirs: pinpon+ other-extensions:+ - LambdaCase+ - OverloadedStrings+ ghc-options:+ - -threaded+ - -Wcompat+ - -Wnoncanonical-monad-instances+ - -Wnoncanonical-monadfail-instances+ - -fno-warn-redundant-constraints+ when:+ - condition: "!(flag(pinpon-executable))"+ then:+ buildable: false+ else:+ dependencies:+ - base+ - amazonka+ - amazonka-sns+ - containers+ - exceptions+ - lens+ - mtl+ - pinpon+ - protolude+ - network >=2.6.3 && <2.7+ - optparse-applicative >=0.13.2 && <0.15+ - optparse-text ==0.1.*+ - text+ - transformers+ - warp+ pinpon-ring:+ <<: *executable+ source-dirs: pinpon-ring+ when:+ - condition: "!(flag(pinpon-ring-executable))"+ then:+ buildable: false+ else:+ dependencies:+ - base+ - bytestring+ - exceptions+ - http-client+ - http-client-tls >=0.3.5 && <0.4+ - http-types+ - lens+ - network+ - optparse-applicative+ - optparse-text+ - pinpon+ - protolude+ - servant-client ==0.11.*+ - text+ - transformers+ - warp+ pinpon-gpio:+ <<: *executable+ source-dirs: pinpon-gpio+ other-extensions:+ - FlexibleContexts+ - OverloadedStrings+ when:+ - condition: "!(flag(pinpon-gpio-executable))"+ then:+ buildable: false+ else:+ dependencies:+ - base+ - bytestring+ - exceptions+ - hpio+ - http-client+ - http-client-tls+ - http-types+ - lens+ - mtl+ - network+ - optparse-applicative+ - optparse-text+ - pinpon+ - protolude+ - servant-client+ - text+ - time+ - transformers+ - warp++tests:+ hlint: &test+ main: hlint.hs+ source-dirs: test+ other-modules: []+ ghc-options:+ - -w+ - -threaded+ when:+ - condition: "!(flag(test-hlint))"+ then:+ buildable: false+ else:+ dependencies:+ - base+ - hlint ==2.0.*+ - protolude+ doctest:+ <<: *test+ main: doctest.hs+ ghc-options:+ - -threaded+ when:+ - condition: "!(flag(test-doctests))"+ then:+ buildable: false+ else:+ dependencies:+ - base+ - doctest >=0.10.1 && <1+ - protolude+ spec:+ <<: *test+ main: Spec.hs+ ghc-options:+ - -w+ - -threaded+ - -rtsopts+ - -with-rtsopts=-N+ dependencies:+ - base+ - aeson+ - bytestring+ - exceptions+ - hspec ==2.4.*+ - pinpon+ - protolude+ - QuickCheck >=2.9 && <2.11+ - quickcheck-instances ==0.3.*+ - servant-swagger++data-files:+- swagger.json++extra-source-files:+- README.md+- changelog.md+- package.yaml+- stack.yaml+- stack-lts-9.yaml+- stack-lts-10.yaml
+ pinpon-gpio/Main.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Protolude hiding (option)+import Control.Concurrent (threadDelay)+import Control.Lens ((^.))+import Control.Monad (forever, unless, void)+import Control.Monad.Catch.Pure (runCatch)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString.Char8 as C8 (unpack)+import Data.Monoid ((<>))+import Data.String (String)+import Data.Text (Text, pack)+import qualified Data.Text as T (unwords)+import qualified Data.Text.IO as T (putStrLn, hPutStrLn)+import Data.Time.Clock+ (NominalDiffTime, diffUTCTime, getCurrentTime)+import Network.HTTP.Client (newManager)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Types (Status(..))+import Network.PinPon.Client+ (Notification(..), defaultNotification, headline, message, notify,+ sound)+import Options.Applicative hiding (action)+import Options.Applicative.Text (text)+import Servant.Client+ (BaseUrl, ClientEnv(..), ServantError(..), parseBaseUrl,+ runClientM)+import System.GPIO.Linux.Sysfs (SysfsGpioIO, runSysfsGpioIO)+import System.GPIO.Monad+ (Pin(..), PinActiveLevel(..), PinInputMode(InputDefault),+ PinInterruptMode(..), withInterruptPin, pollInterruptPin)+import System.IO (stderr)++-- Only one for now.+data Interpreter =+ SysfsIO+ deriving (Eq,Show,Read)++data Options = Options+ { _quiet :: !Bool+ , _interpreter :: !Interpreter+ , _edge :: !PinInterruptMode+ , _activeLow :: !PinActiveLevel+ , _debounce :: !Int+ , _headline :: !Text+ , _message :: !Text+ , _sound :: !Text+ , _pinNumber :: !Int+ , _url :: !BaseUrl+ }++parseServiceUrl :: String -> ReadM BaseUrl+parseServiceUrl s =+ case runCatch $ parseBaseUrl s of+ Left _ -> readerError $ "Invalid service URL: " ++ s+ Right url -> return url++options :: Parser Options+options =+ Options <$>+ switch (long "quiet" <>+ short 'q' <>+ showDefault <>+ help "Only show errors") <*>+ option auto (long "interpreter" <>+ short 'i' <>+ metavar "SysfsIO" <>+ value SysfsIO <>+ showDefault <>+ help "Choose the GPIO interpreter to use") <*>+ option auto (long "edge" <>+ short 'e' <>+ metavar "RisingEdge|FallingEdge" <>+ value RisingEdge <>+ showDefault <>+ help "Trigger on rising/falling edge") <*>+ option auto (long "active-level" <>+ short 'l' <>+ metavar "ActiveLow|ActiveHigh" <>+ value ActiveHigh <>+ showDefault <>+ help "Pin active level") <*>+ option auto (long "debounce" <>+ short 'D' <>+ metavar "INT" <>+ value 5 <>+ showDefault <>+ help "Debounce duration in seconds") <*>+ option text (long "headline" <>+ short 'H' <>+ metavar "TEXT" <>+ value (defaultNotification ^. headline) <>+ help "Override the default notification headline") <*>+ option text (long "message" <>+ short 'M' <>+ metavar "TEXT" <>+ value (defaultNotification ^. message) <>+ help "Override the default notification message") <*>+ option text (long "sound" <>+ short 'S' <>+ metavar "TEXT" <>+ value (defaultNotification ^. sound) <>+ help "Override the default notification sound") <*>+ argument auto (metavar "N" <>+ help "GPIO pin number") <*>+ argument (str >>= parseServiceUrl)+ (metavar "URL" <>+ help "PinPon server base URL")++-- Note: debounce delay here is in /microseconds/.+debounce :: (MonadIO m) => Int -> m a -> m a+debounce delay action =+ do startAction <- liftIO getCurrentTime+ result <- action+ endAction <- liftIO getCurrentTime+ let timeLeft = max 0 $ delay - toUsec (endAction `diffUTCTime` startAction)+ in liftIO $ threadDelay timeLeft+ return result+ where+ toUsec :: NominalDiffTime -> Int+ toUsec d = truncate $ d * 1000000++-- Not really that pretty.+prettyServantError :: ServantError -> Text+prettyServantError (FailureResponse _ status _ _) =+ T.unwords+ [pack (show $ statusCode status), pack (C8.unpack $ statusMessage status)]+prettyServantError DecodeFailure{} =+ "decode failure"+prettyServantError UnsupportedContentType{} =+ "unsupported content type"+prettyServantError InvalidContentTypeHeader{} =+ "invalid content type header"+prettyServantError ConnectionError{} =+ "connection refused"++run :: Options -> IO ()+run (Options quiet SysfsIO edge activeLevel debounceDelay hl msg s pin serviceUrl) =+ let notification = Notification hl msg s+ in do manager <- newManager tlsManagerSettings+ let clientEnv = ClientEnv manager serviceUrl+ runSysfsGpioIO $+ withInterruptPin (Pin pin) InputDefault edge (Just activeLevel) $ \h ->+ forever $ debounce (debounceDelay * 1000000) $ do+ void $ pollInterruptPin h+ output "Ring! Ring!"+ result <- sendNotification notification clientEnv+ case result of+ Right _ -> output "Notification sent"+ Left e -> outputErr $ T.unwords ["PinPon service error:", prettyServantError e]+ where+ sendNotification :: Notification -> ClientEnv -> SysfsGpioIO (Either ServantError Notification)+ sendNotification n env = liftIO $ runClientM (notify n) env++ output :: Text -> SysfsGpioIO ()+ output t = unless quiet $ liftIO (T.putStrLn t)++ outputErr :: Text -> SysfsGpioIO ()+ outputErr = liftIO . T.hPutStrLn stderr++main :: IO ()+main = execParser opts >>= run+ where+ opts =+ info (helper <*> options)+ (fullDesc <>+ progDesc "pinpon-gpio" <>+ header "A GPIO-driven PinPon doorbell client.")+
+ pinpon-ring/Main.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Protolude hiding (option)+import Control.Lens ((^.))+import Control.Monad.Catch.Pure (runCatch)+import Data.ByteString.Char8 as C8 (unpack)+import Data.Monoid ((<>))+import Data.String (String)+import Data.Text (Text)+import Network.HTTP.Client (newManager)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Types (Status(..))+import Network.PinPon.Client+ (Notification(..), defaultNotification, headline, message, notify,+ sound)+import Options.Applicative+import Options.Applicative.Text (text)+import Servant.Client+ (BaseUrl, ClientEnv(..), ServantError(..), parseBaseUrl,+ runClientM)+import System.Exit (ExitCode(..), exitSuccess, exitWith)++data Options = Options+ { _headline :: !Text+ , _message :: !Text+ , _sound :: !Text+ , _url :: !BaseUrl+ }++parseServiceUrl :: String -> ReadM BaseUrl+parseServiceUrl s =+ case runCatch $ parseBaseUrl s of+ Left _ -> readerError $ "Invalid service URL: " ++ s+ Right url -> return url++options :: Parser Options+options =+ Options <$>+ option text (long "headline" <>+ short 'H' <>+ metavar "TEXT" <>+ value (defaultNotification ^. headline) <>+ help "Override the default notification headline") <*>+ option text (long "message" <>+ short 'M' <>+ metavar "TEXT" <>+ value (defaultNotification ^. message) <>+ help "Override the default notification message") <*>+ option text (long "sound" <>+ short 'S' <>+ metavar "TEXT" <>+ value (defaultNotification ^. sound) <>+ help "Override the default notification sound") <*>+ argument (str >>= parseServiceUrl)+ (metavar "URL" <>+ help "PinPon server base URL")++run :: Options -> IO ()+run (Options hl msg s baseUrl) =+ let notification = Notification hl msg s+ in+ do manager <- newManager tlsManagerSettings+ runClientM (notify notification) (ClientEnv manager baseUrl) >>= \case+ Right status ->+ do print status+ exitSuccess+ Left e ->+ do putStrLn $ "PinPon service error: " ++ prettyServantError e+ exitWith $ ExitFailure 1+ where+ prettyServantError :: ServantError -> String+ prettyServantError (FailureResponse _ status _ _) =+ show (statusCode status) ++ " " ++ C8.unpack (statusMessage status)+ prettyServantError DecodeFailure{} =+ "decode failure"+ prettyServantError UnsupportedContentType{} =+ "unsupported content type"+ prettyServantError InvalidContentTypeHeader{} =+ "invalid content type header"+ prettyServantError ConnectionError{} =+ "connection refused"++main :: IO ()+main = execParser opts >>= run+ where+ opts = info (helper <*> options)+ (fullDesc <>+ progDesc "Ring a PinPon doorbell" <>+ header "pinpon-ring")
+ pinpon.cabal view
@@ -0,0 +1,294 @@+-- This file has been generated from package.yaml by hpack version 0.21.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: ed2620ae2820a31b4c16cfcc7335a51248afdd96daffda59da6dee3be41fb25a++name: pinpon+version: 0.2.0.1+synopsis: A gateway for various cloud notification services+description: @pinpon@ is a gateway for various cloud notification services, such+ as the Amazon AWS SNS service.+ .+ Think of @pinpon@ as a hub for dispatching notifications originating+ from multiple notification sources. Clients of the @pinpon@ service+ create topics and send notifications via the REST-ish @pinpon@+ service, and the @pinpon@ server takes care of the per-service+ details and communicating with the upstream cloud services.+ .+ Advantages of this approach, compared to programming directly to the+ individual notification services' interfaces, are:+ .+ * A common API for all supported notification services.+ .+ * The secret credentials required to communicate with each cloud+ notification service can be kept in a central location (namely,+ the @pinpon@ server), rather than being distributed to each+ notification source host, therefore reducing the attack surface.+ .+ * Hosts which send notifications via the @pinpon@ gateway can be+ firewalled from the public Internet. This is especially useful in+ IoT applications.+ .+ Currently-supported notification services:+ .+ * Amazon AWS SNS+category: Network+stability: experimental+homepage: https://github.com/quixoftic/pinpon#readme+bug-reports: https://github.com/quixoftic/pinpon/issues+author: Drew Hess <dhess-src@quixoftic.com>+maintainer: Drew Hess <dhess-src@quixoftic.com>+copyright: Copyright (c) 2018, Quixoftic, LLC+license: BSD3+license-file: LICENSE+tested-with: GHC==8.0.2 GHC==8.2.2+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ changelog.md+ package.yaml+ README.md+ stack-lts-10.yaml+ stack-lts-9.yaml+ stack.yaml++data-files:+ swagger.json++source-repository head+ type: git+ location: https://github.com/quixoftic/pinpon++flag pinpon-executable+ description: Build pinpon program+ manual: True+ default: True++flag pinpon-gpio-executable+ description: Build pinpon-gpio program+ manual: True+ default: True++flag pinpon-ring-executable+ description: Build pinpon-ring program+ manual: True+ default: True++flag test-doctests+ description: Build doctests+ manual: True+ default: True++flag test-hlint+ description: Build hlint test+ manual: True+ default: False++library+ exposed-modules:+ Network.PinPon+ Network.PinPon.API+ Network.PinPon.API.Topic+ Network.PinPon.AWS+ Network.PinPon.Client+ Network.PinPon.Config+ Network.PinPon.Notification+ Network.PinPon.SwaggerAPI+ Network.PinPon.Util+ Network.PinPon.WireTypes.APNS+ Network.PinPon.WireTypes.SNS+ other-modules:+ Paths_pinpon+ hs-source-dirs:+ src+ default-extensions: NoImplicitPrelude+ other-extensions: DataKinds DeriveGeneric DuplicateRecordFields MultiParamTypeClasses OverloadedStrings Safe TemplateHaskell Trustworthy TypeOperators+ ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+ build-depends:+ aeson >=1.1 && <1.3+ , aeson-pretty ==0.8.*+ , amazonka >=1.4.5 && <1.6+ , amazonka-core >=1.4.5 && <1.6+ , amazonka-sns >=1.4.5 && <1.6+ , base >=4 && <5+ , bytestring >=0.10.8 && <0.11+ , containers >=0.5.7 && <0.6+ , exceptions >=0.8.3 && <0.9+ , http-client >=0.5.7 && <0.6+ , http-types >=0.9.1 && <0.10+ , lens ==4.15.*+ , lucid >=2.9.9 && <3+ , mtl ==2.2.1 && <2.3+ , protolude ==0.2.*+ , resourcet >=1.1.9 && <1.2+ , servant ==0.11.*+ , servant-client ==0.11.*+ , servant-docs ==0.11.*+ , servant-lucid >=0.7.1 && <0.8+ , servant-server ==0.11.*+ , servant-swagger >=1.1.4 && <1.2+ , servant-swagger-ui >=0.2.4 && <0.3+ , swagger2 >=2.1.6 && <2.3+ , text >=1.2.2 && <1.3+ , time >=1.6 && <1.9+ , transformers >=0.5.2 && <0.6+ , transformers-base >=0.4.4 && <0.5+ , wai ==3.2.*+ , warp ==3.2.*+ default-language: Haskell2010++executable pinpon+ main-is: Main.hs+ other-modules:+ Paths_pinpon+ hs-source-dirs:+ pinpon+ default-extensions: NoImplicitPrelude+ other-extensions: LambdaCase OverloadedStrings+ ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -fno-warn-redundant-constraints+ if !(flag(pinpon-executable))+ buildable: False+ else+ build-depends:+ amazonka+ , amazonka-sns+ , base+ , containers+ , exceptions+ , lens+ , mtl+ , network >=2.6.3 && <2.7+ , optparse-applicative >=0.13.2 && <0.15+ , optparse-text ==0.1.*+ , pinpon+ , protolude+ , text+ , transformers+ , warp+ default-language: Haskell2010++executable pinpon-gpio+ main-is: Main.hs+ other-modules:+ Paths_pinpon+ hs-source-dirs:+ pinpon-gpio+ default-extensions: NoImplicitPrelude+ other-extensions: FlexibleContexts OverloadedStrings+ ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -fno-warn-redundant-constraints+ if !(flag(pinpon-gpio-executable))+ buildable: False+ else+ build-depends:+ base+ , bytestring+ , exceptions+ , hpio+ , http-client+ , http-client-tls+ , http-types+ , lens+ , mtl+ , network+ , optparse-applicative+ , optparse-text+ , pinpon+ , protolude+ , servant-client+ , text+ , time+ , transformers+ , warp+ default-language: Haskell2010++executable pinpon-ring+ main-is: Main.hs+ other-modules:+ Paths_pinpon+ hs-source-dirs:+ pinpon-ring+ default-extensions: NoImplicitPrelude+ other-extensions: LambdaCase OverloadedStrings+ ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -fno-warn-redundant-constraints+ if !(flag(pinpon-ring-executable))+ buildable: False+ else+ build-depends:+ base+ , bytestring+ , exceptions+ , http-client+ , http-client-tls >=0.3.5 && <0.4+ , http-types+ , lens+ , network+ , optparse-applicative+ , optparse-text+ , pinpon+ , protolude+ , servant-client ==0.11.*+ , text+ , transformers+ , warp+ default-language: Haskell2010++test-suite doctest+ type: exitcode-stdio-1.0+ main-is: doctest.hs+ hs-source-dirs:+ test+ default-extensions: NoImplicitPrelude+ ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded+ if !(flag(test-doctests))+ buildable: False+ else+ build-depends:+ base+ , doctest >=0.10.1 && <1+ , protolude+ default-language: Haskell2010++test-suite hlint+ type: exitcode-stdio-1.0+ main-is: hlint.hs+ hs-source-dirs:+ test+ default-extensions: NoImplicitPrelude+ ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -w -threaded+ if !(flag(test-hlint))+ buildable: False+ else+ build-depends:+ base+ , hlint ==2.0.*+ , protolude+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ default-extensions: NoImplicitPrelude+ ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -w -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck >=2.9 && <2.11+ , aeson+ , base+ , bytestring+ , exceptions+ , hspec ==2.4.*+ , pinpon+ , protolude+ , quickcheck-instances ==0.3.*+ , servant-swagger+ if !(flag(test-hlint))+ buildable: False+ else+ build-depends:+ base+ , hlint ==2.0.*+ , protolude+ default-language: Haskell2010
+ pinpon/Main.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Protolude hiding (option)+import Control.Lens ((&), (.~))+import Control.Monad.Trans.AWS+ (Region(..), Credentials(..))+import Data.Monoid ((<>))+import qualified Data.Set as Set (fromList)+import Data.Text (Text)+import Network (PortID(..), listenOn)+import Network.AWS.Auth (credProfile, credFile)+import Network.AWS.Data (fromText)+import Network.PinPon.Config+ (Platform(..), createConfig, platforms)+import Network.PinPon.SwaggerAPI (app)+import Network.Wai.Handler.Warp+ (defaultSettings, runSettingsSocket, setHost, setPort)+import Options.Applicative+import Options.Applicative.Text (text)++data Options = Options+ { _region :: !Region+ , _credentialsFile :: Maybe FilePath+ , _credentialsProfile :: !Text+ , _platforms :: [Platform]+ , _port :: !Int+ , _topicName :: !Text+ }++parseRegion :: Text -> ReadM Region+parseRegion r =+ case fromText r of+ Left _ -> readerError $ "Invalid AWS region: " ++ show r+ Right region -> return region++makeCredentials :: Maybe FilePath -> Text -> IO Credentials+makeCredentials Nothing profile =+ do defaultPath <- credFile+ return $ FromFile profile defaultPath+makeCredentials (Just path) profile =+ return $ FromFile profile path++options :: Parser Options+options =+ Options <$>+ option (text >>= parseRegion)+ (long "region" <>+ short 'r' <>+ metavar "REGION" <>+ value NorthVirginia <>+ help "Specify the AWS region (default is us-east-1)") <*>+ optional (strOption (long "credentials-file" <>+ short 'f' <>+ metavar "PATH" <>+ help "Path to AWS credentials file")) <*>+ option text (long "profile" <>+ short 'P' <>+ metavar "PROFILE_NAME" <>+ value credProfile <>+ help "Credentials profile name") <*>+ many (option auto (long "platform" <>+ short 'P' <>+ metavar "PLATFORM" <>+ help "Send platform-specific messages (APNS, APNSSandbox)")) <*>+ option auto (long "port" <>+ short 'p' <>+ metavar "INT" <>+ value 8000 <>+ help "Listen on port") <*>+ argument text (metavar "topic-name")++run :: Options -> IO ()+run (Options region maybeFile profile platformList port topicName) =+ do credentials <- makeCredentials maybeFile profile+ config <- createConfig region credentials topicName+ sock <- listenOn (PortNumber (fromIntegral port))+ runSettingsSocket (setPort port $ setHost "*" defaultSettings)+ sock+ (app $ config & platforms .~ Set.fromList platformList)+++main :: IO ()+main = execParser opts >>= run+ where+ opts = info (helper <*> options)+ ( fullDesc+ <> progDesc "Run a PinPon server"+ <> header "pinpon - A PinPon server" )
+ src/Network/PinPon.hs view
@@ -0,0 +1,3 @@+module Network.PinPon+ ()+ where
+ src/Network/PinPon/API.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++module Network.PinPon.API+ ( -- * Types+ API++ -- * Servant / WAI functions+ , app+ , api+ , server+ )+ where++import Protolude+import Control.Monad.Reader (runReaderT)+import Control.Monad.Trans.Resource (runResourceT)+import Network.Wai (Application)+import Servant+ ((:~>)(..), Handler, Proxy(..), Server, enter, serve)++import Network.PinPon.API.Topic (TopicAPI, topicServer)+import Network.PinPon.Config (App(..), Config(..))++-- | Combine all of the various individual service APIs into a single+-- API type.+type API = TopicAPI++api :: Proxy API+api = Proxy++appToHandler :: Config -> App :~> Handler+appToHandler config = NT $ \a -> runResourceT (runReaderT (runApp a) config)++-- | A Servant 'Server' which serves the 'PinPonAPI' on the given+-- 'Config'.+--+-- Normally you will just use 'app', but this function is exported so+-- that you can extend/wrap 'API'.+server :: Config -> Server API+server config = enter (appToHandler config) topicServer++-- | A WAI 'Network.Wai.Application' which runs the service, using the+-- given 'Config'.+app :: Config -> Application+app = serve api . server
+ src/Network/PinPon/API/Topic.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Network.PinPon.API.Topic+ ( -- * Types+ Notification(..)+ , TopicAPI++ -- * Servant functions+ , topicServer+ ) where++import Protolude+import Control.Lens ((^.), (&), (.~), (?~))+import Control.Monad (void)+import Control.Monad.Reader (asks)+import qualified Data.Set as Set (member)+import Network.AWS.SNS.Publish+ (publish, pMessageStructure, pSubject, pTargetARN)+import Servant ((:>), JSON, Post, ReqBody, ServerT)+import Servant.HTML.Lucid (HTML)++import Network.PinPon.AWS (runSNS)+import Network.PinPon.Config+ (App(..), Config(..), Platform(..))+import Network.PinPon.Notification+ (Notification(..), headline)+import Network.PinPon.WireTypes.SNS+ (Message(..), apnsPayload, apnsSandboxPayload, defaultMessage,+ defaultText)+import Network.PinPon.WireTypes.APNS+ (defaultPayload, aps, alert, body, sound, title)+import Network.PinPon.Util (encodeText)++toMessage :: Notification -> App Message+toMessage (Notification h m s) =+ let payload =+ defaultPayload & aps.alert.title .~ h & aps.alert.body .~ m & aps.sound .~ s+ in do+ platforms <- asks _platforms+ return $+ defaultMessage+ & defaultText .~ m+ & apnsPayload .~ (if Set.member APNS platforms then Just payload else Nothing)+ & apnsSandboxPayload .~ (if Set.member APNSSandbox platforms then Just payload else Nothing)++type TopicAPI =+ "topic" :> ReqBody '[JSON] Notification :> Post '[JSON, HTML] Notification++topicServer :: ServerT TopicAPI App+topicServer =+ notify+ where+ notify :: Notification -> App Notification+ notify n =+ do arn <- asks _arn+ msg <- toMessage n+ void $ runSNS $ publish (encodeText msg)+ & pSubject ?~ n ^. headline+ & pMessageStructure ?~ "json"+ & pTargetARN ?~ arn+ return n
+ src/Network/PinPon/AWS.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.PinPon.AWS+ ( runSNS+ ) where++import Protolude hiding (catch)+import Control.Lens ((^.))+import Control.Monad.Catch (catch)+import Control.Monad.Reader (asks)+import Control.Monad.Trans.AWS (runAWST, send)+import qualified Data.ByteString.Lazy as BL (ByteString)+import Data.ByteString.Lens (packedChars)+import Network.AWS.Data.Text (ToText(..))+import Network.AWS.Types (AWSRequest, Error(..), Rs, serializeMessage, serviceMessage)+import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..))+import Servant (ServantErr(..), err502, err504, throwError)++import Network.PinPon.Config (App(..), Config(..))++runSNS :: (AWSRequest a) => a -> App (Rs a)+runSNS req =+ do env <- asks _env+ catch (runAWST env $ send req) $ throwError . snsErrToServant++snsErrToServant :: Error -> ServantErr+snsErrToServant e = (errCode e) { errBody = mconcat ["Upstream AWS SNS error: ", errMsg e ] }++errCode :: Error -> ServantErr+errCode (TransportError (HttpExceptionRequest _ ResponseTimeout)) = err504+errCode (TransportError (HttpExceptionRequest _ ConnectionTimeout)) = err504+errCode _ = err502++errMsg :: Error -> BL.ByteString+errMsg (ServiceError e) = maybe "Unspecified error" (toSL . toText) $ e ^. serviceMessage+errMsg (SerializeError e) = e ^. serializeMessage ^. packedChars+errMsg (TransportError e) = show e ^. packedChars
+ src/Network/PinPon/Client.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++module Network.PinPon.Client+ ( -- * Client actions+ notify++ -- * Re-exported for convenience.+ , Notification(..)+ , defaultNotification+ , headline+ , message+ , sound+ ) where++import Data.Proxy (Proxy(..))+import Servant.Client (ClientM, client)++import Network.PinPon.API (API)+import Network.PinPon.Notification+ (Notification(..), defaultNotification, headline, message, sound)++-- | The client API.+clientAPI :: Proxy API+clientAPI = Proxy++-- | Post a notification.+notify :: Notification -> ClientM Notification+notify = client clientAPI
+ src/Network/PinPon/Config.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++module Network.PinPon.Config+ ( -- * Types+ App(..)+ , Config(..)+ , createConfig+ , Platform(..)++ -- * Lenses+ , env+ , arn+ , platforms+ ) where++import Protolude+import Control.Lens+import Control.Monad.Base (MonadBase(..))+import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Except (MonadError)+import Control.Monad.Reader (MonadReader(..), ReaderT)+import Control.Monad.Trans.AWS+ (Region, Credentials, newEnv, runResourceT, runAWST, send)+import Control.Monad.Trans.Resource (MonadResource(..), ResourceT)+import Data.Maybe (fromJust)+import Data.Set (Set)+import qualified Data.Set as Set (empty)+import Data.Text (Text)+import Network.AWS (Env, HasEnv(..))+import Network.AWS.SNS (createTopic, ctrsTopicARN)+import Servant (Handler, ServantErr)++-- | @pinpon@ can deliver platform-specific messages via Amazon SNS+-- for the following platforms.+--+-- Note that, though it is not listed here, @pinpon@ supports delivery+-- via SNS to email addresses. This support is always enabled.+--+-- Platforms not specifically supported by @pinpon@ will still receive+-- notifications, but those notifications will not have any+-- platform-specific features; clients on those platforms will receive+-- only the notification message text. (See+-- "Network.PinPon.Notification.Notification".)+data Platform+ = APNS -- ^ Apple's APN service+ | APNSSandbox -- ^ Apple's APN sandbox service+ deriving (Eq, Ord, Enum, Bounded, Show, Read)++data Config = Config+ { _env :: !Env+ , _arn :: !Text+ , _platforms :: Set Platform+ }++makeClassy ''Config++instance HasEnv Config where+ environment = env++-- | Given an AWS 'Region' and a 'Credentials' descriptor, create an+-- SNS topic with the given 'Text' name, and return a @pinpon@ server+-- 'Config' for the topic. Notifications sent to the @pinpon@ server+-- using this 'Config' will be relayed to the SNS topic for delivery+-- to the topic's subscribers.+--+-- The initial set of platforms in the newly-created 'Config' is+-- empty. If you want to send platform-specific messages, add the+-- desired platform(s) to the 'Config's platform set after creating+-- the 'Config'.+--+-- Note that if the topic already exists with the given credentials+-- and region, then this operation is idempotent.+createConfig :: Region -> Credentials -> Text -> IO Config+createConfig region credentials topicName =+ do e <- newEnv credentials+ let enviro = e & envRegion .~ region+ topic <- runResourceT . runAWST enviro $+ send $ createTopic topicName+ return Config { _env = enviro+ , _arn = fromJust $ topic ^. ctrsTopicARN+ , _platforms = Set.empty+ }+newtype App a =+ App {runApp :: ReaderT Config (ResourceT Handler) a}+ deriving (Functor,Applicative,Monad,MonadBase IO,MonadError ServantErr,MonadCatch,MonadThrow,MonadReader Config,MonadIO,MonadResource)
+ src/Network/PinPon/Notification.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Network.PinPon.Notification+ ( -- * Types+ Notification(..)+ , headline+ , message+ , sound+ , defaultNotification+ ) where++import Protolude+import Control.Lens ((&), (?~), mapped, makeLenses)+import Control.Monad (void)+import Data.Aeson.Types+ (FromJSON(..), ToJSON(..), genericParseJSON, genericToEncoding,+ genericToJSON)+import Data.Text (Text)+import Data.Swagger+ (ToSchema(..), description, example, genericDeclareNamedSchema,+ schema)+import Lucid+ (ToHtml(..), HtmlT, doctypehtml_, head_, title_, body_)++import Network.PinPon.Util+ (recordTypeJSONOptions, recordTypeSwaggerOptions)++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Swagger.Schema.Validation++-- | A @pinpon@ doorbell notification.+--+-- @pinpon@ doorbell notifications are sent by @pinpon@ API clients to+-- the server. The server translates these notifications to the+-- format(s) required by the doorbell's subscribers.+--+-- Note that some notification formats don't support sound (e.g.,+-- email and SMS). This field will be ignored on platforms that do not+-- support it.+data Notification = Notification+ { _headline :: !Text -- ^ A summary of the notification, preferably a single line+ , _message :: !Text -- ^ A more detailed message (can be multiple lines)+ , _sound :: !Text -- ^ A client-specific string denoting the sound to play+ } deriving (Show, Generic)++makeLenses ''Notification++-- | A default value for 'Notification'.+defaultNotification :: Notification+defaultNotification = Notification "Ring! Ring!" "Someone is ringing the doorbell!" "default"++instance ToJSON Notification where+ toJSON = genericToJSON recordTypeJSONOptions+ toEncoding = genericToEncoding recordTypeJSONOptions+instance FromJSON Notification where+ parseJSON = genericParseJSON recordTypeJSONOptions++-- $+-- >>> validateToJSON $ Notification "Hi" "Test" "soundfile.caf"+-- []+instance ToSchema Notification where+ declareNamedSchema proxy =+ genericDeclareNamedSchema recordTypeSwaggerOptions proxy+ & mapped.schema.description ?~ "A doorbell notification"+ & mapped.schema.example ?~ toJSON defaultNotification++notificationResultDocument :: (Monad m) => HtmlT m a -> HtmlT m a -> HtmlT m a+notificationResultDocument hl msg =+ doctypehtml_ $ do+ void $ head_ $ title_ hl+ body_ msg++instance ToHtml Notification where+ toHtml (Notification hl msg _) = notificationResultDocument (toHtml hl) (toHtml msg)+ toHtmlRaw = toHtml
+ src/Network/PinPon/SwaggerAPI.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Network.PinPon.SwaggerAPI+ ( -- * Types+ API++ -- * Servant / WAI functions+ , app+ , api+ , server++ -- * Swagger+ , pinPonSwagger++ -- * Convenience functions+ , writeSwaggerJSON+ )+ where++import Protolude+import Control.Lens ((&), (.~), (?~))+import Data.Aeson.Encode.Pretty (encodePretty)+import qualified Data.ByteString.Lazy.Char8 as C8+import Data.Swagger+ (Swagger, URL(..), description, info, license, title, url, version)+import Network.Wai (Application)+import Servant ((:<|>)(..), Proxy(..), Server, serve)+import Servant.Swagger (toSwagger)+import Servant.Swagger.UI (SwaggerSchemaUI, swaggerSchemaUIServer)++import qualified Network.PinPon.API as PinPon (API, api, server)+import Network.PinPon.Config (Config(..))++-- | Combine all of the various individual service APIs (plus Swagger+-- support) into a single API type.+type API =+ PinPon.API :<|>+ SwaggerSchemaUI "swagger-ui" "swagger.json"++api :: Proxy API+api = Proxy++-- | A Servant 'Server' which serves the 'API' (including the Swagger+-- schema) on the given 'Config'.+--+-- Normally you will just use 'app', but this function is exported so+-- that you can extend/wrap 'API'.+server :: Config -> Server API+server config = PinPon.server config :<|> swaggerSchemaUIServer pinPonSwagger++-- | A WAI 'Network.Wai.Application' which runs the service, using the+-- given 'Config'.+app :: Config -> Application+app = serve api . server++pinPonSwagger :: Swagger+pinPonSwagger = toSwagger PinPon.api+ & info.title .~ "PinPon API"+ & info.version .~ "0.1"+ & info.description ?~ "A simple Internet-enabled doorbell notificaion service"+ & info.license ?~ ("BSD3" & url ?~ URL "https://opensource.org/licenses/BSD-3-Clause")++writeSwaggerJSON :: IO ()+writeSwaggerJSON = C8.writeFile "swagger.json" (encodePretty pinPonSwagger)
+ src/Network/PinPon/Util.hs view
@@ -0,0 +1,27 @@+module Network.PinPon.Util+ ( recordTypeJSONOptions+ , recordTypeSwaggerOptions+ , encodeText+ ) where++import Protolude+import Control.Lens ((^.), strict)+import Data.Aeson (ToJSON, encode)+import Data.Aeson.Types (Options(..), camelTo2, defaultOptions)+import Data.Text (Text)+import Data.Text.Strict.Lens (utf8)+import qualified Data.Swagger as Swagger (SchemaOptions(..))+import Data.Swagger (defaultSchemaOptions)++recordTypeJSONOptions :: Options+recordTypeJSONOptions =+ defaultOptions {fieldLabelModifier = drop 1+ ,constructorTagModifier = camelTo2 '_'}++recordTypeSwaggerOptions :: Swagger.SchemaOptions+recordTypeSwaggerOptions =+ defaultSchemaOptions {Swagger.fieldLabelModifier = drop 1+ ,Swagger.constructorTagModifier = camelTo2 '_'}++encodeText :: ToJSON a => a -> Text+encodeText a = encode a ^. strict . utf8
+ src/Network/PinPon/WireTypes/APNS.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Network.PinPon.WireTypes.APNS+ ( -- * Apple Push Notification service on-the-wire types.++ -- | These Haskell types are injections to their synonyms in the+ -- APNS JSON spec. See+ -- <https://developer.apple.com/library/content/documentation/NetworkingInternet/Conceptual/RemoteNotificationsPG/CreatingtheNotificationPayload.html#//apple_ref/doc/uid/TP40008194-CH10-SW1+ -- here> and+ -- <https://developer.apple.com/library/content/documentation/NetworkingInternet/Conceptual/RemoteNotificationsPG/PayloadKeyReference.html#//apple_ref/doc/uid/TP40008194-CH17-SW1+ -- here> for details.+ --+ -- These types are only sent to APNS (via SNS) and are never+ -- received on the wire, so they are not instances of "FromJSON",+ -- only 'ToJSON'.+ --+ -- Not all valid APNS fields are represented in these Haskell+ -- types; only the fields used by @pinpon@ are implemented.++ Alert(..)+ , title+ , body+ , defaultAlert++ , Aps(..)+ , alert+ , sound+ , defaultAps++ , Payload(..)+ , aps+ , defaultPayload+ ) where++import Protolude+import Control.Lens (makeLenses)+import Data.Aeson.Types+ (ToJSON(..), genericToEncoding, genericToJSON)+import Data.Text (Text)++import Network.PinPon.Util (recordTypeJSONOptions)++-- | A partial representation of the APNS @alert@ dictionary. See+-- <https://developer.apple.com/library/content/documentation/NetworkingInternet/Conceptual/RemoteNotificationsPG/PayloadKeyReference.html#//apple_ref/doc/uid/TP40008194-CH17-SW4+-- here> for details.+--+-- Note that while the APNS wire protocol permits an @alert@ to be+-- represented as a single JSON string, rather than a dictionary, we+-- only support the dictionary representation.+data Alert = Alert+ { _title :: !Text+ , _body :: !Text+ } deriving (Show, Generic)++makeLenses ''Alert++-- | A @pinpon@-specific default value for 'Alert'.+defaultAlert :: Alert+defaultAlert = Alert "Ring! Ring!" "Someone is ringing the doorbell!"++instance ToJSON Alert where+ toJSON = genericToJSON recordTypeJSONOptions+ toEncoding = genericToEncoding recordTypeJSONOptions++-- | A partial representation of the APNS @aps@ dictionary. See+-- <https://developer.apple.com/library/content/documentation/NetworkingInternet/Conceptual/RemoteNotificationsPG/PayloadKeyReference.html#//apple_ref/doc/uid/TP40008194-CH17-SW2+-- here> for details.+data Aps = Aps+ { _alert :: Alert+ , _sound :: !Text+ } deriving (Show, Generic)++makeLenses ''Aps++-- | A @pinpon@-specific default value for 'Aps'.+defaultAps :: Aps+defaultAps = Aps defaultAlert "default"++instance ToJSON Aps where+ toJSON = genericToJSON recordTypeJSONOptions+ toEncoding = genericToEncoding recordTypeJSONOptions++-- | The top-level APNS dictionary object. See+-- <https://developer.apple.com/library/content/documentation/NetworkingInternet/Conceptual/RemoteNotificationsPG/CreatingtheNotificationPayload.html#//apple_ref/doc/uid/TP40008194-CH10-SW15+-- here> for details.+--+-- Note that objects other than the @aps@ dictionary may be included+-- in APNS payloads, but as @pinpon@ doesn't use them, that+-- functionality is not implemented.+newtype Payload = Payload+ { _aps :: Aps+ } deriving (Show, Generic)++makeLenses ''Payload++-- | A @pinpon@-specific default value for an APNS 'Payload'.+defaultPayload :: Payload+defaultPayload = Payload defaultAps++instance ToJSON Payload where+ toJSON = genericToJSON recordTypeJSONOptions+ toEncoding = genericToEncoding recordTypeJSONOptions
+ src/Network/PinPon/WireTypes/SNS.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Network.PinPon.WireTypes.SNS+ ( -- * Amazon Simple Notification Service on-the-wire types+ Message(..)+ , defaultText+ , apnsPayload+ , apnsSandboxPayload+ , defaultMessage+ ) where++import Protolude+import Control.Lens (makeLenses)+import Data.Aeson.Types+ ((.=), Pair, Series, ToJSON(..), object, pairs)+import Data.Monoid ((<>))+import Data.Text (Text)++import Network.PinPon.Util (encodeText)+import qualified Network.PinPon.WireTypes.APNS as APNS (Payload(..))++-- $setup+-- >>> :set -XOverloadedStrings++-- | A multi-platform SNS message.+data Message = Message+ { _defaultText :: !Text -- ^ The default message contents (required by SNS)+ , _apnsPayload :: Maybe APNS.Payload -- ^ Optional production APNS payload+ , _apnsSandboxPayload :: Maybe APNS.Payload -- ^ Optional sandbox APNS payload+ } deriving (Show, Generic)++makeLenses ''Message++-- | A @pinpon@-specific default value for 'Message'.+defaultMessage :: Message+defaultMessage = Message "Someone is ringing the doorbell!" Nothing Nothing++instance ToJSON Message where+ toJSON (Message d p s) = object $! ["default" .= d] <> apns p <> apnsSandbox s+ where+ apns :: Maybe APNS.Payload -> [Pair]+ apns Nothing = mempty+ apns v = ["APNS" .= encodeText v]+ apnsSandbox :: Maybe APNS.Payload -> [Pair]+ apnsSandbox Nothing = mempty+ apnsSandbox v = ["APNS_SANDBOX" .= encodeText v]+ toEncoding (Message d p s) = pairs $! "default" .= d <> apns p <> apnsSandbox s+ where+ apns :: Maybe APNS.Payload -> Series+ apns Nothing = mempty+ apns v = "APNS" .= encodeText v+ apnsSandbox :: Maybe APNS.Payload -> Series+ apnsSandbox Nothing = mempty+ apnsSandbox v = "APNS_SANDBOX" .= encodeText v++-- $+-- >>> import Network.PinPon.WireTypes.APNS (Alert(..), Aps(..), Payload(..))+-- >>> import Data.Aeson (encode)+-- >>> let alert1 = Alert "This is a production alert title" "This is a production alert body"+-- >>> let aps1 = Aps alert1 "production default"+-- >>> let payload1 = Payload aps1+-- >>> let msg1 = Message "This is the default message" (Just payload1) Nothing+-- >>> let encodedMsg1 = encode $ toJSON msg1+-- >>> encodedMsg1 == "{\"default\":\"This is the default message\",\"APNS\":\"{\\\"aps\\\":{\\\"alert\\\":{\\\"title\\\":\\\"This is a production alert title\\\",\\\"body\\\":\\\"This is a production alert body\\\"},\\\"sound\\\":\\\"production default\\\"}}\"}" || encodedMsg1 == "{\"APNS\":\"{\\\"aps\\\":{\\\"alert\\\":{\\\"title\\\":\\\"This is a production alert title\\\",\\\"body\\\":\\\"This is a production alert body\\\"},\\\"sound\\\":\\\"production default\\\"}}\",\"default\":\"This is the default message\"}"+-- True+-- >>> let alert2 = Alert "This is a sandbox alert title" "This is a sandbox alert body"+-- >>> let aps2 = Aps alert2 "sandbox default"+-- >>> let payload2 = Payload aps2+-- >>> let msg2 = Message "This is the default message" Nothing (Just payload2)+-- >>> let encodedMsg2 = encode $ toJSON msg2+-- >>> encodedMsg2 == "{\"default\":\"This is the default message\",\"APNS_SANDBOX\":\"{\\\"aps\\\":{\\\"alert\\\":{\\\"title\\\":\\\"This is a sandbox alert title\\\",\\\"body\\\":\\\"This is a sandbox alert body\\\"},\\\"sound\\\":\\\"sandbox default\\\"}}\"}" || encodedMsg2 == "{\"default\":\"This is the default message\",\"APNS_SANDBOX\":\"{\\\"aps\\\":{\\\"alert\\\":{\\\"title\\\":\\\"This is a sandbox alert title\\\",\\\"body\\\":\\\"This is a sandbox alert body\\\"},\\\"sound\\\":\\\"sandbox default\\\"}}\"}"+-- True+-- >>> let msg3 = Message "This is the default message" (Just payload1) (Just payload2)+-- >>> let encodedMsg3 = encode $ toJSON msg3+-- >>> encodedMsg3 == "{\"default\":\"This is the default message\",\"APNS_SANDBOX\":\"{\\\"aps\\\":{\\\"alert\\\":{\\\"title\\\":\\\"This is a sandbox alert title\\\",\\\"body\\\":\\\"This is a sandbox alert body\\\"},\\\"sound\\\":\\\"sandbox default\\\"}}\",\"APNS\":\"{\\\"aps\\\":{\\\"alert\\\":{\\\"title\\\":\\\"This is a production alert title\\\",\\\"body\\\":\\\"This is a production alert body\\\"},\\\"sound\\\":\\\"production default\\\"}}\"}" || encodedMsg3 == "{\"APNS\":\"{\\\"aps\\\":{\\\"alert\\\":{\\\"title\\\":\\\"This is a production alert title\\\",\\\"body\\\":\\\"This is a production alert body\\\"},\\\"sound\\\":\\\"production default\\\"}}\",\"default\":\"This is the default message\",\"APNS_SANDBOX\":\"{\\\"aps\\\":{\\\"alert\\\":{\\\"title\\\":\\\"This is a sandbox alert title\\\",\\\"body\\\":\\\"This is a sandbox alert body\\\"},\\\"sound\\\":\\\"sandbox default\\\"}}\"}"+-- True
+ stack-lts-10.yaml view
@@ -0,0 +1,5 @@+require-stack-version: ">= 1.1.0"+pvp-bounds: both+resolver: lts-10.4+packages:+- .
+ stack-lts-9.yaml view
@@ -0,0 +1,7 @@+require-stack-version: ">= 1.1.0"+pvp-bounds: both+resolver: lts-9.21+packages:+- .+extra-deps:+- protolude-0.2
+ stack.yaml view
@@ -0,0 +1,5 @@+require-stack-version: ">= 1.1.0"+pvp-bounds: both+resolver: lts-10.4+packages:+- .
+ swagger.json view
@@ -0,0 +1,73 @@+{+ "swagger": "2.0",+ "info": {+ "version": "0.1",+ "title": "PinPon API",+ "license": {+ "url": "https://opensource.org/licenses/BSD-3-Clause",+ "name": "BSD3"+ },+ "description": "A simple Internet-enabled doorbell notificaion service"+ },+ "definitions": {+ "Notification": {+ "example": {+ "sound": "default",+ "headline": "Ring! Ring!",+ "message": "Someone is ringing the doorbell!"+ },+ "required": [+ "headline",+ "message",+ "sound"+ ],+ "type": "object",+ "description": "A doorbell notification",+ "properties": {+ "sound": {+ "type": "string"+ },+ "headline": {+ "type": "string"+ },+ "message": {+ "type": "string"+ }+ }+ }+ },+ "paths": {+ "/topic": {+ "post": {+ "consumes": [+ "application/json;charset=utf-8"+ ],+ "responses": {+ "400": {+ "description": "Invalid `body`"+ },+ "200": {+ "schema": {+ "$ref": "#/definitions/Notification"+ },+ "description": ""+ }+ },+ "produces": [+ "application/json;charset=utf-8",+ "text/html;charset=utf-8"+ ],+ "parameters": [+ {+ "required": true,+ "schema": {+ "$ref": "#/definitions/Notification"+ },+ "in": "body",+ "name": "body"+ }+ ]+ }+ }+ }+}
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/doctest.hs view
@@ -0,0 +1,7 @@+module Main where++import Protolude+import Test.DocTest++main :: IO ()+main = doctest ["src", "-XNoImplicitPrelude"]
+ test/hlint.hs view
@@ -0,0 +1,11 @@+module Main where++import Protolude+import Control.Monad (unless)+import Language.Haskell.HLint++main :: IO ()+main =+ do args <- getArgs+ hints <- hlint $ ["src", "--cpp-define=HLINT", "--cpp-ansi"] ++ args+ unless (null hints) exitFailure