{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

module HaskellWorks.CabalCache.IO.Lazy
  ( readResource
  , readFirstAvailableResource
  , resourceExists
  , firstExistingResource
  , headS3Uri
  , writeResource
  , createLocalDirectoryIfMissing
  , linkOrCopyResource
  , readHttpUri
  , removePathRecursive
  ) where

import Antiope.Core
import Antiope.S3.Lazy                  (S3Uri)
import Control.Lens
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Trans.Resource
import Data.Either                      (isRight)
import Data.Generics.Product.Any
import HaskellWorks.CabalCache.AppError
import HaskellWorks.CabalCache.Location (Location (..))
import HaskellWorks.CabalCache.Show

import qualified Antiope.S3.Lazy                    as AWS
import qualified Control.Concurrent                 as IO
import qualified Data.ByteString.Lazy               as LBS
import qualified Data.Text                          as T
import qualified HaskellWorks.CabalCache.IO.Console as CIO
import qualified Network.AWS                        as AWS
import qualified Network.AWS.S3.CopyObject          as AWS
import qualified Network.AWS.S3.HeadObject          as AWS
import qualified Network.AWS.S3.PutObject           as AWS
import qualified Network.HTTP.Client                as HTTP
import qualified Network.HTTP.Types                 as HTTP
import qualified System.Directory                   as IO
import qualified System.FilePath.Posix              as FP
import qualified System.IO                          as IO
import qualified System.IO.Error                    as IO

{- HLINT ignore "Redundant do"        -}
{- HLINT ignore "Reduce duplication"  -}
{- HLINT ignore "Redundant bracket"   -}

handleAwsError :: MonadCatch m => m a -> m (Either AppError a)
handleAwsError :: m a -> m (Either AppError a)
handleAwsError m a
f = m (Either AppError a)
-> (Error -> m (Either AppError a)) -> m (Either AppError a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (a -> Either AppError a
forall a b. b -> Either a b
Right (a -> Either AppError a) -> m a -> m (Either AppError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
f) ((Error -> m (Either AppError a)) -> m (Either AppError a))
-> (Error -> m (Either AppError a)) -> m (Either AppError a)
forall a b. (a -> b) -> a -> b
$ \(Error
e :: AWS.Error) ->
  case Error
e of
    (AWS.ServiceError (AWS.ServiceError' Abbrev
_ s :: Status
s@(HTTP.Status Int
404 ByteString
_) [Header]
_ ErrorCode
_ Maybe ErrorMessage
_ Maybe RequestId
_)) -> Either AppError a -> m (Either AppError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (AppError -> Either AppError a
forall a b. a -> Either a b
Left (Status -> AppError
AwsAppError Status
s))
    (AWS.ServiceError (AWS.ServiceError' Abbrev
_ s :: Status
s@(HTTP.Status Int
301 ByteString
_) [Header]
_ ErrorCode
_ Maybe ErrorMessage
_ Maybe RequestId
_)) -> Either AppError a -> m (Either AppError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (AppError -> Either AppError a
forall a b. a -> Either a b
Left (Status -> AppError
AwsAppError Status
s))
    Error
_                                                                      -> Error -> m (Either AppError a)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Error
e

handleHttpError :: (MonadCatch m, MonadIO m) => m a -> m (Either AppError a)
handleHttpError :: m a -> m (Either AppError a)
handleHttpError m a
f = m (Either AppError a)
-> (HttpException -> m (Either AppError a))
-> m (Either AppError a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (a -> Either AppError a
forall a b. b -> Either a b
Right (a -> Either AppError a) -> m a -> m (Either AppError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
f) ((HttpException -> m (Either AppError a)) -> m (Either AppError a))
-> (HttpException -> m (Either AppError a))
-> m (Either AppError a)
forall a b. (a -> b) -> a -> b
$ \(HttpException
e :: HTTP.HttpException) ->
  case HttpException
e of
    (HTTP.HttpExceptionRequest Request
_ HttpExceptionContent
e') -> case HttpExceptionContent
e' of
      HTTP.StatusCodeException Response ()
resp ByteString
_ -> Either AppError a -> m (Either AppError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (AppError -> Either AppError a
forall a b. a -> Either a b
Left (Status -> AppError
HttpAppError (Response ()
resp Response () -> (Response () -> Status) -> Status
forall a b. a -> (a -> b) -> b
& Response () -> Status
forall body. Response body -> Status
HTTP.responseStatus)))
      HttpExceptionContent
_                               -> Either AppError a -> m (Either AppError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (AppError -> Either AppError a
forall a b. a -> Either a b
Left (Text -> AppError
GenericAppError (HttpExceptionContent -> Text
forall a. Show a => a -> Text
tshow HttpExceptionContent
e')))
    HttpException
_                                 -> HttpException -> m (Either AppError a)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM HttpException
e

getS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either AppError LBS.ByteString)
getS3Uri :: Env -> S3Uri -> m (Either AppError ByteString)
getS3Uri Env
envAws S3Uri
s3Uri = case S3Uri -> S3Uri
reslashS3Uri S3Uri
s3Uri of
  (AWS.S3Uri BucketName
b ObjectKey
k) -> m ByteString -> m (Either AppError ByteString)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either AppError a)
handleAwsError (m ByteString -> m (Either AppError ByteString))
-> m ByteString -> m (Either AppError ByteString)
forall a b. (a -> b) -> a -> b
$ Env -> AWS ByteString -> m ByteString
forall (m :: * -> *) r a.
(MonadResource m, HasEnv r) =>
r -> AWS a -> m a
runAws Env
envAws (AWS ByteString -> m ByteString) -> AWS ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ BucketName -> ObjectKey -> AWS ByteString
forall (m :: * -> *).
(MonadAWS m, MonadResource m) =>
BucketName -> ObjectKey -> m ByteString
AWS.unsafeDownload BucketName
b ObjectKey
k

readResource :: (MonadResource m, MonadCatch m) => AWS.Env -> Location -> m (Either AppError LBS.ByteString)
readResource :: Env -> Location -> m (Either AppError ByteString)
readResource Env
envAws = \case
  S3 S3Uri
s3Uri        -> Env -> S3Uri -> m (Either AppError ByteString)
forall (m :: * -> *).
(MonadResource m, MonadCatch m) =>
Env -> S3Uri -> m (Either AppError ByteString)
getS3Uri Env
envAws (S3Uri -> S3Uri
reslashS3Uri S3Uri
s3Uri)
  Local FilePath
path      -> IO (Either AppError ByteString) -> m (Either AppError ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either AppError ByteString) -> m (Either AppError ByteString))
-> IO (Either AppError ByteString)
-> m (Either AppError ByteString)
forall a b. (a -> b) -> a -> b
$ do
    Bool
fileExists <- FilePath -> IO Bool
IO.doesFileExist FilePath
path
    if Bool
fileExists
      then ByteString -> Either AppError ByteString
forall a b. b -> Either a b
Right (ByteString -> Either AppError ByteString)
-> IO ByteString -> IO (Either AppError ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
LBS.readFile FilePath
path
      else Either AppError ByteString -> IO (Either AppError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AppError -> Either AppError ByteString
forall a b. a -> Either a b
Left AppError
NotFound)
  HttpUri Text
httpUri -> IO (Either AppError ByteString) -> m (Either AppError ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either AppError ByteString) -> m (Either AppError ByteString))
-> IO (Either AppError ByteString)
-> m (Either AppError ByteString)
forall a b. (a -> b) -> a -> b
$ Text -> IO (Either AppError ByteString)
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
Text -> m (Either AppError ByteString)
readHttpUri (Text -> Text
reslashHttpUri Text
httpUri)

readFirstAvailableResource :: (MonadResource m, MonadCatch m) => AWS.Env -> [Location] -> m (Either AppError (LBS.ByteString, Location))
readFirstAvailableResource :: Env -> [Location] -> m (Either AppError (ByteString, Location))
readFirstAvailableResource Env
_ [] = Either AppError (ByteString, Location)
-> m (Either AppError (ByteString, Location))
forall (m :: * -> *) a. Monad m => a -> m a
return (AppError -> Either AppError (ByteString, Location)
forall a b. a -> Either a b
Left (Text -> AppError
GenericAppError Text
"No resources specified in read"))
readFirstAvailableResource Env
envAws (Location
a:[Location]
as) = do
  Either AppError ByteString
result <- Env -> Location -> m (Either AppError ByteString)
forall (m :: * -> *).
(MonadResource m, MonadCatch m) =>
Env -> Location -> m (Either AppError ByteString)
readResource Env
envAws Location
a
  case Either AppError ByteString
result of
    Right ByteString
lbs -> Either AppError (ByteString, Location)
-> m (Either AppError (ByteString, Location))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AppError (ByteString, Location)
 -> m (Either AppError (ByteString, Location)))
-> Either AppError (ByteString, Location)
-> m (Either AppError (ByteString, Location))
forall a b. (a -> b) -> a -> b
$ (ByteString, Location) -> Either AppError (ByteString, Location)
forall a b. b -> Either a b
Right (ByteString
lbs, Location
a)
    Left AppError
e -> if [Location] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Location]
as
      then Either AppError (ByteString, Location)
-> m (Either AppError (ByteString, Location))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AppError (ByteString, Location)
 -> m (Either AppError (ByteString, Location)))
-> Either AppError (ByteString, Location)
-> m (Either AppError (ByteString, Location))
forall a b. (a -> b) -> a -> b
$ AppError -> Either AppError (ByteString, Location)
forall a b. a -> Either a b
Left AppError
e
      else Env -> [Location] -> m (Either AppError (ByteString, Location))
forall (m :: * -> *).
(MonadResource m, MonadCatch m) =>
Env -> [Location] -> m (Either AppError (ByteString, Location))
readFirstAvailableResource Env
envAws [Location]
as

safePathIsSymbolLink :: FilePath -> IO Bool
safePathIsSymbolLink :: FilePath -> IO Bool
safePathIsSymbolLink FilePath
filePath = IO Bool -> (IOError -> IO Bool) -> IO Bool
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (FilePath -> IO Bool
IO.pathIsSymbolicLink FilePath
filePath) IOError -> IO Bool
handler
  where handler :: IOError -> IO Bool
        handler :: IOError -> IO Bool
handler IOError
e = if IOError -> Bool
IO.isDoesNotExistError IOError
e
          then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

resourceExists :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> Location -> m Bool
resourceExists :: Env -> Location -> m Bool
resourceExists Env
envAws = \case
  S3 S3Uri
s3Uri        -> Either AppError HeadObjectResponse -> Bool
forall a b. Either a b -> Bool
isRight (Either AppError HeadObjectResponse -> Bool)
-> m (Either AppError HeadObjectResponse) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResourceT m (Either AppError HeadObjectResponse)
-> m (Either AppError HeadObjectResponse)
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (Env -> S3Uri -> ResourceT m (Either AppError HeadObjectResponse)
forall (m :: * -> *).
(MonadResource m, MonadCatch m) =>
Env -> S3Uri -> m (Either AppError HeadObjectResponse)
headS3Uri Env
envAws (S3Uri -> S3Uri
reslashS3Uri S3Uri
s3Uri))
  HttpUri Text
httpUri -> Either AppError ByteString -> Bool
forall a b. Either a b -> Bool
isRight (Either AppError ByteString -> Bool)
-> m (Either AppError ByteString) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (Either AppError ByteString)
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
Text -> m (Either AppError ByteString)
headHttpUri (Text -> Text
reslashHttpUri Text
httpUri)
  Local FilePath
path  -> do
    Bool
fileExists <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
IO.doesFileExist FilePath
path
    if Bool
fileExists
      then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      else do
        Bool
symbolicLinkExists <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
safePathIsSymbolLink FilePath
path
        if Bool
symbolicLinkExists
          then do
            FilePath
target <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
IO.getSymbolicLinkTarget FilePath
path
            Env -> Location -> m Bool
forall (m :: * -> *).
(MonadUnliftIO m, MonadCatch m, MonadIO m) =>
Env -> Location -> m Bool
resourceExists Env
envAws (FilePath -> Location
Local FilePath
target)
          else Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

firstExistingResource :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> [Location] -> m (Maybe Location)
firstExistingResource :: Env -> [Location] -> m (Maybe Location)
firstExistingResource Env
_ [] = Maybe Location -> m (Maybe Location)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Location
forall a. Maybe a
Nothing
firstExistingResource Env
envAws (Location
a:[Location]
as) = do
  Bool
exists <- Env -> Location -> m Bool
forall (m :: * -> *).
(MonadUnliftIO m, MonadCatch m, MonadIO m) =>
Env -> Location -> m Bool
resourceExists Env
envAws Location
a
  if Bool
exists
    then Maybe Location -> m (Maybe Location)
forall (m :: * -> *) a. Monad m => a -> m a
return (Location -> Maybe Location
forall a. a -> Maybe a
Just Location
a)
    else Env -> [Location] -> m (Maybe Location)
forall (m :: * -> *).
(MonadUnliftIO m, MonadCatch m, MonadIO m) =>
Env -> [Location] -> m (Maybe Location)
firstExistingResource Env
envAws [Location]
as

headS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either AppError AWS.HeadObjectResponse)
headS3Uri :: Env -> S3Uri -> m (Either AppError HeadObjectResponse)
headS3Uri Env
envAws S3Uri
s3Uri = case S3Uri -> S3Uri
reslashS3Uri S3Uri
s3Uri of
  AWS.S3Uri BucketName
b ObjectKey
k -> m HeadObjectResponse -> m (Either AppError HeadObjectResponse)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either AppError a)
handleAwsError (m HeadObjectResponse -> m (Either AppError HeadObjectResponse))
-> m HeadObjectResponse -> m (Either AppError HeadObjectResponse)
forall a b. (a -> b) -> a -> b
$ Env -> AWS HeadObjectResponse -> m HeadObjectResponse
forall (m :: * -> *) r a.
(MonadResource m, HasEnv r) =>
r -> AWS a -> m a
runAws Env
envAws (AWS HeadObjectResponse -> m HeadObjectResponse)
-> AWS HeadObjectResponse -> m HeadObjectResponse
forall a b. (a -> b) -> a -> b
$ HeadObject -> AWST' Env (ResourceT IO) (Rs HeadObject)
forall (m :: * -> *) a. (MonadAWS m, AWSRequest a) => a -> m (Rs a)
AWS.send (HeadObject -> AWST' Env (ResourceT IO) (Rs HeadObject))
-> HeadObject -> AWST' Env (ResourceT IO) (Rs HeadObject)
forall a b. (a -> b) -> a -> b
$ BucketName -> ObjectKey -> HeadObject
AWS.headObject BucketName
b ObjectKey
k

uploadToS3 :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> LBS.ByteString -> m (Either AppError ())
uploadToS3 :: Env -> S3Uri -> ByteString -> m (Either AppError ())
uploadToS3 Env
envAws S3Uri
s3Uri ByteString
lbs = case S3Uri -> S3Uri
reslashS3Uri S3Uri
s3Uri of
  AWS.S3Uri BucketName
b ObjectKey
k -> do
    let req :: RqBody
req = ByteString -> RqBody
forall a. ToBody a => a -> RqBody
AWS.toBody ByteString
lbs
    let po :: PutObject
po  = BucketName -> ObjectKey -> RqBody -> PutObject
AWS.putObject BucketName
b ObjectKey
k RqBody
req
    m () -> m (Either AppError ())
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either AppError a)
handleAwsError (m () -> m (Either AppError ())) -> m () -> m (Either AppError ())
forall a b. (a -> b) -> a -> b
$ m PutObjectResponse -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m PutObjectResponse -> m ()) -> m PutObjectResponse -> m ()
forall a b. (a -> b) -> a -> b
$ Env -> AWS PutObjectResponse -> m PutObjectResponse
forall (m :: * -> *) r a.
(MonadUnliftIO m, HasEnv r) =>
r -> AWS a -> m a
runResAws Env
envAws (AWS PutObjectResponse -> m PutObjectResponse)
-> AWS PutObjectResponse -> m PutObjectResponse
forall a b. (a -> b) -> a -> b
$ PutObject -> AWST' Env (ResourceT IO) (Rs PutObject)
forall (m :: * -> *) a. (MonadAWS m, AWSRequest a) => a -> m (Rs a)
AWS.send PutObject
po

reslashS3Uri :: S3Uri -> S3Uri
reslashS3Uri :: S3Uri -> S3Uri
reslashS3Uri S3Uri
uri = S3Uri
uri S3Uri -> (S3Uri -> S3Uri) -> S3Uri
forall a b. a -> (a -> b) -> b
& forall k (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall s t a b. HasAny "objectKey" s t a b => Lens s t a b
the @"objectKey" ((ObjectKey -> Identity ObjectKey) -> S3Uri -> Identity S3Uri)
-> ((Text -> Identity Text) -> ObjectKey -> Identity ObjectKey)
-> (Text -> Identity Text)
-> S3Uri
-> Identity S3Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall s t a b. HasAny 1 s t a b => Lens s t a b
the @1 ((Text -> Identity Text) -> S3Uri -> Identity S3Uri)
-> (Text -> Text) -> S3Uri -> S3Uri
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Text -> Text -> Text -> Text
T.replace Text
"\\" Text
"/")

reslashHttpUri :: Text -> Text
reslashHttpUri :: Text -> Text
reslashHttpUri = Text -> Text -> Text -> Text
T.replace Text
"\\" Text
"/"

writeResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> LBS.ByteString -> ExceptT AppError m ()
writeResource :: Env -> Location -> ByteString -> ExceptT AppError m ()
writeResource Env
envAws Location
loc ByteString
lbs = m (Either AppError ()) -> ExceptT AppError m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either AppError ()) -> ExceptT AppError m ())
-> m (Either AppError ()) -> ExceptT AppError m ()
forall a b. (a -> b) -> a -> b
$ case Location
loc of
  S3 S3Uri
s3Uri   -> Env -> S3Uri -> ByteString -> m (Either AppError ())
forall (m :: * -> *).
(MonadUnliftIO m, MonadCatch m) =>
Env -> S3Uri -> ByteString -> m (Either AppError ())
uploadToS3 Env
envAws (S3Uri -> S3Uri
reslashS3Uri S3Uri
s3Uri) ByteString
lbs
  Local FilePath
path -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> ByteString -> IO ()
LBS.writeFile FilePath
path ByteString
lbs) m () -> m (Either AppError ()) -> m (Either AppError ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either AppError () -> m (Either AppError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either AppError ()
forall a b. b -> Either a b
Right ())
  HttpUri Text
_  -> Either AppError () -> m (Either AppError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (AppError -> Either AppError ()
forall a b. a -> Either a b
Left (Text -> AppError
GenericAppError Text
"HTTP PUT method not supported"))

createLocalDirectoryIfMissing :: (MonadCatch m, MonadIO m) => Location -> m ()
createLocalDirectoryIfMissing :: Location -> m ()
createLocalDirectoryIfMissing = \case
  S3 S3Uri
_        -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Local FilePath
path  -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
IO.createDirectoryIfMissing Bool
True FilePath
path
  HttpUri Text
_   -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

copyS3Uri :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> AWS.S3Uri -> ExceptT AppError m ()
copyS3Uri :: Env -> S3Uri -> S3Uri -> ExceptT AppError m ()
copyS3Uri Env
envAws S3Uri
source S3Uri
target = case (S3Uri -> S3Uri
reslashS3Uri S3Uri
source, S3Uri -> S3Uri
reslashS3Uri S3Uri
target) of
  (AWS.S3Uri BucketName
sourceBucket ObjectKey
sourceObjectKey, AWS.S3Uri BucketName
targetBucket ObjectKey
targetObjectKey) -> m (Either AppError ()) -> ExceptT AppError m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either AppError ()) -> ExceptT AppError m ())
-> m (Either AppError ()) -> ExceptT AppError m ()
forall a b. (a -> b) -> a -> b
$ do
    Either AppError CopyObjectResponse
responseResult <- ResourceT m (Either AppError CopyObjectResponse)
-> m (Either AppError CopyObjectResponse)
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT m (Either AppError CopyObjectResponse)
 -> m (Either AppError CopyObjectResponse))
