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

-- |
-- 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.SetBucketLifecycle
    ( SetBucketLifecycle(..)
    , SetBucketLifecycleResponse
    ) where

import           Control.Monad.Reader        ( MonadReader(ask) )

import           Data.ByteString             ( ByteString )
import           Data.Coerce                 ( coerce )
import qualified Data.Text                   as T
import           Data.Time.Format.ISO8601    ( iso8601Show )

import           GHC.Generics                ( Generic )

import           Network.DO.Spaces.Types
import           Network.DO.Spaces.Utils
import           Network.HTTP.Client.Conduit ( RequestBody(RequestBodyLBS) )
import qualified Network.HTTP.Types          as H

import qualified Text.XML                    as X

-- | Configure the 'LifecycleRule's for a 'Bucket'
data SetBucketLifecycle =
    SetBucketLifecycle { SetBucketLifecycle -> Bucket
bucket :: Bucket, SetBucketLifecycle -> [LifecycleRule]
rules :: [LifecycleRule] }
    deriving stock ( Int -> SetBucketLifecycle -> ShowS
[SetBucketLifecycle] -> ShowS
SetBucketLifecycle -> String
(Int -> SetBucketLifecycle -> ShowS)
-> (SetBucketLifecycle -> String)
-> ([SetBucketLifecycle] -> ShowS)
-> Show SetBucketLifecycle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SetBucketLifecycle] -> ShowS
$cshowList :: [SetBucketLifecycle] -> ShowS
show :: SetBucketLifecycle -> String
$cshow :: SetBucketLifecycle -> String
showsPrec :: Int -> SetBucketLifecycle -> ShowS
$cshowsPrec :: Int -> SetBucketLifecycle -> ShowS
Show, SetBucketLifecycle -> SetBucketLifecycle -> Bool
(SetBucketLifecycle -> SetBucketLifecycle -> Bool)
-> (SetBucketLifecycle -> SetBucketLifecycle -> Bool)
-> Eq SetBucketLifecycle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SetBucketLifecycle -> SetBucketLifecycle -> Bool
$c/= :: SetBucketLifecycle -> SetBucketLifecycle -> Bool
== :: SetBucketLifecycle -> SetBucketLifecycle -> Bool
$c== :: SetBucketLifecycle -> SetBucketLifecycle -> Bool
Eq, (forall x. SetBucketLifecycle -> Rep SetBucketLifecycle x)
-> (forall x. Rep SetBucketLifecycle x -> SetBucketLifecycle)
-> Generic SetBucketLifecycle
forall x. Rep SetBucketLifecycle x -> SetBucketLifecycle
forall x. SetBucketLifecycle -> Rep SetBucketLifecycle x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SetBucketLifecycle x -> SetBucketLifecycle
$cfrom :: forall x. SetBucketLifecycle -> Rep SetBucketLifecycle x
Generic )

type SetBucketLifecycleResponse = ()

instance MonadSpaces m => Action m SetBucketLifecycle where
    type ConsumedResponse SetBucketLifecycle = SetBucketLifecycleResponse

    buildRequest :: SetBucketLifecycle -> m SpacesRequestBuilder
buildRequest SetBucketLifecycle { [LifecycleRule]
Bucket
rules :: [LifecycleRule]
bucket :: Bucket
$sel:rules:SetBucketLifecycle :: SetBucketLifecycle -> [LifecycleRule]
$sel:bucket:SetBucketLifecycle :: SetBucketLifecycle -> 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         = Method -> Maybe Method
forall a. a -> Maybe a
Just Method
PUT
             , $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
                                 )
                               ]
             , Maybe RequestBody
Spaces
$sel:body:SpacesRequestBuilder :: Maybe RequestBody
$sel:spaces:SpacesRequestBuilder :: Spaces
body :: Maybe RequestBody
spaces :: Spaces
..
             }
      where
        body :: Maybe RequestBody
body = RequestBody -> Maybe RequestBody
forall a. a -> Maybe a
Just (RequestBody -> Maybe RequestBody)
-> (Document -> RequestBody) -> Document -> Maybe RequestBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody)
-> (Document -> ByteString) -> Document -> RequestBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderSettings -> Document -> ByteString
X.renderLBS RenderSettings
forall a. Default a => a
X.def
            (Document -> Maybe RequestBody) -> Document -> Maybe RequestBody
forall a b. (a -> b) -> a -> b
$ Prologue -> Element -> [Miscellaneous] -> Document
X.Document Prologue
prologue Element
root [Miscellaneous]
forall a. Monoid a => a
mempty

        prologue :: Prologue
