{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

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

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

import           Data.ByteString         ( ByteString )
import           Data.Coerce             ( coerce )
import           Data.Maybe              ( listToMaybe )
import qualified Data.Text               as T

import           GHC.Generics            ( Generic )

import           Network.DO.Spaces.Types
import           Network.DO.Spaces.Utils
import qualified Network.HTTP.Types      as H

import           Text.Read               ( readMaybe )
import qualified Text.XML                as X
import qualified Text.XML.Cursor         as X
import           Text.XML.Cursor         ( ($/), (&/), (&|) )
import           Text.XML.Cursor.Generic ( Cursor )

-- | Get the 'LifecycleRule' configuration for a 'Bucket'. Note that unless
-- you have explicitly configured lifecycle rules, this will fail with a 404
-- status and an error code of @NoSuchLifecycleConfiguration@
newtype GetBucketLifecycle = GetBucketLifecycle { GetBucketLifecycle -> Bucket
bucket :: Bucket }
    deriving stock ( Int -> GetBucketLifecycle -> ShowS
[GetBucketLifecycle] -> ShowS
GetBucketLifecycle -> String
(Int -> GetBucketLifecycle -> ShowS)
-> (GetBucketLifecycle -> String)
-> ([GetBucketLifecycle] -> ShowS)
-> Show GetBucketLifecycle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetBucketLifecycle] -> ShowS
$cshowList :: [GetBucketLifecycle] -> ShowS
show :: GetBucketLifecycle -> String
$cshow :: GetBucketLifecycle -> String
showsPrec :: Int -> GetBucketLifecycle -> ShowS
$cshowsPrec :: Int -> GetBucketLifecycle -> ShowS
Show, (forall x. GetBucketLifecycle -> Rep GetBucketLifecycle x)
-> (forall x. Rep GetBucketLifecycle x -> GetBucketLifecycle)
-> Generic GetBucketLifecycle
forall x. Rep GetBucketLifecycle x -> GetBucketLifecycle
forall x. GetBucketLifecycle -> Rep GetBucketLifecycle x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GetBucketLifecycle x -> GetBucketLifecycle
$cfrom :: forall x. GetBucketLifecycle -> Rep GetBucketLifecycle x
Generic )
    deriving newtype ( GetBucketLifecycle -> GetBucketLifecycle -> Bool
(GetBucketLifecycle -> GetBucketLifecycle -> Bool)
-> (GetBucketLifecycle -> GetBucketLifecycle -> Bool)
-> Eq GetBucketLifecycle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetBucketLifecycle -> GetBucketLifecycle -> Bool
$c/= :: GetBucketLifecycle -> GetBucketLifecycle -> Bool
== :: GetBucketLifecycle -> GetBucketLifecycle -> Bool
$c== :: GetBucketLifecycle -> GetBucketLifecycle -> Bool
Eq )

newtype GetBucketLifecycleResponse =
    GetBucketLifecycleResponse { GetBucketLifecycleResponse -> [LifecycleRule]
rules :: [LifecycleRule] }
    deriving stock ( Int -> GetBucketLifecycleResponse -> ShowS
[GetBucketLifecycleResponse] -> ShowS
GetBucketLifecycleResponse -> String
(Int -> GetBucketLifecycleResponse -> ShowS)
-> (GetBucketLifecycleResponse -> String)
-> ([GetBucketLifecycleResponse] -> ShowS)
-> Show GetBucketLifecycleResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetBucketLifecycleResponse] -> ShowS
$cshowList :: [GetBucketLifecycleResponse] -> ShowS
show :: GetBucketLifecycleResponse -> String
$cshow :: GetBucketLifecycleResponse -> String
showsPrec :: Int -> GetBucketLifecycleResponse -> ShowS
$cshowsPrec :: Int -> GetBucketLifecycleResponse -> ShowS
Show, (forall x.
 GetBucketLifecycleResponse -> Rep GetBucketLifecycleResponse x)
-> (forall x.
    Rep GetBucketLifecycleResponse x -> GetBucketLifecycleResponse)