-> ResourceT m (Either AppError CopyObjectResponse)
-> m (Either AppError CopyObjectResponse)
forall a b. (a -> b) -> a -> b
$
      ResourceT m CopyObjectResponse
-> ResourceT m (Either AppError CopyObjectResponse)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either AppError a)
handleAwsError (ResourceT m CopyObjectResponse
 -> ResourceT m (Either AppError CopyObjectResponse))
-> ResourceT m CopyObjectResponse
-> ResourceT m (Either AppError CopyObjectResponse)
forall a b. (a -> b) -> a -> b
$ Env -> AWS CopyObjectResponse -> ResourceT m CopyObjectResponse
forall (m :: * -> *) r a.
(MonadResource m, HasEnv r) =>
r -> AWS a -> m a
runAws Env
envAws (AWS CopyObjectResponse -> ResourceT m CopyObjectResponse)
-> AWS CopyObjectResponse -> ResourceT m CopyObjectResponse
forall a b. (a -> b) -> a -> b
$ CopyObject -> AWST' Env (ResourceT IO) (Rs CopyObject)
forall (m :: * -> *) a. (MonadAWS m, AWSRequest a) => a -> m (Rs a)
AWS.send (BucketName -> Text -> ObjectKey -> CopyObject
AWS.copyObject 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)
    case Either AppError CopyObjectResponse
