{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

module HaskellWorks.CabalCache.AWS.S3
  ( uriToS3Uri,
    headS3Uri,
    getS3Uri,
    copyS3Uri,
    putObject,

  ) where

import Amazonka                           (ResponseBody)
import Amazonka.Data                      (ToText(..), fromText)
import Control.Monad.Catch                (MonadCatch(..))
import Control.Monad.Except               (MonadError)
import Control.Monad.Trans.Resource       (MonadResource, MonadUnliftIO, liftResourceT, runResourceT)
import Data.Conduit.Lazy                  (lazyConsume)
import Data.Generics.Product.Any          (the)
import HaskellWorks.CabalCache.AppError   (AwsError(..))
import HaskellWorks.CabalCache.Error      (CopyFailed(..), UnsupportedUri(..))
import HaskellWorks.Prelude
import Lens.Micro
import Network.URI                        (URI)

import qualified Amazonka                             as AWS
-- import qualified Amazonka.Data.Body                   as AWS
import qualified Amazonka.S3                          as AWS
import qualified Control.Monad.Oops                   as OO
import qualified Data.ByteString.Lazy                 as LBS
import qualified HaskellWorks.CabalCache.AWS.Error    as AWS
import qualified HaskellWorks.CabalCache.AWS.S3.URI   as AWS
import qualified HaskellWorks.CabalCache.IO.Console   as CIO
import qualified HaskellWorks.CabalCache.URI          as URI
import qualified System.IO                            as IO

--- | Access the response body as a lazy bytestring
lazyByteString :: MonadResource m => ResponseBody -> m LBS.ByteString
lazyByteString :: forall (m :: * -> *).
MonadResource m =>
ResponseBody -> m ByteString
lazyByteString ResponseBody
rsBody = ResourceT IO ByteString -> m ByteString
forall a. ResourceT IO a -> m a
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT (ResourceT IO ByteString -> m ByteString)
-> ResourceT IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
LBS.fromChunks ([ByteString] -> ByteString)
-> ResourceT IO [ByteString] -> ResourceT IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Source (ResourceT IO) ByteString -> ResourceT IO [ByteString]
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadActive m) =>
Source m a -> m [a]
lazyConsume (ResponseBody
rsBody ResponseBody
-> Getting
     (Source (ResourceT IO) ByteString)
     ResponseBody
     (Source (ResourceT IO) ByteString)
-> Source (ResourceT IO) ByteString
forall s a. s -> Getting a s a -> a
^. forall {k} (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall (sel :: Symbol) s t a b. HasAny sel s t a b => Lens s t a b
the @"body")

unsafeDownloadRequest :: ()
  => Monad m
  => MonadResource m
  => AWS.Env
  -> AWS.GetObject
  -> m LBS.ByteString
unsafeDownloadRequest :: forall (m :: * -> *).
(Monad m, MonadResource m) =>
Env -> GetObject -> m ByteString
unsafeDownloadRequest Env
awsEnv GetObject
req = do
  GetObjectResponse
resp <- Env -> GetObject -> m (AWSResponse GetObject)
forall (m :: * -> *) a.
(MonadResource m, AWSRequest a, Typeable a,
 Typeable (AWSResponse a)) =>
Env -> a -> m (AWSResponse a)
AWS.send Env
awsEnv GetObject
req
  ResponseBody -> m ByteString
forall (m :: * -> *).
MonadResource m =>
ResponseBody -> m ByteString
lazyByteString (GetObjectResponse
resp GetObjectResponse
-> Getting ResponseBody GetObjectResponse ResponseBody
-> ResponseBody
forall s a. s -> Getting a s a -> a
^. forall {k} (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall (sel :: Symbol) s t a b. HasAny sel s t a b => Lens s t a b
the @"body")

unsafeDownload :: ()
  => Monad m
  => MonadResource m
  => AWS.Env
  -> AWS.BucketName
  -> AWS.ObjectKey
  -> m LBS.ByteString
unsafeDownload :: forall (m :: * -> *).
(Monad m, MonadResource m) =>
Env -> BucketName -> ObjectKey -> m ByteString
unsafeDownload Env
env BucketName
bucketName ObjectKey
objectKey = Env -> GetObject -> m ByteString
forall (m :: * -> *).
(Monad m, MonadResource m) =>
Env -> GetObject -> m ByteString
unsafeDownloadRequest Env
env (BucketName -> ObjectKey -> GetObject
AWS.newGetObject BucketName
bucketName ObjectKey
objectKey)

uriToS3Uri :: URI -> Either UnsupportedUri AWS.S3Uri
uriToS3Uri :: URI -> Either UnsupportedUri S3Uri
uriToS3Uri URI
uri = case forall a. FromText a => Text -> Either String a
fromText @AWS.S3Uri (URI -> Text
forall a. Show a => a -> Text
tshow URI
uri) of
  Right S3Uri
s3Uri -> S3Uri -> Either UnsupportedUri S3Uri
forall a b. b -> Either a b
Right S3Uri
s3Uri
  Left String
msg    -> UnsupportedUri -> Either UnsupportedUri S3Uri
forall a b. a -> Either a b
Left (UnsupportedUri -> Either UnsupportedUri S3Uri)
-> UnsupportedUri -> Either UnsupportedUri S3Uri
forall a b. (a -> b) -> a -> b
$ URI -> Text -> UnsupportedUri
UnsupportedUri URI
uri (Text -> UnsupportedUri) -> Text -> UnsupportedUri
forall a b. (a -> b) -> a -> b
$ Text
"Unable to parse URI" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
tshow String
msg

headS3Uri :: ()
  => MonadError (OO.Variant e) m
  => e `OO.CouldBe` AwsError
  => e `OO.CouldBe` UnsupportedUri
  => MonadCatch m
  => MonadResource m
  => AWS.Env
  -> URI
  -> m AWS.HeadObjectResponse
headS3Uri :: forall (e :: [*]) (m :: * -> *).
(MonadError (Variant e) m, CouldBe e AwsError,
 CouldBe e UnsupportedUri, MonadCatch m, MonadResource m) =>
Env -> URI -> m HeadObjectResponse
headS3Uri Env
envAws URI
uri = do
  AWS.S3Uri BucketName
b ObjectKey
k <- Either UnsupportedUri S3Uri -> m S3Uri
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x, Monad m) =>
Either x a -> m a
OO.hoistEither (Either UnsupportedUri S3Uri -> m S3Uri)
-> Either UnsupportedUri S3Uri -> m S3Uri
forall a b. (a -> b) -> a -> b
$ URI -> Either UnsupportedUri S3Uri
uriToS3Uri (URI -> URI
URI.reslashUri URI
uri)
  m HeadObjectResponse -> m HeadObjectResponse
forall (m :: * -> *) (e :: [*]) a.
(MonadCatch m, MonadError (Variant e) m, CouldBeF e AwsError) =>
m a -> m a
AWS.handleAwsError (m HeadObjectResponse -> m HeadObjectResponse)
-> m HeadObjectResponse -> m HeadObjectResponse
forall a b. (a -> b) -> a -> b
$ Env -> HeadObject -> m (AWSResponse HeadObject)
forall (m :: * -> *) a.
(MonadResource m, AWSRequest a, Typeable a,
 Typeable (AWSResponse a)) =>
Env -> a -> m (AWSResponse a)
AWS.send Env
envAws (HeadObject -> m (AWSResponse HeadObject))
-> HeadObject -> m (AWSResponse HeadObject)
forall a b. (a -> b) -> a -> b
$ BucketName -> ObjectKey -> HeadObject
AWS.newHeadObject BucketName
b ObjectKey
k

putObject :: ()
  => e `OO.CouldBe` AwsError
  => e `OO.CouldBe` UnsupportedUri
  => MonadCatch m
  => MonadUnliftIO m
  => AWS.ToBody a
  => AWS.Env
  -> URI
  -> a
  -> ExceptT (OO.Variant e) m ()
putObject :: forall (e :: [*]) (m :: * -> *) a.
(CouldBe e AwsError, CouldBe e UnsupportedUri, MonadCatch m,
 MonadUnliftIO m, ToBody a) =>
Env -> URI -> a -> ExceptT (Variant e) m ()
putObject Env
envAws URI
uri a
lbs = do
  AWS.S3Uri BucketName
b ObjectKey
k <- Either UnsupportedUri S3Uri -> ExceptT (Variant e) m S3Uri
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x, Monad m) =>
Either x a -> m a
OO.hoistEither (Either UnsupportedUri S3Uri -> ExceptT (Variant e) m S3Uri)
-> Either UnsupportedUri S3Uri -> ExceptT (Variant e) m S3Uri
forall a b. (a -> b) -> a -> b
$ URI -> Either UnsupportedUri S3Uri
uriToS3Uri (URI -> URI
URI.reslashUri URI
uri)
  let req :: RequestBody
