GetBucketLifecycle.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# 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
                 ( Action(..)
                 , Bucket
                 , ClientException(InvalidXML)
                 , LifecycleExpiration(AfterDays, OnDate)
                 , LifecycleID(LifecycleID)
                 , LifecycleRule(..)
                 , MonadSpaces
                 , SpacesRequestBuilder(..)
                 )
import           Network.DO.Spaces.Utils
                 ( xmlDocCursor
                 , xmlElemError
                 , xmlMaybeElem
                 , xmlUTCTime
                 )
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@
data GetBucketLifecycle = GetBucketLifecycle { bucket :: Bucket }
    deriving ( Show, Eq, Generic )

data GetBucketLifecycleResponse =
    GetBucketLifecycleResponse { rules :: [LifecycleRule] }
    deriving ( Show, Eq, Generic )

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

    buildRequest GetBucketLifecycle { .. } = do
        spaces <- ask
        return SpacesRequestBuilder
               { bucket         = Just bucket
               , method         = Nothing
               , body           = Nothing
               , object         = Nothing
               , overrideRegion = Nothing
               , queryString    = Nothing
               , headers        = mempty
               , subresources   = Just
                     $ H.toQuery [ ( "lifecycle" :: ByteString
                                   , Nothing :: Maybe ByteString
                                   )
                                 ]
               , ..
               }

    consumeResponse raw = do
        cursor <- xmlDocCursor raw
        GetBucketLifecycleResponse
            <$> sequence (cursor $/ X.laxElement "Rule" &| ruleP)

ruleP :: MonadThrow m => Cursor X.Node -> m LifecycleRule
ruleP c = do
    id' <- X.force (xmlElemError "ID")
        $ c $/ X.laxElement "ID" &/ X.content &| coerce
    enabled <- X.forceM (xmlElemError "Status")
        $ c $/ X.laxElement "Status" &/ X.content &| readStatus
    return LifecycleRule { .. }
  where
    prefix = xmlMaybeElem c "Prefix"

    abortIncomplete = join . listToMaybe
        $ c $/ X.laxElement "AbortIncompleteMultipartUpload" &| abortP

    expiration = join . sequence . listToMaybe
        $ c $/ X.laxElement "Expiration" &| expiresP

    abortP c' = X.forceM (xmlElemError "DaysAfterInitiation")
        $ c' $/ X.laxElement "DaysAfterInitiation" &/ X.content
        &| (readMaybe . T.unpack)

    readStatus = \case
        "Enabled"  -> return True
        "Disabled" -> return False
        _          -> throwM $ InvalidXML "GetBucketLifecycle: invalid Status"

    -- TODO find a less hideous way of doing this
    expiresP (X.node -> X.NodeElement (X.Element _ _ elems)) = case elems of
        (_ : el : _) -> case el of
            X.NodeElement (X.Element (X.nameLocalName -> name) _ _)
                | name == "Days" -> AfterDays
                    <$> (readMaybe . T.unpack . mconcat
                         $ (X.fromNode el $/ X.content))
                | name == "Date" -> OnDate
                    <$> (xmlUTCTime @Maybe . mconcat
                         $ (X.fromNode el $/ X.content))
            _ -> throwInvalidExpires
        _            -> throwInvalidExpires

    expiresP _ = throwInvalidExpires

    throwInvalidExpires =
        throwM $ InvalidXML "GetBucketLifecycle: invalid Expiration"