responseResult of
      Right CopyObjectResponse
response -> do
        let responseCode :: Int
responseCode = CopyObjectResponse
response CopyObjectResponse -> Getting Int CopyObjectResponse Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int CopyObjectResponse Int
Lens' CopyObjectResponse Int
AWS.corsResponseStatus
        if 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
          then Either AppError () -> m (Either AppError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either AppError ()
forall a b. b -> Either a b
Right ())
          else do
            IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> 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
            Either AppError () -> m (Either AppError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (AppError -> Either AppError ()
forall a b. a -> Either a b
Left AppError
RetriesFailedAppError)
      Left AppError
msg -> Either AppError () -> m (Either AppError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (AppError -> Either AppError ()
forall a b. a -> Either a b
Left AppError
msg)

retry :: (Show e, MonadIO m) => Int -> ExceptT e m () -> ExceptT e m ()
retry :: Int -> ExceptT e m () -> ExceptT e m ()
retry = (e -> Bool) -> Int -> ExceptT e m () -> ExceptT e m ()
forall e (m :: * -> *).
(Show e, MonadIO m) =>
(e -> Bool) -> Int -> ExceptT e m () -> ExceptT e m ()
retryWhen (Bool -> e -> Bool
forall a b. a -> b -> a
const Bool
True)

retryWhen :: (Show e, MonadIO m) => (e -> Bool) -> Int -> ExceptT e m () -> ExceptT e m ()
retryWhen :: (e -> Bool) -> Int -> ExceptT e m () -> ExceptT e m ()
retryWhen e -> Bool
p Int
n ExceptT e m ()
f = ExceptT e m () -> (e -> ExceptT e m ()) -> ExceptT e m ()
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ExceptT e m ()
f ((e -> ExceptT e m ()) -> ExceptT e m ())
-> (e -> ExceptT e m ()) -> ExceptT e m ()
forall a b. (a -> b) -> a -> b
$ \e
exception -> if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  then do
    IO () -> ExceptT e m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT e m ()) -> IO () -> ExceptT 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
"WARNING: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> e -> Text
forall a. Show a => a -> Text
tshow e
exception Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (retrying)"
    IO () -> ExceptT e m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT e m ()) -> IO () -> ExceptT e m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