req = a -> RequestBody
forall a. ToBody a => a -> RequestBody
AWS.toBody a
lbs
  let po :: PutObject
po  = BucketName -> ObjectKey -> RequestBody -> PutObject
AWS.newPutObject BucketName
b ObjectKey
k RequestBody
req
  ExceptT (Variant e) m () -> ExceptT (Variant e) m ()
forall (m :: * -> *) (e :: [*]) a.
(MonadCatch m, MonadError (Variant e) m, CouldBeF e AwsError) =>
m a -> m a
AWS.handleAwsError (ExceptT (Variant e) m () -> ExceptT (Variant e) m ())
-> ExceptT (Variant e) m () -> ExceptT (Variant e) m ()
forall a b. (a -> b) -> a -> b
$ ExceptT (Variant e) m PutObjectResponse -> ExceptT (Variant e) m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT (Variant e) m PutObjectResponse
 -> ExceptT (Variant e) m ())
-> ExceptT (Variant e) m PutObjectResponse
-> ExceptT (Variant e) m ()
forall a b. (a -> b) -> a -> b
$ (ResourceT m (Either (Variant e) PutObjectResponse)
 -> m (Either (Variant e) PutObjectResponse))
-> ExceptT (Variant e) (ResourceT m) PutObjectResponse
-> ExceptT (Variant e) m PutObjectResponse
forall x (m :: * -> *) a (n :: * -> *) b.
(m (Either x a) -> n (Either x b))
-> ExceptT x m a -> ExceptT x n b
OO.suspend ResourceT m (Either (Variant e) PutObjectResponse)
-> m (Either (Variant e) PutObjectResponse)
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ExceptT (Variant e) (ResourceT m) PutObjectResponse
 -> ExceptT (Variant e) m PutObjectResponse)
