diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. 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/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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. diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -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 +maintainer: Drew Hess +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 diff --git a/pinpon-gpio/Main.hs b/pinpon-gpio/Main.hs new file mode 100644 --- /dev/null +++ b/pinpon-gpio/Main.hs @@ -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.") + diff --git a/pinpon-ring/Main.hs b/pinpon-ring/Main.hs new file mode 100644 --- /dev/null +++ b/pinpon-ring/Main.hs @@ -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") diff --git a/pinpon.cabal b/pinpon.cabal new file mode 100644 --- /dev/null +++ b/pinpon.cabal @@ -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 +maintainer: Drew Hess +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 diff --git a/pinpon/Main.hs b/pinpon/Main.hs new file mode 100644 --- /dev/null +++ b/pinpon/Main.hs @@ -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" ) diff --git a/src/Network/PinPon.hs b/src/Network/PinPon.hs new file mode 100644 --- /dev/null +++ b/src/Network/PinPon.hs @@ -0,0 +1,3 @@ +module Network.PinPon + () + where diff --git a/src/Network/PinPon/API.hs b/src/Network/PinPon/API.hs new file mode 100644 --- /dev/null +++ b/src/Network/PinPon/API.hs @@ -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 diff --git a/src/Network/PinPon/API/Topic.hs b/src/Network/PinPon/API/Topic.hs new file mode 100644 --- /dev/null +++ b/src/Network/PinPon/API/Topic.hs @@ -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 diff --git a/src/Network/PinPon/AWS.hs b/src/Network/PinPon/AWS.hs new file mode 100644 --- /dev/null +++ b/src/Network/PinPon/AWS.hs @@ -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 diff --git a/src/Network/PinPon/Client.hs b/src/Network/PinPon/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/PinPon/Client.hs @@ -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 diff --git a/src/Network/PinPon/Config.hs b/src/Network/PinPon/Config.hs new file mode 100644 --- /dev/null +++ b/src/Network/PinPon/Config.hs @@ -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) diff --git a/src/Network/PinPon/Notification.hs b/src/Network/PinPon/Notification.hs new file mode 100644 --- /dev/null +++ b/src/Network/PinPon/Notification.hs @@ -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 diff --git a/src/Network/PinPon/SwaggerAPI.hs b/src/Network/PinPon/SwaggerAPI.hs new file mode 100644 --- /dev/null +++ b/src/Network/PinPon/SwaggerAPI.hs @@ -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) diff --git a/src/Network/PinPon/Util.hs b/src/Network/PinPon/Util.hs new file mode 100644 --- /dev/null +++ b/src/Network/PinPon/Util.hs @@ -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 diff --git a/src/Network/PinPon/WireTypes/APNS.hs b/src/Network/PinPon/WireTypes/APNS.hs new file mode 100644 --- /dev/null +++ b/src/Network/PinPon/WireTypes/APNS.hs @@ -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 + -- and + -- 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 +-- 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 +-- 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 +-- 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 diff --git a/src/Network/PinPon/WireTypes/SNS.hs b/src/Network/PinPon/WireTypes/SNS.hs new file mode 100644 --- /dev/null +++ b/src/Network/PinPon/WireTypes/SNS.hs @@ -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 diff --git a/stack-lts-10.yaml b/stack-lts-10.yaml new file mode 100644 --- /dev/null +++ b/stack-lts-10.yaml @@ -0,0 +1,5 @@ +require-stack-version: ">= 1.1.0" +pvp-bounds: both +resolver: lts-10.4 +packages: +- . diff --git a/stack-lts-9.yaml b/stack-lts-9.yaml new file mode 100644 --- /dev/null +++ b/stack-lts-9.yaml @@ -0,0 +1,7 @@ +require-stack-version: ">= 1.1.0" +pvp-bounds: both +resolver: lts-9.21 +packages: +- . +extra-deps: +- protolude-0.2 diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,5 @@ +require-stack-version: ">= 1.1.0" +pvp-bounds: both +resolver: lts-10.4 +packages: +- . diff --git a/swagger.json b/swagger.json new file mode 100644 --- /dev/null +++ b/swagger.json @@ -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" + } + ] + } + } + } +} diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/doctest.hs b/test/doctest.hs new file mode 100644 --- /dev/null +++ b/test/doctest.hs @@ -0,0 +1,7 @@ +module Main where + +import Protolude +import Test.DocTest + +main :: IO () +main = doctest ["src", "-XNoImplicitPrelude"] diff --git a/test/hlint.hs b/test/hlint.hs new file mode 100644 --- /dev/null +++ b/test/hlint.hs @@ -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