{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      : Network.DO.Spaces.Actions.UploadObject
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
module Network.DO.Spaces.Actions.UploadObject
    ( UploadObject(..)
    , UploadObjectResponse(..)
    ) where

import           Control.Monad.Catch       ( MonadThrow(throwM) )
import           Control.Monad.Reader      ( MonadReader(ask) )
import           Control.Monad.Trans.Maybe ( MaybeT(runMaybeT) )

import qualified Data.CaseInsensitive      as CI

import           GHC.Generics              ( Generic )

import           Network.DO.Spaces.Types
import           Network.DO.Spaces.Utils
import           Network.HTTP.Conduit      ( RequestBody )
import           Network.Mime              ( MimeType )

-- | Upload a single object to Spaces. The maximum size for a single PUT request
-- is 5 GB
data UploadObject = UploadObject
    { UploadObject -> Bucket
bucket          :: Bucket
    , UploadObject -> Object
object          :: Object
    , UploadObject -> RequestBody
body            :: RequestBody
    , UploadObject -> UploadHeaders
optionalHeaders :: UploadHeaders
    , UploadObject -> Maybe MimeType
contentType     :: Maybe MimeType
    }
    deriving stock ( (forall x. UploadObject -> Rep UploadObject x)
-> (forall x. Rep UploadObject x -> UploadObject)
-> Generic UploadObject
forall x. Rep UploadObject x -> UploadObject
forall x. UploadObject -> Rep UploadObject x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UploadObject x -> UploadObject
$cfrom :: forall x. UploadObject -> Rep UploadObject x
Generic )

data UploadObjectResponse = UploadObjectResponse
    { UploadObjectResponse -> ETag
etag          :: ETag
    , UploadObjectResponse -> Int
contentLength :: Int -- ^ Length in bytes
    }
    deriving stock ( Int -> UploadObjectResponse -> ShowS
[UploadObjectResponse] -> ShowS
UploadObjectResponse -> String
(Int -> UploadObjectResponse -> ShowS)
-> (UploadObjectResponse -> String)
-> ([UploadObjectResponse] -> ShowS)
-> Show UploadObjectResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UploadObjectResponse] -> ShowS
$cshowList :: [UploadObjectResponse] -> ShowS
show :: UploadObjectResponse -> String
$cshow :: UploadObjectResponse -> String
showsPrec :: Int -> UploadObjectResponse -> ShowS
$cshowsPrec :: Int -> UploadObjectResponse -> ShowS
Show, UploadObjectResponse -> UploadObjectResponse -> Bool
(UploadObjectResponse -> UploadObjectResponse -> Bool)
-> (UploadObjectResponse -> UploadObjectResponse -> Bool)
-> Eq UploadObjectResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UploadObjectResponse -> UploadObjectResponse -> Bool
$c/= :: UploadObjectResponse -> UploadObjectResponse -> Bool
== :: UploadObjectResponse -> UploadObjectResponse -> Bool
$c== :: UploadObjectResponse -> UploadObjectResponse -> Bool
Eq, (forall x. UploadObjectResponse -> Rep UploadObjectResponse x)
-> (forall x. Rep UploadObjectResponse x -> UploadObjectResponse)
-> Generic UploadObjectResponse
forall x. Rep UploadObjectResponse x -> UploadObjectResponse
forall x. UploadObjectResponse -> Rep UploadObjectResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UploadObjectResponse x -> UploadObjectResponse
$cfrom :: forall x. UploadObjectResponse -> Rep UploadObjectResponse x
Generic )

instance MonadSpaces m => Action m UploadObject where
    type ConsumedResponse UploadObject = UploadObjectResponse

    buildRequest :: UploadObject -> m SpacesRequestBuilder
buildRequest UploadObject { Maybe MimeType
RequestBody
UploadHeaders
Object
Bucket
contentType :: Maybe MimeType
optionalHeaders :: UploadHeaders
body :: RequestBody
object :: Object
bucket :: Bucket
$sel:contentType:UploadObject :: UploadObject -> Maybe MimeType
$sel:optionalHeaders:UploadObject :: UploadObject -> UploadHeaders
$sel:body:UploadObject :: UploadObject -> RequestBody
$sel:object:UploadObject :: UploadObject -> Object
$sel:bucket:UploadObject :: UploadObject -> Bucket
.. } = do
        Spaces