-> ExceptT (Variant e) (ResourceT m) PutObjectResponse
-> ExceptT (Variant e) m PutObjectResponse
forall a b. (a -> b) -> a -> b
$ Env
-> PutObject
-> ExceptT (Variant e) (ResourceT m) (AWSResponse PutObject)
forall (m :: * -> *) a.
(MonadResource m, AWSRequest a, Typeable a,
 Typeable (AWSResponse a)) =>
Env -> a -> m (AWSResponse a)
AWS.send Env
envAws PutObject
po

getS3Uri :: ()
  => MonadError (OO.Variant e) m
  => e `OO.CouldBe` AwsError
  => e `OO.CouldBe` UnsupportedUri
  => MonadCatch m
  => MonadResource m
  => AWS.Env
  -> URI
  -> m LBS.ByteString
getS3Uri :: forall (e :: [*]) (m :: * -> *).
(MonadError (Variant e) m, CouldBe e AwsError,
 CouldBe e UnsupportedUri, MonadCatch m, MonadResource m) =>
Env -> URI -> m ByteString
getS3Uri Env
envAws URI
uri = do
  AWS.S3Uri BucketName
b ObjectKey
k <- Either UnsupportedUri S3Uri -> m S3Uri
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x, Monad m) =>
Either x a -> m a
OO.hoistEither (Either UnsupportedUri S3Uri -> m S3Uri)
-> Either UnsupportedUri S3Uri -> m S3Uri
forall a b. (a -> b) -> a -> b
$ URI -> Either UnsupportedUri S3Uri
uriToS3Uri (URI -> URI
URI.reslashUri URI
uri)
  m ByteString -> m ByteString
forall (m :: * -> *) (e :: [*]) a.
(MonadCatch m, MonadError (Variant e) m, CouldBeF e AwsError) =>
m a -> m a
AWS.handleAwsError (m ByteString -> m ByteString) -> m ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Env -> BucketName -> ObjectKey -> m ByteString
forall (m :: * -> *).
(Monad m, MonadResource m) =>
Env -> BucketName -> ObjectKey -> m ByteString
unsafeDownload Env
envAws BucketName
b ObjectKey
k

copyS3Uri :: ()
  => MonadUnliftIO m
  => e `OO.CouldBe` AwsError
  => e `OO.CouldBe` CopyFailed
  => e `OO.CouldBe` UnsupportedUri
  => AWS.Env
  -> URI
  -> URI
  -> ExceptT (OO.Variant e) m ()
