postmark-streams (empty) → 0.1.0.0
raw patch · 7 files changed
+360/−0 lines, 7 filesdep +aesondep +attoparsecdep +basesetup-changed
Dependencies added: aeson, attoparsec, base, base64-bytestring, binary, bytestring, http-streams, io-streams, text, time
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- postmark-streams.cabal +47/−0
- src/Postmark.hs +142/−0
- src/Postmark/Request.hs +88/−0
- src/Postmark/Response.hs +46/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for postmark-streams++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Petter Bergman++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 Petter Bergman 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ postmark-streams.cabal view
@@ -0,0 +1,47 @@+-- Initial postmark-streams.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: postmark-streams+version: 0.1.0.0+synopsis: Send email via Postmark using io-streams.+description:+ Send email via Postmark using io-streams.+license: BSD3+license-file: LICENSE+author: Petter Bergman+maintainer: jon.petter.bergman@gmail.com+-- copyright: +category: Network+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10+++source-repository head+ type: git+ location: git://github.com/jonpetterbergman/pidfile.git+source-repository this+ type: git+ location: git://github.com/jonpetterbergman/pidfile.git+ tag: v0.1.0.0+ + ++library+ exposed-modules: Postmark,+ Postmark.Request,+ Postmark.Response+-- other-modules: Postmark.Request, Postmark.Response + other-extensions: OverloadedStrings+ build-depends: base >=4.9 && <4.10,+ aeson >=1.1 && <1.2,+ attoparsec >=0.13 && <0.14,+ binary >=0.8 && <0.9,+ bytestring >=0.10 && <0.11,+ http-streams >=0.8 && <0.9,+ io-streams >=1.3 && <1.4,+ text >=1.2 && <1.3,+ base64-bytestring >=1.0 && <1.1,+ time >=1.6 && <1.7+ hs-source-dirs: src+ default-language: Haskell2010
+ src/Postmark.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module: $HEADER$+--+-- Send email via Postmark using io-streams. +module Postmark(send,sendStream,Error(..)) where++import Control.Applicative ((<|>))+import Control.Exception (bracket)+import Control.Monad (when)+import Data.Aeson (FromJSON, ToJSON, encode)+import Data.Aeson (Result, Value, fromJSON, json')+import qualified Data.Aeson as Aeson+import Data.Attoparsec.ByteString (Parser)+import Data.Binary.Builder (Builder)+import qualified Data.Binary.Builder as Builder+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import Data.ByteString.Lazy (toChunks)+import Data.Char (isSpace)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Maybe (isJust)+import Debug.Trace+import Network.Http.Client+import Postmark.Request (Email)+import qualified Postmark.Request as PRes+import qualified Postmark.Response as PRes+import System.IO.Streams (InputStream, OutputStream,+ makeInputStream,+ makeOutputStream, readExactly,+ takeBytesWhile, unRead, write)+import qualified System.IO.Streams as Streams+import System.IO.Streams.Attoparsec (parseFromStream)+import qualified System.IO.Streams.Attoparsec as AStreams+import System.IO.Streams.Debug (debugInputBS, debugOutput)++-- | Error type+data Error =+ Raw StatusCode ByteString + | API PRes.Error deriving Show++singleUrl :: ByteString+singleUrl = "https://api.postmarkapp.com/email"++batchUrl :: ByteString+batchUrl = "https://api.postmarkapp.com/email/batch"++-- | @'send' token email@ sends a single mail via Postmark.+-- @token@ is your Postmark server token or the test-token,+-- \"POSTMARK_API_TEST\" for testing purposes.+send :: ByteString -> Email -> IO (Either Error PRes.Success)+send token r = withConnection (establishConnection singleUrl) $ \connection ->+ do+ sendRequest connection (req singleUrl token) (jsonBody r)+ receiveResponse connection decodeResponse'++-- | @'sendStream' token build process@ sends a stream of emails+-- via Postmark's batch email API.+sendStream :: ByteString+ -> (OutputStream Email -> IO ())+ -> (InputStream (Either PRes.Error PRes.Success) -> IO r)+ -> IO (Either Error r)+sendStream token build process = withConnection (establishConnection batchUrl) $ \connection ->+ do+ sendRequest connection (req batchUrl token) $ \o -> build =<< jsonOutputStream o+ receiveResponse connection $ decodeResponse $ \i -> process =<< jsonInputStream successOrError i++req :: ByteString -> ByteString -> Request+req url token = buildRequest1 $ do+ http POST url+ setAccept "application/json"+ setContentType "application/json"+ setHeader "X-Postmark-Server-Token" token++jsonBody :: ToJSON a => a -> OutputStream Builder -> IO ()+jsonBody v o = write (Just $ Builder.fromLazyByteString $ encode v) o++decodeResponse :: (InputStream ByteString -> IO r)+ -> Response+ -> InputStream ByteString+ -> IO (Either Error r)+decodeResponse success r i = decodeStatus $ getStatusCode r+ where decodeStatus 200 = fmap Right $ success i+ decodeStatus 422 = fmap (Left . API) $ jsonFromStream fromJSON i+ decodeStatus x = return $ Left $ Raw x $ getStatusMessage r++decodeResponse' :: Response -> InputStream ByteString -> IO (Either Error PRes.Success)+decodeResponse' = decodeResponse $ jsonFromStream fromJSON++jsonFromStream :: (Value -> Result a) -> InputStream ByteString -> IO a+jsonFromStream f i =+ do+ v <- parseFromStream json' i+ case f v of+ Aeson.Success x -> return x+ Aeson.Error str -> error str++delim :: a -> a -> a -> OutputStream a -> IO (OutputStream a)+delim start sep end o = newIORef True >>= makeOutputStream . f+ where f _ Nothing = write (Just end) o+ f sRef s = do atStart <- readIORef sRef+ writeIORef sRef False+ if atStart then write (Just start) o else write (Just sep) o+ write s o++jsonOutputStream :: ToJSON a => OutputStream Builder -> IO (OutputStream a)+jsonOutputStream o =+ Streams.contramap (Builder.fromLazyByteString . encode) =<<+ delim "[\n" ",\n" "]\n\n" o++match :: ByteString -> InputStream ByteString -> IO (Maybe ByteString)+match m i = readExactly (ByteString.length m) i >>= go+ where go bs | bs == m = return $ Just bs+ | otherwise = do unRead bs i+ return Nothing++space :: InputStream ByteString -> IO ()+space i = takeBytesWhile isSpace i >> return ()++spaceMatch :: ByteString -> InputStream ByteString -> IO (Maybe ByteString)+spaceMatch m i = space i >> match m i++spaceMatch' :: ByteString -> InputStream ByteString -> IO ()+spaceMatch' m i = fmap (maybe (error $ "match': expected: " ++ show m) (const ())) $ spaceMatch m i++jsonInputStream :: (Value -> Result a) -> InputStream ByteString -> IO (InputStream a)+jsonInputStream f i =+ do+ spaceMatch' "[" i+ as <- newIORef True+ makeInputStream $ go as+ where go as = spaceMatch "]" i >>= go'+ where go' end | isJust end = return Nothing+ | otherwise =+ do+ atStart <- readIORef as+ when (not atStart) $ spaceMatch' "," i+ writeIORef as False+ fmap Just $ jsonFromStream f i++successOrError :: Value -> Result (Either PRes.Error PRes.Success)+successOrError v = (fmap Left $ fromJSON v) <|> (fmap Right $ fromJSON v)
+ src/Postmark/Request.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module: $HEADER$+--+-- Postmark email requests.+module Postmark.Request(Email(..),TrackLinks(..),Attachment(..),Body(..)) where++import Data.Aeson (ToJSON (..), Value (..), object, (.=))+import Data.Aeson.Types (Pair)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Base64 as Base64+import Data.Text (Text, intercalate)+import Data.Text.Encoding (decodeUtf8)++-- | Body can be html, plain-text or both+data Body =+ Html Text+ | Plain Text+ | HtmlPlain Text Text++encBody :: Body -> [Pair]+encBody (Html v) = ["HtmlBody" .= v]+encBody (Plain p) = ["TextBody" .= p]+encBody (HtmlPlain v p) = ["HtmlBody" .= v,"TextBody" .= p]++encHeaders :: [(Text,Text)] -> Value+encHeaders = toJSON . map go+ where go (k,v) = object ["Name" .= k,"Value" .= v]++-- | Activate link-tracking for the selected body types.+data TrackLinks =+ None+ | HtmlAndText+ | HtmlOnly+ | TextOnly++encTrackLinks :: TrackLinks -> Text+encTrackLinks None = "None"+encTrackLinks HtmlAndText = "HtmlAndText"+encTrackLinks HtmlOnly = "HtmlOnly"+encTrackLinks TextOnly = "TextOnly"++-- | The type of attachments.+data Attachment =+ Attachment {+ name :: Text+ , content :: ByteString+ , contentType :: Text }++instance ToJSON Attachment where+ toJSON a = object+ ["Name" .= name a,+ "Content" .= (decodeUtf8 $ Base64.encode $ content a),+ "ContentType" .= contentType a]++-- | The type of email requests.+data Email =+ Email {+ from :: Text+ , to :: (Text,[Text])+ , cc :: [Text]+ , bcc :: [Text]+ , subject :: Maybe Text+ , tag :: Maybe Text+ , body :: Body+ , replyTo :: Maybe Text+ , headers :: [(Text,Text)]+ , trackOpens :: Bool+ , trackLinks :: TrackLinks+ , attachments :: [Attachment] }++toCommaSeparated :: [Text] -> Text+toCommaSeparated = intercalate ","++instance ToJSON Email where+ toJSON r = object $ concat+ [["From" .= from r+ ,"To" .= (toCommaSeparated $ (\(p,xs) -> p:xs) $ to r)+ ,"Cc" .= (toCommaSeparated $ cc r)+ ,"Bcc" .= (toCommaSeparated $ bcc r)]+ ,maybe [] (\s -> ["Subject" .= s]) $ subject r+ ,maybe [] (\t -> ["Tag" .= t]) $ tag r+ ,encBody $ body r+ ,maybe [] (\rt -> ["ReplyTo" .= rt]) $ replyTo r+ ,["Headers" .= (encHeaders $ headers r)+ ,"TrackOpens" .= trackOpens r+ ,"TrackLinks" .= (encTrackLinks $ trackLinks r)+ ,"Attachments" .= attachments r]]
+ src/Postmark/Response.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module: $HEADER$+--+-- Postmark email responses.+module Postmark.Response(Status(..),Error,Success(..)) where++import Data.Aeson (FromJSON (..), Value (..), (.:))+import Data.Aeson.Types (typeMismatch)+import Data.Text (Text,split)+import Data.Time (ZonedTime)+import Data.Word (Word32)++-- | Status code+data Status =+ Status {+ errorCode :: Word32+ , message :: Text+} deriving Show++-- | In case of an API error, only a 'Status' is returned+type Error = Status++instance FromJSON Status where+ parseJSON (Object o) = Status <$> o .: "ErrorCode" <*> o .: "Message"+ parseJSON invalid = typeMismatch "Status" invalid++-- | In case of success, 'Success' is returned+data Success =+ Success {+ status :: Status+ , submittedAt :: ZonedTime+ , messageID :: Text+ , to_ :: [Text] } deriving Show++fromCommaSeparated :: Text -> [Text]+fromCommaSeparated = split (== ',')++instance FromJSON Success where+ parseJSON (Object o) =+ Success <$>+ parseJSON (Object o) <*>+ o .: "SubmittedAt" <*>+ o .: "MessageID" <*>+ fmap fromCommaSeparated (o .: "To")+ parseJSON invalid = typeMismatch "Success" invalid