{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Network.DO.Spaces.Actions
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
-- This module re-exports the 'Action' instances in the modules below it
--
module Network.DO.Spaces.Actions
    ( runAction
    , parseErrorResponse
      -- * Re-exports
    , module M
    ) where

import           Conduit
                 ( (.|)
                 , runConduit
                 )

import           Control.Monad                                   ( when )
import           Control.Monad.Catch
                 ( MonadThrow
                 , throwM
                 )
import           Control.Monad.IO.Class
                 ( MonadIO(liftIO)
                 )

import           Data.Conduit.Binary                             ( sinkLbs )
import           Data.Function                                   ( (&) )
import           Data.Time
                 ( getCurrentTime
                 )

import           Network.DO.Spaces.Actions.CopyObject            as M
import           Network.DO.Spaces.Actions.CreateBucket          as M
import           Network.DO.Spaces.Actions.DeleteBucket          as M
import           Network.DO.Spaces.Actions.DeleteBucketCORS      as M
import           Network.DO.Spaces.Actions.DeleteBucketLifecycle as M
import           Network.DO.Spaces.Actions.DeleteObject          as M
import           Network.DO.Spaces.Actions.GetBucketACLs         as M
import           Network.DO.Spaces.Actions.GetBucketCORS         as M
import           Network.DO.Spaces.Actions.GetBucketLifecycle    as M
import           Network.DO.Spaces.Actions.GetBucketLocation     as M
import           Network.DO.Spaces.Actions.GetObject             as M
import           Network.DO.Spaces.Actions.GetObjectACLs         as M
import           Network.DO.Spaces.Actions.GetObjectInfo         as M
import           Network.DO.Spaces.Actions.ListAllBuckets        as M
import           Network.DO.Spaces.Actions.ListBucket            as M
import           Network.DO.Spaces.Actions.SetBucketACLs         as M
import           Network.DO.Spaces.Actions.SetBucketCORS         as M
import           Network.DO.Spaces.Actions.SetBucketLifecycle    as M
import           Network.DO.Spaces.Actions.SetObjectACLs         as M
import           Network.DO.Spaces.Actions.UploadMultipart       as M
import           Network.DO.Spaces.Actions.UploadObject          as M
import           Network.DO.Spaces.Request
                 ( finalize
                 , mkAuthorization
                 , mkStringToSign
                 , newSpacesRequest
                 )
import           Network.DO.Spaces.Types
                 ( APIException(..)
                 , Action(..)
                 , ClientException(HTTPStatus)
                 , MonadSpaces
                 , RawResponse(..)
                 , SpacesResponse(..)
                 , WithMetadata(NoMetadata, KeepMetadata)
                 )
import           Network.DO.Spaces.Utils
                 ( getResponseMetadata
                 , handleMaybe
                 , xmlDocCursor
                 , xmlElemError
                 )
import           Network.HTTP.Client.Conduit                     ( withResponse
                                                                 )
import qualified Network.HTTP.Conduit                            as H
import qualified Network.HTTP.Types                              as H
import           Network.HTTP.Types                              ( Status )

import qualified Text.XML.Cursor                                 as X
import           Text.XML.Cursor
                 ( ($/)
                 , (&/)
                 )

-- | Run an instance of 'Action', receiving a 'ConsumedResponse'. The retention
-- of 'Network.DO.Spaces.Types.SpacesMetadata' can be controlled by passing a
-- 'Network.DO.Spaces.Types.WithMetadata' constructor
runAction :: forall a m.
          (MonadSpaces m, Action m a)
          => WithMetadata
          -> a
          -> m (SpacesResponse a)
runAction :: WithMetadata -> a -> m (SpacesResponse a)
runAction WithMetadata
withMD a
action = do
    UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    SpacesRequestBuilder
reqBuilder <- a -> m SpacesRequestBuilder
forall (m :: * -> *) a. Action m a => a -> m SpacesRequestBuilder
buildRequest a
action
    SpacesRequest
req <- SpacesRequestBuilder -> UTCTime -> m SpacesRequest
forall (m :: * -> *).
MonadThrow m =>
SpacesRequestBuilder -> UTCTime -> m SpacesRequest
newSpacesRequest SpacesRequestBuilder
reqBuilder UTCTime
now
    let stringToSign :: StringToSign
stringToSign = SpacesRequest -> StringToSign
mkStringToSign SpacesRequest
req
        auth :: Authorization
auth         = SpacesRequest -> StringToSign -> Authorization
mkAuthorization SpacesRequest
req StringToSign
stringToSign
        finalized :: Request
finalized    = SpacesRequest -> Authorization -> Request
finalize SpacesRequest
req Authorization
auth

    Request
-> (Response (ConduitM () ByteString m ()) -> m (SpacesResponse a))
-> m (SpacesResponse a)
forall (m :: * -> *) (n :: * -> *) env i a.
(MonadUnliftIO m, MonadIO n, MonadReader env m,
 HasHttpManager env) =>
Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a
withResponse @_ @m Request
finalized ((Response (ConduitM () ByteString m ()) -> m (SpacesResponse a))
 -> m (SpacesResponse a))
-> (Response (ConduitM () ByteString m ()) -> m (SpacesResponse a))
-> m (SpacesResponse a)
forall a b. (a -> b) -> a -> b
$ \Response (ConduitM () ByteString m ())
resp -> do
        let status :: Status
status   = Response (ConduitM () ByteString m ())
resp Response (ConduitM () ByteString m ())
-> (Response (ConduitM () ByteString m ()) -> Status) -> Status
forall a b. a -> (a -> b) -> b
& Response (ConduitM () ByteString m ()) -> Status
forall body. Response body -> Status
H.responseStatus
            body :: ConduitM () ByteString m ()
body     = Response (ConduitM () ByteString m ())
resp Response (ConduitM () ByteString m ())
-> (Response (ConduitM () ByteString m ())
    -> ConduitM () ByteString m ())
-> ConduitM () ByteString m ()
forall a b. a -> (a -> b) -> b
& Response (ConduitM () ByteString m ())
-> ConduitM () ByteString m ()
forall body. Response body -> body
H.responseBody
            headers :: ResponseHeaders
headers  = Response (ConduitM () ByteString m ())
resp Response (ConduitM () ByteString m ())
-> (Response (ConduitM () ByteString m ()) -> ResponseHeaders)
-> ResponseHeaders
forall a b. a -> (a -> b) -> b
& Response (ConduitM () ByteString m ()) -> ResponseHeaders
forall body. Response body -> ResponseHeaders
H.responseHeaders
            metadata :: Maybe SpacesMetadata
metadata = case WithMetadata
withMD of
                WithMetadata
NoMetadata   -> Maybe SpacesMetadata
forall a. Maybe a
Nothing
                WithMetadata
KeepMetadata -> SpacesMetadata -> Maybe SpacesMetadata
forall a. a -> Maybe a
Just (SpacesMetadata -> Maybe SpacesMetadata)
-> SpacesMetadata -> Maybe SpacesMetadata
forall a b. (a -> b) -> a -> b
$ Status -> RawResponse m -> SpacesMetadata
forall (m :: * -> *). Status -> RawResponse m -> SpacesMetadata
getResponseMetadata Status
status RawResponse m
raw
            raw :: RawResponse m
raw      = RawResponse :: forall (m :: * -> *). ResponseHeaders -> BodyBS m -> RawResponse m
RawResponse { ResponseHeaders
ConduitM () ByteString m ()
$sel:body:RawResponse :: ConduitM () ByteString m ()
$sel:headers:RawResponse :: ResponseHeaders
headers :: ResponseHeaders
body :: ConduitM () ByteString m ()
.. }

        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Status
status Status -> (Status -> Int) -> Int
forall a b. a -> (a -> b) -> b
& Status -> Int
H.statusCode) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
300)
            (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ (RawResponse m -> m APIException)
-> RawResponse m -> m (Maybe APIException)
forall (m :: * -> *) a b.
MonadCatch m =>
(a -> m b) -> a -> m (Maybe b)
handleMaybe (Status -> RawResponse m -> m APIException
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
Status -> RawResponse m -> m APIException
parseErrorResponse Status
status) RawResponse m
raw m (Maybe APIException) -> (Maybe APIException -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just APIException
apiErr -> APIException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM APIException
apiErr
                Maybe APIException
Nothing     -> ClientException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ClientException -> m ())
-> (ByteString -> ClientException) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> ByteString -> ClientException
HTTPStatus Status
status
                    (ByteString -> m ()) -> m ByteString -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConduitT () Void m ByteString -> m ByteString
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitM () ByteString m ()
body ConduitM () ByteString m ()
-> ConduitM ByteString Void m ByteString
-> ConduitT () Void m ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString Void m ByteString
forall (m :: * -> *) o.
Monad m =>
ConduitT ByteString o m ByteString
sinkLbs)

        ConsumedResponse a
