diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for postmark-streams + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/postmark-streams.cabal b/postmark-streams.cabal new file mode 100644 --- /dev/null +++ b/postmark-streams.cabal @@ -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 diff --git a/src/Postmark.hs b/src/Postmark.hs new file mode 100644 --- /dev/null +++ b/src/Postmark.hs @@ -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) diff --git a/src/Postmark/Request.hs b/src/Postmark/Request.hs new file mode 100644 --- /dev/null +++ b/src/Postmark/Request.hs @@ -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]] diff --git a/src/Postmark/Response.hs b/src/Postmark/Response.hs new file mode 100644 --- /dev/null +++ b/src/Postmark/Response.hs @@ -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