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

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

import           Control.Monad           ( when )
import           Control.Monad.Catch     ( MonadThrow(throwM) )
import           Control.Monad.Reader    ( MonadReader(ask) )

import qualified Data.ByteString.Char8   as C
import qualified Data.CaseInsensitive    as CI
import           Data.Char               ( toUpper )
import           Data.Coerce             ( coerce )
import           Data.Maybe              ( catMaybes )
import qualified Data.Text.Encoding      as T
import           Data.Time               ( UTCTime )

import           GHC.Generics            ( Generic )

import           Network.DO.Spaces.Types
import           Network.DO.Spaces.Utils

-- | Whether the 'Object'\'s metadata should be copied or replaced. Replace is
-- required to copy an object to itself
data MetadataDirective
    = Copy
    | Replace
    deriving stock ( Int -> MetadataDirective -> ShowS
[MetadataDirective] -> ShowS
MetadataDirective -> String
(Int -> MetadataDirective -> ShowS)
-> (MetadataDirective -> String)
-> ([MetadataDirective] -> ShowS)
-> Show MetadataDirective
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MetadataDirective] -> ShowS
$cshowList :: [MetadataDirective] -> ShowS
show :: MetadataDirective -> String
$cshow :: MetadataDirective -> String
showsPrec :: Int -> MetadataDirective -> ShowS
$cshowsPrec :: Int -> MetadataDirective -> ShowS
Show, MetadataDirective -> MetadataDirective -> Bool
(MetadataDirective -> MetadataDirective -> Bool)
-> (MetadataDirective -> MetadataDirective -> Bool)
-> Eq MetadataDirective
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MetadataDirective -> MetadataDirective -> Bool
$c/= :: MetadataDirective -> MetadataDirective -> Bool
== :: MetadataDirective -> MetadataDirective -> Bool
$c== :: MetadataDirective -> MetadataDirective -> Bool
Eq, (forall x. MetadataDirective -> Rep MetadataDirective x)
-> (forall x. Rep MetadataDirective x -> MetadataDirective)
-> Generic MetadataDirective
forall x. Rep MetadataDirective x -> MetadataDirective
forall x. MetadataDirective -> Rep MetadataDirective x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MetadataDirective x -> MetadataDirective
$cfrom :: forall x. MetadataDirective -> Rep MetadataDirective x
Generic )

-- | Copy and 'Object' from one 'Bucket' to another. Both buckets must
-- be in the same region
data CopyObject = CopyObject
    { CopyObject -> Bucket
srcBucket         :: Bucket
    , CopyObject -> Bucket
destBucket        :: Bucket
    , CopyObject -> Object
srcObject         :: Object
    , CopyObject -> Object
destObject        :: Object
    , CopyObject -> MetadataDirective
metadataDirective :: MetadataDirective
    , CopyObject -> Maybe CannedACL
acl               :: Maybe CannedACL
    }
    deriving stock ( Int -> CopyObject -> ShowS
[CopyObject] -> ShowS
CopyObject -> String
(Int -> CopyObject -> ShowS)
-> (CopyObject -> String)
-> ([CopyObject] -> ShowS)
-> Show CopyObject
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CopyObject] -> ShowS
$cshowList :: [CopyObject] -> ShowS
show :: CopyObject -> String
$cshow :: CopyObject -> String
showsPrec :: Int -> CopyObject -> ShowS
$cshowsPrec :: Int -> CopyObject -> ShowS
Show, CopyObject -> CopyObject -> Bool
(CopyObject -> CopyObject -> Bool)
-> (CopyObject -> CopyObject -> Bool) -> Eq CopyObject
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CopyObject -> CopyObject -> Bool
$c/= :: CopyObject -> CopyObject -> Bool
== :: CopyObject -> CopyObject -> Bool
$c== :: CopyObject -> CopyObject -> Bool
Eq, (forall x. CopyObject -> Rep CopyObject x)
-> (forall x. Rep CopyObject x -> CopyObject) -> Generic CopyObject
forall x. Rep CopyObject x -> CopyObject
forall x. CopyObject -> Rep CopyObject x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CopyObject x -> CopyObject
$cfrom :: forall x. CopyObject -> Rep CopyObject x
Generic )

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

instance MonadSpaces m => Action m CopyObject where
    type ConsumedResponse CopyObject = CopyObjectResponse

    buildRequest :: CopyObject -> m SpacesRequestBuilder