-> Generic GetBucketLifecycleResponse
forall x.
Rep GetBucketLifecycleResponse x -> GetBucketLifecycleResponse
forall x.
GetBucketLifecycleResponse -> Rep GetBucketLifecycleResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep GetBucketLifecycleResponse x -> GetBucketLifecycleResponse
$cfrom :: forall x.
GetBucketLifecycleResponse -> Rep GetBucketLifecycleResponse x
Generic )
    deriving newtype ( GetBucketLifecycleResponse -> GetBucketLifecycleResponse -> Bool
(GetBucketLifecycleResponse -> GetBucketLifecycleResponse -> Bool)
-> (GetBucketLifecycleResponse
    -> GetBucketLifecycleResponse -> Bool)
-> Eq GetBucketLifecycleResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetBucketLifecycleResponse -> GetBucketLifecycleResponse -> Bool
$c/= :: GetBucketLifecycleResponse -> GetBucketLifecycleResponse -> Bool
== :: GetBucketLifecycleResponse -> GetBucketLifecycleResponse -> Bool
$c== :: GetBucketLifecycleResponse -> GetBucketLifecycleResponse -> Bool
Eq )

instance MonadSpaces m => Action m GetBucketLifecycle where
    type ConsumedResponse GetBucketLifecycle = GetBucketLifecycleResponse

    buildRequest :: GetBucketLifecycle -> m SpacesRequestBuilder
buildRequest GetBucketLifecycle { Bucket
bucket :: Bucket
$sel:bucket:GetBucketLifecycle :: GetBucketLifecycle -> 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:method:SpacesRequestBuilder :: Maybe Method
method         = Maybe Method
forall a. Maybe a
Nothing
             , $sel:body:SpacesRequestBuilder :: Maybe RequestBody
body           = Maybe RequestBody
forall a. Maybe a
Nothing
             , $sel:object:SpacesRequestBuilder :: Maybe Object
object         = Maybe Object
forall a. Maybe a
Nothing
             , $sel:overrideRegion:SpacesRequestBuilder :: Maybe Region
overrideRegion = Maybe Region
forall a. Maybe a
Nothing
             , $sel:queryString:SpacesRequestBuilder :: Maybe Query
queryString    = Maybe Query
forall a. Maybe a
Nothing
             , $sel:headers:SpacesRequestBuilder :: [Header]
headers        = [Header]
forall a. Monoid a => a
mempty
             , $sel:subresources:SpacesRequestBuilder :: Maybe Query
subresources   = Query -> Maybe Query
forall a. a -> Maybe a
Just
                   (Query -> Maybe Query) -> Query -> Maybe Query
forall a b. (a -> b) -> a -> b
$ Query -> Query
forall a. QueryLike a => a -> Query
H.toQuery [ ( ByteString
"lifecycle" :: ByteString
                                 , Maybe ByteString
forall a. Maybe a
Nothing :: Maybe ByteString
                                 )
                               ]
             , Spaces
$sel:spaces:SpacesRequestBuilder :: Spaces
spaces :: Spaces
..
             }

    consumeResponse :: RawResponse m -> m (ConsumedResponse GetBucketLifecycle)
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
        [LifecycleRule] -> GetBucketLifecycleResponse
GetBucketLifecycleResponse
            ([LifecycleRule] -> GetBucketLifecycleResponse)
-> m [LifecycleRule] -> m GetBucketLifecycleResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [m LifecycleRule] -> m [LifecycleRule]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Cursor
cursor Cursor -> (Cursor -> [m LifecycleRule]) -> [m LifecycleRule]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Axis
X.laxElement Text
"Rule" Axis -> (Cursor -> m LifecycleRule) -> Cursor -> [m LifecycleRule]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| Cursor -> m LifecycleRule
forall (m :: * -> *). MonadThrow m => Cursor -> m LifecycleRule
ruleP)

ruleP :: MonadThrow m => Cursor X.Node -> m LifecycleRule
ruleP :: Cursor -> m LifecycleRule
ruleP Cursor
c = do
    LifecycleID
lifecycleID <- ClientException -> [LifecycleID] -> m LifecycleID
forall e (f :: * -> *) a.
(Exception e, MonadThrow f) =>
e -> [a] -> f a
X.force (Text -> ClientException
xmlElemError Text
"ID")
        ([LifecycleID] -> m LifecycleID) -> [LifecycleID] -> m LifecycleID