IO.threadDelay Int
1000000
    if (e -> Bool
p e
exception )
      then Int -> ExceptT e m () -> ExceptT e m ()
forall e (m :: * -> *).
(Show e, MonadIO m) =>
Int -> ExceptT e m () -> ExceptT e m ()
retry (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ExceptT e m ()
f
      else e -> ExceptT e m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
exception
  else e -> ExceptT e m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
exception

retryUnless :: (Show e, MonadIO m) => (e -> Bool) -> Int -> ExceptT e m () -> ExceptT e m ()
retryUnless :: (e -> Bool) -> Int -> ExceptT e m () -> ExceptT e m ()
retryUnless e -> Bool
p = (e -> Bool) -> Int -> ExceptT e m () -> ExceptT e m ()
forall e (m :: * -> *).
(Show e, MonadIO m) =>
(e -> Bool) -> Int -> ExceptT e m () -> ExceptT e m ()
retryWhen (Bool -> Bool
not (Bool -> Bool) -> (e -> Bool) -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Bool
p)

linkOrCopyResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> Location -> ExceptT AppError m ()
linkOrCopyResource :: Env -> Location -> Location -> ExceptT AppError m ()
linkOrCopyResource Env
envAws Location
source Location
target = case Location
source of
  S3 S3Uri
sourceS3Uri -> case Location
target of
    S3 S3Uri
targetS3Uri -> (AppError -> Bool)
-> Int -> ExceptT AppError m () -> ExceptT AppError m ()
forall e (m :: * -> *).
(Show e, MonadIO m) =>
(e -> Bool) -> Int -> ExceptT e m () -> ExceptT e m ()
retryUnless ((Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just Int
301) (Maybe Int -> Bool) -> (AppError -> Maybe Int) -> AppError -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppError -> Maybe Int
appErrorStatus) Int
3 (Env -> S3Uri -> S3Uri -> ExceptT AppError m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadCatch m) =>
Env -> S3Uri -> S3Uri -> ExceptT AppError m ()
copyS3Uri Env
envAws (S3Uri -> S3Uri
reslashS3Uri S3Uri
sourceS3Uri) (S3Uri -> S3Uri
reslashS3Uri S3Uri
targetS3Uri))
    Local FilePath