prologue = [Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
X.Prologue [Miscellaneous]
forall a. Monoid a => a
mempty Maybe Doctype
forall a. Maybe a
Nothing [Miscellaneous]
forall a. Monoid a => a
mempty

        root :: Element
root = Name -> Map Name Text -> [Node] -> Element
X.Element Name
name Map Name Text
forall a. Monoid a => a
mempty (LifecycleRule -> Node
rulesNode (LifecycleRule -> Node) -> [LifecycleRule] -> [Node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LifecycleRule]
rules)
          where
            name :: Name
name = Text -> Maybe Text -> Maybe Text -> Name
X.Name Text
"LifecycleConfiguration"
                          (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"http://s3.amazonaws.com/doc/2006-03-01/")
                          Maybe Text
forall a. Maybe a
Nothing

        rulesNode :: LifecycleRule -> Node
rulesNode LifecycleRule { Bool
Maybe Days
Maybe Text
Maybe LifecycleExpiration
LifecycleID
$sel:abortIncomplete:LifecycleRule :: LifecycleRule -> Maybe Days
$sel:expiration:LifecycleRule :: LifecycleRule -> Maybe LifecycleExpiration
$sel:prefix:LifecycleRule :: LifecycleRule -> Maybe Text
$sel:enabled:LifecycleRule :: LifecycleRule -> Bool
$sel:lifecycleID:LifecycleRule :: LifecycleRule -> LifecycleID
abortIncomplete :: Maybe Days
expiration :: Maybe LifecycleExpiration
prefix :: Maybe Text
enabled :: Bool
lifecycleID :: LifecycleID
.. } =
            Element -> Node
X.NodeElement (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> [Node] -> Element
X.Element Name
"Rule" Map Name Text
forall a. Monoid a => a
mempty [Node]
nodes
          where
            nodes :: [Node]
nodes = [ Name -> Text -> Node
mkNode Name
"ID" (LifecycleID -> Text
coerce LifecycleID
lifecycleID)
                    , Name -> Text -> Node
mkNode Name
"Status" (Bool -> Text
showEnabled Bool
enabled)
                    ]
                [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> (Text -> [Node]) -> Maybe Text -> [Node]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Node -> [Node]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node -> [Node]) -> (Text -> Node) -> Text -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text -> Node
mkNode Name
"Prefix") Maybe Text
prefix
                [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> (LifecycleExpiration -> [Node])
-> Maybe LifecycleExpiration -> [Node]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Node -> [Node]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node -> [Node])
-> (LifecycleExpiration -> Node) -> LifecycleExpiration -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LifecycleExpiration -> Node
mkExpireNode) Maybe LifecycleExpiration
expiration
                [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> (Days -> [Node]) -> Maybe Days -> [Node]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Node -> [Node]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node -> [Node]) -> (Days -> Node) -> Days -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Days -> Node
forall a. Show a => a -> Node
mkAbortNode) Maybe Days
abortIncomplete

            showEnabled :: Bool -> Text
showEnabled = \case
                Bool
True  -> Text
"Enabled"
                Bool
False -> Text
"Disabled"

            mkExpireNode :: LifecycleExpiration -> Node
mkExpireNode LifecycleExpiration
conf = Element -> Node
X.NodeElement
                (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> [Node] -> Element
X.Element Name
"Expiration" Map Name Text
forall a. Monoid a => a
mempty (Node -> [Node]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node -> [Node]) -> Node -> [Node]
forall a b. (a -> b) -> a -> b
$ LifecycleExpiration -> Node
mkExNodes LifecycleExpiration
conf)
              where
                mkExNodes :: LifecycleExpiration -> Node
mkExNodes (AfterDays Days
days) = Name -> Text -> Node
mkNode Name
"Days" (Days -> Text
forall a. Show a => a -> Text
tshow Days
days)
                mkExNodes (OnDate UTCTime
date)    =
                    Name -> Text -> Node
mkNode Name
"Date" (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
forall t. ISO8601 t => t -> String
iso8601Show UTCTime
date)

            mkAbortNode :: a -> Node
mkAbortNode a
days = Element -> Node
X.NodeElement
                (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> [Node] -> Element
X.Element Name
"AbortIncompleteMultipartUpload"
                            Map Name Text
forall a. Monoid a => a
mempty
                            [ Name -> Text -> Node
mkNode Name
"DaysAfterInitiation" (a -> Text
forall a. Show a => a -> Text
tshow a
days) ]

    consumeResponse :: RawResponse m -> m (ConsumedResponse SetBucketLifecycle)
consumeResponse RawResponse m
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()