forall a b. (a -> b) -> a -> b
$ Cursor
c Cursor -> (Cursor -> [LifecycleID]) -> [LifecycleID]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Axis
X.laxElement Text
"ID" Axis -> (Cursor -> [LifecycleID]) -> Cursor -> [LifecycleID]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
X.content (Cursor -> [Text])
-> (Text -> LifecycleID) -> Cursor -> [LifecycleID]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| Text -> LifecycleID
coerce
    Bool
enabled <- ClientException -> [m Bool] -> m Bool
forall e (f :: * -> *) a.
(Exception e, MonadThrow f) =>
e -> [f a] -> f a
X.forceM (Text -> ClientException
xmlElemError Text
"Status")
        ([m Bool] -> m Bool) -> [m Bool] -> m Bool
forall a b. (a -> b) -> a -> b
$ Cursor
c Cursor -> (Cursor -> [m Bool]) -> [m Bool]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Axis
X.laxElement Text
"Status" Axis -> (Cursor -> [m Bool]) -> Cursor -> [m Bool]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
X.content (Cursor -> [Text]) -> (Text -> m Bool) -> Cursor -> [m Bool]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| Text -> m Bool
readStatus
    LifecycleRule -> m LifecycleRule
forall (f :: * -> *) a. Applicative f => a -> f a
pure LifecycleRule :: LifecycleID
-> Bool
-> Maybe Text
-> Maybe LifecycleExpiration
-> Maybe Days
-> LifecycleRule
LifecycleRule { Bool
Maybe Days
Maybe Text
Maybe LifecycleExpiration
LifecycleID
$sel:abortIncomplete:LifecycleRule :: Maybe Days
$sel:expiration:LifecycleRule :: Maybe LifecycleExpiration
$sel:prefix:LifecycleRule :: Maybe Text
$sel:enabled:LifecycleRule :: Bool
$sel:lifecycleID:LifecycleRule :: LifecycleID
expiration :: Maybe LifecycleExpiration
abortIncomplete :: Maybe Days
prefix :: Maybe Text
enabled :: Bool
lifecycleID :: LifecycleID
.. }
  where
    prefix :: Maybe Text
prefix = Cursor -> Text -> Maybe Text
xmlMaybeElem Cursor
c Text
"Prefix"

    abortIncomplete :: Maybe Days
abortIncomplete = Maybe (Maybe Days) -> Maybe Days
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Days) -> Maybe Days)
-> ([Maybe Days] -> Maybe (Maybe Days))
-> [Maybe Days]
-> Maybe Days
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Days] -> Maybe (Maybe Days)
forall a. [a] -> Maybe a
listToMaybe
        ([Maybe Days] -> Maybe Days) -> [Maybe Days] -> Maybe Days
forall a b. (a -> b) -> a -> b
$ Cursor
c Cursor -> (Cursor -> [Maybe Days]) -> [Maybe Days]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Axis
X.laxElement Text
"AbortIncompleteMultipartUpload" Axis -> (Cursor -> Maybe Days) -> Cursor -> [Maybe Days]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| Cursor -> Maybe Days
forall a. Read a => Cursor -> Maybe a
abortP

    expiration :: Maybe LifecycleExpiration
expiration = Maybe (Maybe LifecycleExpiration) -> Maybe LifecycleExpiration
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe LifecycleExpiration) -> Maybe LifecycleExpiration)
-> ([Maybe LifecycleExpiration]
    -> Maybe (Maybe LifecycleExpiration))
-> [Maybe LifecycleExpiration]
-> Maybe LifecycleExpiration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Maybe LifecycleExpiration)
-> Maybe (Maybe LifecycleExpiration)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Maybe (Maybe LifecycleExpiration)
 -> Maybe (Maybe LifecycleExpiration))
-> ([Maybe LifecycleExpiration]
    -> Maybe (Maybe LifecycleExpiration))
-> [Maybe LifecycleExpiration]
-> Maybe (Maybe LifecycleExpiration)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe LifecycleExpiration] -> Maybe (Maybe LifecycleExpiration)
forall a. [a] -> Maybe a
listToMaybe
        ([Maybe LifecycleExpiration] -> Maybe LifecycleExpiration)