_        -> AppError -> ExceptT AppError m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError AppError
"Can't copy between different file backends"
    HttpUri Text
_      -> AppError -> ExceptT AppError m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError AppError
"Link and copy unsupported for http backend"
  Local FilePath
sourcePath -> case Location
target of
    S3 S3Uri
_             -> AppError -> ExceptT AppError m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError AppError
"Can't copy between different file backends"
    Local FilePath
targetPath -> do
      IO () -> ExceptT AppError m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT AppError m ()) -> IO () -> ExceptT AppError m ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
IO.createDirectoryIfMissing Bool
True (FilePath -> FilePath
FP.takeDirectory FilePath
targetPath)
      Bool
targetPathExists <- IO Bool -> ExceptT AppError m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT AppError m Bool)
-> IO Bool -> ExceptT AppError m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
IO.doesFileExist FilePath
targetPath
      Bool -> ExceptT AppError m () -> ExceptT AppError m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
targetPathExists (ExceptT AppError m () -> ExceptT AppError m ())
-> ExceptT AppError m () -> ExceptT AppError m ()
forall a b. (a -> b) -> a -> b
$ IO () -> ExceptT AppError m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT AppError m ()) -> IO () -> ExceptT AppError m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
IO.createFileLink FilePath
sourcePath FilePath
targetPath
    HttpUri Text