spaces <- m Spaces
forall r (m :: * -> *). MonadReader r m => m r
ask
        SpacesRequestBuilder -> m SpacesRequestBuilder
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpacesRequestBuilder :: Spaces
-> Maybe RequestBody
-> Maybe Method
-> [Header]
-> Maybe Bucket
-> Maybe Object
-> Maybe Query
-> Maybe Query
-> Maybe Region
-> SpacesRequestBuilder
SpacesRequestBuilder
             { $sel:bucket:SpacesRequestBuilder :: Maybe Bucket
bucket         = Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just Bucket
bucket
             , $sel:object:SpacesRequestBuilder :: Maybe Object
object         = Object -> Maybe Object
forall a. a -> Maybe a
Just Object
object
             , $sel:method:SpacesRequestBuilder :: Maybe Method
method         = Method -> Maybe Method
forall a. a -> Maybe a
Just Method
PUT
             , $sel:body:SpacesRequestBuilder :: Maybe RequestBody
body           = RequestBody -> Maybe RequestBody
forall a. a -> Maybe a
Just RequestBody
body
             , $sel:queryString:SpacesRequestBuilder :: Maybe Query
queryString    = Maybe Query
forall a. Maybe a
Nothing
             , $sel:subresources:SpacesRequestBuilder :: Maybe Query
subresources   = Maybe Query
forall a. Maybe a
Nothing
             , $sel:overrideRegion:SpacesRequestBuilder :: Maybe Region
overrideRegion = Maybe Region
forall a. Maybe a
Nothing
             , [Header]
Spaces
$sel:headers:SpacesRequestBuilder :: [Header]
$sel:spaces:SpacesRequestBuilder :: Spaces
headers :: [Header]
spaces :: Spaces
..
             }
      where
        headers :: [Header]
headers = ([Header] -> [Header])
-> (MimeType -> [Header] -> [Header])
-> Maybe MimeType
-> [Header]
-> [Header]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Header] -> [Header]
forall a. a -> a
id
                        (\MimeType
ct -> (:) (MimeType -> CI MimeType
forall s. FoldCase s => s -> CI s
CI.mk MimeType
"Content-Type", MimeType
ct))
                        Maybe MimeType
contentType
                        (UploadHeaders -> [Header]
renderUploadHeaders UploadHeaders
optionalHeaders)

    consumeResponse :: RawResponse m -> m (ConsumedResponse UploadObject)
consumeResponse RawResponse m
raw = do
        Maybe UploadObjectResponse
resp <- MaybeT m UploadObjectResponse -> m (Maybe UploadObjectResponse)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
            (MaybeT m UploadObjectResponse -> m (Maybe UploadObjectResponse))
-> MaybeT m UploadObjectResponse -> m (Maybe UploadObjectResponse)
forall a b. (a -> b) -> a -> b
$ ETag -> Int -> UploadObjectResponse
UploadObjectResponse (ETag -> Int -> UploadObjectResponse)
-> MaybeT m ETag -> MaybeT m (Int -> UploadObjectResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MimeType -> MaybeT m ETag
forall (m :: * -> *). Monad m => MimeType -> MaybeT m ETag
readEtag (MimeType -> MaybeT m ETag) -> MaybeT m MimeType -> MaybeT m ETag
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CI MimeType -> MaybeT m MimeType
lookupHeader' CI MimeType
"etag")
            MaybeT m (Int -> UploadObjectResponse)
-> MaybeT m Int -> MaybeT m UploadObjectResponse
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (MimeType -> MaybeT m Int
forall (m :: * -> *). Monad m => MimeType -> MaybeT m Int
readContentLen (MimeType -> MaybeT m Int) -> MaybeT m MimeType -> MaybeT m Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CI MimeType -> MaybeT m MimeType
lookupHeader' CI MimeType
"Content-Length")
        case Maybe UploadObjectResponse
resp of
            Just UploadObjectResponse
r  -> UploadObjectResponse -> m UploadObjectResponse
forall (f :: * -> *) a. Applicative f => a -> f a
pure UploadObjectResponse
r
            Maybe UploadObjectResponse
Nothing -> ClientException -> m UploadObjectResponse
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ClientException -> m UploadObjectResponse)
-> ClientException -> m UploadObjectResponse
forall a b. (a -> b) -> a -> b
$ ETag -> ClientException
InvalidResponse ETag
"Missing/malformed headers"
      where
        lookupHeader' :: CI MimeType -> MaybeT m MimeType
lookupHeader' = RawResponse m -> CI MimeType -> MaybeT m MimeType
forall (m :: * -> *).
Monad m =>
RawResponse m -> CI MimeType -> MaybeT m MimeType
lookupHeader RawResponse m
raw