result <- RawResponse m -> m (ConsumedResponse a)
forall (m :: * -> *) a.
Action m a =>
RawResponse m -> m (ConsumedResponse a)
consumeResponse @_ @a RawResponse m
raw
        SpacesResponse a -> m (SpacesResponse a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpacesResponse :: forall a.
ConsumedResponse a -> Maybe SpacesMetadata -> SpacesResponse a
SpacesResponse { Maybe SpacesMetadata
ConsumedResponse a
$sel:metadata:SpacesResponse :: Maybe SpacesMetadata
$sel:result:SpacesResponse :: ConsumedResponse a
result :: ConsumedResponse a
metadata :: Maybe SpacesMetadata
.. }

parseErrorResponse
    :: (MonadThrow m, MonadIO m) => Status -> RawResponse m -> m APIException
parseErrorResponse :: Status -> RawResponse m -> m APIException
parseErrorResponse Status
status RawResponse m
raw = do
    Cursor
cursor <- RawResponse m -> m Cursor
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
RawResponse m -> m Cursor
xmlDocCursor RawResponse m
raw
    Text
code <- ClientException -> [Text] -> m Text
forall e (f :: * -> *) a.
(Exception e, MonadThrow f) =>
e -> [a] -> f a
X.force (Text -> ClientException
xmlElemError Text
"Code")
        ([Text] -> m Text) -> [Text] -> m Text
forall a b. (a -> b) -> a -> b
$ Cursor
cursor Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Axis
X.laxElement Text
"Code" Axis -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
X.content
    Text
requestID <- ClientException -> [Text] -> m Text
forall e (f :: * -> *) a.
(Exception e, MonadThrow f) =>
e -> [a] -> f a
X.force (Text -> ClientException
xmlElemError Text
"RequestId")
        ([Text] -> m Text) -> [Text] -> m Text
forall a b. (a -> b) -> a -> b
$ Cursor
cursor Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Axis
X.laxElement Text
"RequestId" Axis -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
X.content
    Text
hostID <- ClientException -> [Text] -> m Text
forall e (f :: * -> *) a.
(Exception e, MonadThrow f) =>
e -> [a] -> f a
X.force (Text -> ClientException
xmlElemError Text
"HostId")
        ([Text] -> m Text) -> [Text] -> m Text
forall a b. (a -> b) -> a -> b
$ Cursor
cursor Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Axis
X.laxElement Text
"HostId" Axis -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
X.content
    APIException -> m APIException
forall (f :: * -> *) a. Applicative f => a -> f a
pure APIException :: Status -> Text -> Text -> Text -> APIException
APIException { Text
Status
$sel:hostID:APIException :: Text
$sel:requestID:APIException :: Text
$sel:code:APIException :: Text
$sel:status:APIException :: Status
hostID :: Text
requestID :: Text
code :: Text
status :: Status
.. }