_      -> AppError -> ExceptT AppError m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError AppError
"Link and copy unsupported for http backend"
  HttpUri Text
_ -> AppError -> ExceptT AppError m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError AppError
"HTTP PUT method not supported"

readHttpUri :: (MonadIO m, MonadCatch m) => Text -> m (Either AppError LBS.ByteString)
readHttpUri :: Text -> m (Either AppError ByteString)
readHttpUri Text
httpUri = m ByteString -> m (Either AppError ByteString)
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
m a -> m (Either AppError a)
handleHttpError (m ByteString -> m (Either AppError ByteString))
-> m ByteString -> m (Either AppError ByteString)
forall a b. (a -> b) -> a -> b
$ do
  Manager
manager <- IO Manager -> m Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> m Manager) -> IO Manager -> m Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
HTTP.defaultManagerSettings
  Request
request <- IO Request -> m Request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> m Request) -> IO Request -> m Request
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
HTTP.parseUrlThrow (Text -> FilePath
T.unpack (Text
"GET " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
reslashHttpUri Text
httpUri))
  Response ByteString
response <- IO (Response ByteString) -> m (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> m (Response ByteString))
-> IO (Response ByteString) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
request Manager
manager

  ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
response

headHttpUri :: (MonadIO m, MonadCatch m) => Text -> m (Either AppError LBS.ByteString)
headHttpUri :: Text -> m (Either AppError ByteString)
headHttpUri Text
httpUri = m ByteString -> m (Either AppError ByteString)
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
m a -> m (Either AppError a)
handleHttpError (m ByteString -> m (Either AppError ByteString))
-> m ByteString -> m (Either AppError ByteString)
forall a b. (a -> b) -> a -> b
$ do
  Manager
