{-# LANGUAGE OverloadedStrings #-}
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)
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 :: 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 :: 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)