buildRequest CopyObject { Maybe CannedACL
Object
Bucket
MetadataDirective
acl :: Maybe CannedACL
metadataDirective :: MetadataDirective
destObject :: Object
srcObject :: Object
destBucket :: Bucket
srcBucket :: Bucket
$sel:acl:CopyObject :: CopyObject -> Maybe CannedACL
$sel:metadataDirective:CopyObject :: CopyObject -> MetadataDirective
$sel:destObject:CopyObject :: CopyObject -> Object
$sel:srcObject:CopyObject :: CopyObject -> Object
$sel:destBucket:CopyObject :: CopyObject -> Bucket
$sel:srcBucket:CopyObject :: CopyObject -> Bucket
.. } = do
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Object
srcObject Object -> Object -> Bool
forall a. Eq a => a -> a -> Bool
== Object
destObject, MetadataDirective
metadataDirective MetadataDirective -> MetadataDirective -> Bool
forall a. Eq a => a -> a -> Bool
== MetadataDirective
Copy ])
            (m () -> m ()) -> (ETag -> m ()) -> ETag -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
            (ClientException -> m ())
-> (ETag -> ClientException) -> ETag -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ETag -> ClientException
InvalidRequest
            (ETag -> m ()) -> ETag -> m ()
forall a b. (a -> b) -> a -> b
$ [ETag] -> ETag
forall a. Monoid a => [a] -> a
mconcat [ ETag
"CopyObject: "
                      , ETag
"Object cannot be copied to itself unless "
                      , ETag
"REPLACE directive is specified"
                      ]
        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:object:SpacesRequestBuilder :: Maybe Object
object         = Object -> Maybe Object
forall a. a -> Maybe a
Just Object
destObject
             , $sel:bucket:SpacesRequestBuilder :: Maybe Bucket
bucket         = Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just Bucket
destBucket
             , $sel:method:SpacesRequestBuilder :: Maybe Method
method         = Method -> Maybe Method
forall a. a -> Maybe a
Just Method
PUT
             , $sel:body:SpacesRequestBuilder :: Maybe RequestBody
body           = Maybe RequestBody
forall a. Maybe a
Nothing
             , $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 = [ ( ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"x-amz-copy-source"
                    , [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [ ByteString
"/"
                              , ETag -> ByteString
T.encodeUtf8 (ETag -> ByteString) -> ETag -> ByteString
forall a b. (a -> b) -> a -> b
$ Bucket -> ETag
coerce Bucket
srcBucket
                              , ByteString
"/"
                              , ETag -> ByteString
T.encodeUtf8 (ETag -> ByteString) -> ETag -> ByteString
forall a b. (a -> b) -> a -> b
$ Object -> ETag
coerce Object
srcObject
                              ]
                    )
                  , ( ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"x-amz-metadata-directive"
                    , (Char -> Char) -> ByteString -> ByteString
C.map Char -> Char
toUpper (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ MetadataDirective -> ByteString
forall a. Show a => a -> ByteString
bshow MetadataDirective
metadataDirective
                    )
                  ]
            [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [Maybe Header] -> [Header]
forall a. [Maybe a] -> [a]
catMaybes [ (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"x-amz-acl", ) (ByteString -> Header)
-> (CannedACL -> ByteString) -> CannedACL -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CannedACL -> ByteString
forall a. IsString a => CannedACL -> a
showCannedACL (CannedACL -> Header) -> Maybe CannedACL -> Maybe Header
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CannedACL
acl ]

    consumeResponse :: RawResponse m -> m (ConsumedResponse CopyObject)
consumeResponse RawResponse m
raw = do
        Cursor
cursor <- RawResponse m -> m Cursor
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
RawResponse m -> m Cursor
xmlDocCursor RawResponse m
raw
        ETag -> UTCTime -> CopyObjectResponse
CopyObjectResponse (ETag -> UTCTime -> CopyObjectResponse)
-> m ETag -> m (UTCTime -> CopyObjectResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cursor -> m ETag
forall (m :: * -> *). MonadThrow m => Cursor -> m ETag
etagP Cursor
cursor m (UTCTime -> CopyObjectResponse)
-> m UTCTime -> m CopyObjectResponse
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Cursor -> m UTCTime
forall (m :: * -> *). MonadThrow m => Cursor -> m UTCTime
lastModifiedP Cursor
cursor