copyS3Uri :: forall (m :: * -> *) (e :: [*]).
(MonadUnliftIO m, CouldBe e AwsError, CouldBe e CopyFailed,
 CouldBe e UnsupportedUri) =>
Env -> URI -> URI -> ExceptT (Variant e) m ()
copyS3Uri Env
envAws URI
source URI
target = do
  AWS.S3Uri BucketName
sourceBucket ObjectKey
sourceObjectKey <- Either UnsupportedUri S3Uri -> ExceptT (Variant e) m S3Uri
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x, Monad m) =>
Either x a -> m a
OO.hoistEither (Either UnsupportedUri S3Uri -> ExceptT (Variant e) m S3Uri)
-> Either UnsupportedUri S3Uri -> ExceptT (Variant e) m S3Uri
forall a b. (a -> b) -> a -> b
$ URI -> Either UnsupportedUri S3Uri
uriToS3Uri (URI -> URI
URI.reslashUri URI
source)
  AWS.S3Uri BucketName
targetBucket ObjectKey
targetObjectKey <- Either UnsupportedUri S3Uri -> ExceptT (Variant e) m S3Uri
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x, Monad m) =>
Either x a -> m a
OO.hoistEither (Either UnsupportedUri S3Uri -> ExceptT (Variant e) m S3Uri)
-> Either UnsupportedUri S3Uri -> ExceptT (Variant e) m S3Uri
forall a b. (a -> b) -> a -> b
$ URI -> Either UnsupportedUri S3Uri
uriToS3Uri (URI -> URI
URI.reslashUri URI
target)
  let copyObjectRequest :: CopyObject
copyObjectRequest = BucketName -> Text -> ObjectKey -> CopyObject
AWS.newCopyObject BucketName
targetBucket (BucketName -> Text
forall a. ToText a => a -> Text
toText BucketName
sourceBucket Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ObjectKey -> Text
forall a. ToText a => a -> Text
toText ObjectKey
sourceObjectKey) ObjectKey
targetObjectKey
  CopyObjectResponse
response <- (ResourceT m (Either (Variant e) CopyObjectResponse)
 -> m (Either (Variant e) CopyObjectResponse))
-> ExceptT (Variant e) (ResourceT m) CopyObjectResponse
-> ExceptT (Variant e) m CopyObjectResponse
forall x (m :: * -> *) a (n :: * -> *) b.
(m (Either x a) -> n (Either x b))
-> ExceptT x m a -> ExceptT x n b
OO.suspend ResourceT m (Either (Variant e) CopyObjectResponse)
-> m (Either (Variant e) CopyObjectResponse)
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ExceptT (Variant e) (ResourceT m) CopyObjectResponse
 -> ExceptT (Variant e) m CopyObjectResponse)
-> ExceptT (Variant e) (ResourceT m) CopyObjectResponse
-> ExceptT (Variant e) m CopyObjectResponse
forall a b. (a -> b) -> a -> b
$ Env
-> CopyObject
-> ExceptT (Variant e) (ResourceT m) (AWSResponse CopyObject)
forall (m :: * -> *) a.
(MonadResource m, AWSRequest a, Typeable a,
 Typeable (AWSResponse a)) =>
Env -> a -> m (AWSResponse a)
AWS.send Env
envAws CopyObject
copyObjectRequest
  let responseCode :: Int
responseCode = CopyObjectResponse
response CopyObjectResponse -> Getting Int CopyObjectResponse Int -> Int
forall s a. s -> Getting a s a -> a
^. forall {k} (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall (sel :: Symbol) s t a b. HasAny sel s t a b => Lens s t a b
the @"httpStatus"
  Bool -> ExceptT (Variant e) m () -> ExceptT (Variant e) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
200 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
responseCode Bool -> Bool -> Bool
&& Int
responseCode Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
300) do
    IO () -> ExceptT (Variant e) m ()
forall a. IO a -> ExceptT (Variant e) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT (Variant e) m ())
-> IO () -> ExceptT (Variant e) m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
CIO.hPutStrLn Handle
IO.stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Error in S3 copy: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CopyObjectResponse -> Text
forall a. Show a => a -> Text
tshow CopyObjectResponse
response
    CopyFailed -> ExceptT (Variant e) m ()
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw CopyFailed
CopyFailed