manager <- IO Manager -> m Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> m Manager) -> IO Manager -> m Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
HTTP.defaultManagerSettings
  Request
request <- IO Request -> m Request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> m Request) -> IO Request -> m Request
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
HTTP.parseUrlThrow (Text -> FilePath
T.unpack (Text
"HEAD " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
reslashHttpUri Text
httpUri)))
  Response ByteString
response <- IO (Response ByteString) -> m (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> m (Response ByteString))
-> IO (Response ByteString) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
request Manager
manager

  ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
response

removePathRecursive :: (MonadIO m, MonadCatch m) => FilePath -> m (Either AppError ())
removePathRecursive :: FilePath -> m (Either AppError ())
removePathRecursive FilePath
pkgStorePath = m (Either AppError ())
-> (IOError -> m (Either AppError ())) -> m (Either AppError ())
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch m (Either AppError ())
forall (m :: * -> *). MonadIO m => m (Either AppError ())
action IOError -> m (Either AppError ())
forall (m :: * -> *).
MonadIO m =>
IOError -> m (Either AppError ())
handler
  where action :: MonadIO m => m (Either AppError ())
        action :: m (Either AppError ())
action = () -> Either AppError ()
forall a b. b -> Either a b
Right (() -> Either AppError ()) -> m () -> m (Either AppError ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ()
IO.removeDirectoryRecursive FilePath
pkgStorePath)
        handler :: MonadIO m => IOError -> m (Either AppError ())
        handler :: IOError -> m (Either AppError ())
handler IOError
e = do
          Handle -> Text -> m ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
CIO.hPutStrLn Handle
IO.stderr (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Warning: Caught " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IOError -> Text
forall a. Show a => a -> Text
tshow IOError
e
          Either AppError () -> m (Either AppError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (AppError -> Either AppError ()
forall a b. a -> Either a b
Left (Text -> AppError
GenericAppError (IOError -> Text
forall a. Show a => a -> Text
tshow IOError
e)))