{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Network.AWS.Data.Body where
import Control.Monad.Trans.Resource
import Data.Aeson
import qualified Data.ByteString as BS
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS8
import Data.Conduit
import Data.HashMap.Strict (HashMap)
import Data.Monoid
import Data.String
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as LText
import qualified Data.Text.Lazy.Encoding as LText
import Network.AWS.Data.ByteString
import Network.AWS.Data.Crypto
import Network.AWS.Data.Log
import Network.AWS.Data.Query (QueryString)
import Network.AWS.Data.XML (encodeXML)
import Network.AWS.Lens (AReview, Lens', lens, to, un)
import Network.HTTP.Conduit
import Text.XML (Element)
default (Builder)
newtype RsBody = RsBody
{ _streamBody :: ResumableSource (ResourceT IO) ByteString
}
instance Show RsBody where
show = const "RsBody { ResumableSource (ResourceT IO) ByteString }"
fuseStream :: RsBody
-> Conduit ByteString (ResourceT IO) ByteString
-> RsBody
fuseStream b f = b { _streamBody = _streamBody b $=+ f }
newtype ChunkSize = ChunkSize Int
deriving (Eq, Ord, Show, Enum, Num, Real, Integral)
instance ToLog ChunkSize where
build = build . show
defaultChunkSize :: ChunkSize
defaultChunkSize = 128 * 1024
data ChunkedBody = ChunkedBody
{ _chunkedSize :: !ChunkSize
, _chunkedLength :: !Integer
, _chunkedBody :: Source (ResourceT IO) ByteString
}
chunkedLength :: Lens' ChunkedBody Integer
chunkedLength = lens _chunkedLength (\s a -> s { _chunkedLength = a })
instance Show ChunkedBody where
show c = BS8.unpack . toBS $ build
"ChunkedBody { chunkSize = "
<> build (_chunkedSize c)
<> "<> originalLength = "
<> build (_chunkedLength c)
<> "<> fullChunks = "
<> build (fullChunks c)
<> "<> remainderBytes = "
<> build (remainderBytes c)
<> "}"
fuseChunks :: ChunkedBody
-> Conduit ByteString (ResourceT IO) ByteString
-> ChunkedBody
fuseChunks c f = c { _chunkedBody = _chunkedBody c =$= f }
fullChunks :: ChunkedBody -> Integer
fullChunks c = _chunkedLength c `div` fromIntegral (_chunkedSize c)
remainderBytes :: ChunkedBody -> Maybe Integer
remainderBytes c =
case _chunkedLength c `mod` toInteger (_chunkedSize c) of
0 -> Nothing
n -> Just n
data HashedBody
= HashedStream (Digest SHA256) !Integer (Source (ResourceT IO) ByteString)
| HashedBytes (Digest SHA256) ByteString
instance Show HashedBody where
show = \case
HashedStream h n _ -> str "HashedStream" h n
HashedBytes h x -> str "HashedBody" h (BS.length x)
where
str c h n = BS8.unpack . toBS $
c <> " { sha256 = "
<> build (digestToBase Base16 h)
<> ", length = "
<> build n
instance IsString HashedBody where
fromString = toHashed
sha256Base16 :: HashedBody -> ByteString
sha256Base16 = digestToBase Base16 . \case
HashedStream h _ _ -> h
HashedBytes h _ -> h
data RqBody
= Chunked ChunkedBody
| Hashed HashedBody
deriving (Show)
instance IsString RqBody where
fromString = Hashed . fromString
md5Base64 :: RqBody -> Maybe ByteString
md5Base64 = \case
Hashed (HashedBytes _ x) -> Just . digestToBase Base64 $ hashMD5 x
_ -> Nothing
isStreaming :: RqBody -> Bool
isStreaming = \case
Hashed (HashedStream {}) -> True
_ -> False
toRequestBody :: RqBody -> RequestBody
toRequestBody = \case
Chunked x -> requestBodySourceChunked (_chunkedBody x)
Hashed x -> case x of
HashedStream _ n f -> requestBodySource (fromIntegral n) f
HashedBytes _ b -> RequestBodyBS b
contentLength :: RqBody -> Integer
contentLength = \case
Chunked x -> _chunkedLength x
Hashed x -> case x of
HashedStream _ n _ -> n
HashedBytes _ b -> fromIntegral (BS.length b)
class ToHashedBody a where
toHashed :: a -> HashedBody
instance ToHashedBody ByteString where
toHashed x = HashedBytes (hash x) x
instance ToHashedBody HashedBody where toHashed = id
instance ToHashedBody String where toHashed = toHashed . LBS8.pack
instance ToHashedBody LBS.ByteString where toHashed = toHashed . toBS
instance ToHashedBody Text where toHashed = toHashed . Text.encodeUtf8
instance ToHashedBody LText.Text where toHashed = toHashed . LText.encodeUtf8
instance ToHashedBody Value where toHashed = toHashed . encode
instance ToHashedBody Element where toHashed = toHashed . encodeXML
instance ToHashedBody QueryString where toHashed = toHashed . toBS
instance ToHashedBody (HashMap Text Value) where
toHashed = toHashed . Object
class ToBody a where
toBody :: a -> RqBody
default toBody :: ToHashedBody a => a -> RqBody
toBody = Hashed . toHashed
instance ToBody RqBody where toBody = id
instance ToBody HashedBody where toBody = Hashed
instance ToBody ChunkedBody where toBody = Chunked
instance ToHashedBody a => ToBody (Maybe a) where
toBody = Hashed . maybe (toHashed BS.empty) toHashed
instance ToBody String
instance ToBody LBS.ByteString
instance ToBody ByteString
instance ToBody Text
instance ToBody LText.Text
instance ToBody (HashMap Text Value)
instance ToBody Value
instance ToBody Element
instance ToBody QueryString
_Body :: ToBody a => AReview RqBody a
_Body = un (to toBody)