-> [Maybe LifecycleExpiration] -> Maybe LifecycleExpiration
forall a b. (a -> b) -> a -> b
$ Cursor
c Cursor
-> (Cursor -> [Maybe LifecycleExpiration])
-> [Maybe LifecycleExpiration]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Axis
X.laxElement Text
"Expiration" Axis
-> (Cursor -> Maybe LifecycleExpiration)
-> Cursor
-> [Maybe LifecycleExpiration]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| Cursor -> Maybe LifecycleExpiration
expiresP

    abortP :: Cursor -> Maybe a
abortP Cursor
c' = ClientException -> [Maybe a] -> Maybe a
forall e (f :: * -> *) a.
(Exception e, MonadThrow f) =>
e -> [f a] -> f a
X.forceM (Text -> ClientException
xmlElemError Text
"DaysAfterInitiation")
        ([Maybe a] -> Maybe a) -> [Maybe a] -> Maybe a
forall a b. (a -> b) -> a -> b
$ Cursor
c' Cursor -> (Cursor -> [Maybe a]) -> [Maybe a]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Axis
X.laxElement Text
"DaysAfterInitiation" Axis -> (Cursor -> [Maybe a]) -> Cursor -> [Maybe a]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
X.content
        (Cursor -> [Text]) -> (Text -> Maybe a) -> Cursor -> [Maybe a]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| (String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe a) -> (Text -> String) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)

    readStatus :: Text -> m Bool
readStatus = \case
        Text
"Enabled"  -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        Text
"Disabled" -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        Text
_          -> ClientException -> m Bool
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ClientException -> m Bool) -> ClientException -> m Bool
forall a b. (a -> b) -> a -> b
$ Text -> ClientException
InvalidXML Text
"GetBucketLifecycle: invalid Status"

    -- TODO find a less hideous way of doing this
    expiresP :: Cursor -> Maybe LifecycleExpiration
expiresP (Cursor -> Node
forall node. Cursor node -> node
X.node -> X.NodeElement (X.Element Name
_ Map Name Text
_ [Node]
elems)) = case [Node]
elems of
        (Node
_ : Node
el : [Node]
_) -> case Node
el of
            X.NodeElement (X.Element (Name -> Text
X.nameLocalName -> Text
name) Map Name Text
_ [Node]
_)
                | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Days" -> Days -> LifecycleExpiration
AfterDays
                    (Days -> LifecycleExpiration)
-> Maybe Days -> Maybe LifecycleExpiration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Maybe Days
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Days)
-> ([Text] -> String) -> [Text] -> Maybe Days
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> ([Text] -> Text) -> [Text] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                         ([Text] -> Maybe Days) -> [Text] -> Maybe Days
forall a b. (a -> b) -> a -> b
$ (Node -> Cursor
X.fromNode Node
el Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Cursor -> [Text]
X.content))
                | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Date" -> UTCTime -> LifecycleExpiration
OnDate
                    (UTCTime -> LifecycleExpiration)
-> Maybe UTCTime -> Maybe LifecycleExpiration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MonadThrow Maybe => Text -> Maybe UTCTime
forall (m :: * -> *). MonadThrow m => Text -> m UTCTime
xmlUTCTime @Maybe (Text -> Maybe UTCTime)
-> ([Text] -> Text) -> [Text] -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                         ([Text] -> Maybe UTCTime) -> [Text] -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ (Node -> Cursor
X.fromNode Node
el Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Cursor -> [Text]
X.content))
            Node
_ -> Maybe LifecycleExpiration
forall a. Maybe a
throwInvalidExpires
        [Node]
_            -> Maybe LifecycleExpiration
forall a. Maybe a
throwInvalidExpires

    expiresP Cursor
_ = Maybe LifecycleExpiration
forall a. Maybe a
throwInvalidExpires

    throwInvalidExpires :: Maybe a
throwInvalidExpires =
        ClientException -> Maybe a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ClientException -> Maybe a) -> ClientException -> Maybe a
forall a b. (a -> b) -> a -> b
$ Text -> ClientException
InvalidXML Text
"GetBucketLifecycle: invalid Expiration"