{-# 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.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 Network.URI                      (URI)

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 Network.HTTP.Client.TLS            as HTTPS
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 -> URI -> m (Either AppError LBS.ByteString)
getS3Uri :: Env -> URI -> m (Either AppError ByteString)
getS3Uri Env
envAws URI
uri = ExceptT AppError m ByteString -> m (Either AppError ByteString)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT AppError m ByteString -> m (Either AppError ByteString))
-> ExceptT AppError m ByteString -> m (Either AppError ByteString)
forall a b. (a -> b) -> a -> b
$ do
  AWS.S3Uri BucketName
b ObjectKey
k <- Either AppError S3Uri -> ExceptT AppError m S3Uri
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either AppError S3Uri -> ExceptT AppError m S3Uri)
-> Either AppError S3Uri -> ExceptT AppError m S3Uri
forall a b. (a -> b) -> a -> b
$ URI -> Either AppError S3Uri
uriToS3Uri (URI -> URI
reslashUri URI
uri)
  m (Either AppError ByteString) -> ExceptT AppError m ByteString
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either AppError ByteString) -> ExceptT AppError m ByteString)
-> (m ByteString -> m (Either AppError ByteString))
-> m ByteString
-> ExceptT AppError m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m ByteString -> m (Either AppError ByteString)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either AppError a)
handleAwsError (m ByteString -> ExceptT AppError m ByteString)
-> m ByteString -> ExceptT AppError m 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

uriToS3Uri :: URI -> Either AppError S3Uri
uriToS3Uri :: URI -> Either AppError S3Uri
uriToS3Uri URI
uri = case Text -> Either String S3Uri
forall a. FromText a => Text -> Either String a
fromText @S3Uri (URI -> Text
forall a. Show a => a -> Text
tshow URI
uri) of
  Right S3Uri
s3Uri -> S3Uri -> Either AppError S3Uri
forall a b. b -> Either a b
Right S3Uri
s3Uri
  Left String
msg    -> AppError -> Either AppError S3Uri
forall a b. a -> Either a b
Left (AppError -> Either AppError S3Uri)
-> (Text -> AppError) -> Text -> Either AppError S3Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> AppError
GenericAppError (Text -> Either AppError S3Uri) -> Text -> Either AppError S3Uri
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

readResource :: (MonadResource m, MonadCatch m) => AWS.Env -> Location -> m (Either AppError LBS.ByteString)
readResource :: Env -> Location -> m (Either AppError ByteString)
readResource Env
envAws = \case
  Local String
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 <- String -> IO Bool
IO.doesFileExist String
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
<$> String -> IO ByteString
LBS.readFile String
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)
  Uri URI
uri -> case URI
uri URI -> Getting String URI String -> String
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 s t a b. HasAny "uriScheme" s t a b => Lens s t a b
the @"uriScheme" of
    String
"s3:"     -> Env -> URI -> m (Either AppError ByteString)
forall (m :: * -> *).
(MonadResource m, MonadCatch m) =>
Env -> URI -> m (Either AppError ByteString)
getS3Uri Env
envAws (URI -> URI
reslashUri URI
uri)
    String
"http:"   -> 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
$ URI -> IO (Either AppError ByteString)
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
URI -> m (Either AppError ByteString)
readHttpUri (URI -> URI
reslashUri URI
uri)
    String
"https:"  -> 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
$ URI -> IO (Either AppError ByteString)
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
URI -> m (Either AppError ByteString)
readHttpUri (URI -> URI
reslashUri URI
uri)
    String
scheme    -> Either AppError ByteString -> m (Either AppError ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (AppError -> Either AppError ByteString
forall a b. a -> Either a b
Left (Text -> AppError
GenericAppError (Text
"Unrecognised uri scheme: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
scheme)))

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 :: String -> IO Bool
safePathIsSymbolLink String
filePath = IO Bool -> (IOError -> IO Bool) -> IO Bool
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (String -> IO Bool
IO.pathIsSymbolicLink String
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
  Local String
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
$ String -> IO Bool
IO.doesFileExist String
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
$ String -> IO Bool
safePathIsSymbolLink String
path
        if Bool
symbolicLinkExists
          then do
            String
target <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
IO.getSymbolicLinkTarget String
path
            Env -> Location -> m Bool
forall (m :: * -> *).
(MonadUnliftIO m, MonadCatch m, MonadIO m) =>
Env -> Location -> m Bool
resourceExists Env
envAws (String -> Location
Local String
target)
          else Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  Uri URI
uri       -> case URI
uri URI -> Getting String URI String -> String
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 s t a b. HasAny "uriScheme" s t a b => Lens s t a b
the @"uriScheme" of
    String
"s3:"   -> 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 -> URI -> ResourceT m (Either AppError HeadObjectResponse)
forall (m :: * -> *).
(MonadResource m, MonadCatch m) =>
Env -> URI -> m (Either AppError HeadObjectResponse)
headS3Uri Env
envAws (URI -> URI
reslashUri URI
uri))
    String
"http:" -> 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
<$> URI -> m (Either AppError ByteString)
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
URI -> m (Either AppError ByteString)
headHttpUri (URI -> URI
reslashUri URI
uri)
    String
_scheme -> 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 -> URI -> m (Either AppError AWS.HeadObjectResponse)
headS3Uri :: Env -> URI -> m (Either AppError HeadObjectResponse)
headS3Uri Env
envAws URI
uri = ExceptT AppError m HeadObjectResponse
-> m (Either AppError HeadObjectResponse)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT AppError m HeadObjectResponse
 -> m (Either AppError HeadObjectResponse))
-> ExceptT AppError m HeadObjectResponse
-> m (Either AppError HeadObjectResponse)
forall a b. (a -> b) -> a -> b
$ do
  AWS.S3Uri BucketName
b ObjectKey
k <- Either AppError S3Uri -> ExceptT AppError m S3Uri
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either AppError S3Uri -> ExceptT AppError m S3Uri)
-> Either AppError S3Uri -> ExceptT AppError m S3Uri
forall a b. (a -> b) -> a -> b
$ URI -> Either AppError S3Uri
uriToS3Uri (URI -> URI
reslashUri URI
uri)
  m (Either AppError HeadObjectResponse)
-> ExceptT AppError m HeadObjectResponse
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either AppError HeadObjectResponse)
 -> ExceptT AppError m HeadObjectResponse)
-> (m HeadObjectResponse -> m (Either AppError HeadObjectResponse))
-> m HeadObjectResponse
-> ExceptT AppError m HeadObjectResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m HeadObjectResponse -> m (Either AppError HeadObjectResponse)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either AppError a)
handleAwsError (m HeadObjectResponse -> ExceptT AppError m HeadObjectResponse)
-> m HeadObjectResponse -> ExceptT AppError m 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 -> URI -> LBS.ByteString -> m (Either AppError ())
uploadToS3 :: Env -> URI -> ByteString -> m (Either AppError ())
uploadToS3 Env
envAws URI
uri ByteString
lbs = ExceptT AppError m () -> m (Either AppError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT AppError m () -> m (Either AppError ()))
-> ExceptT AppError m () -> m (Either AppError ())
forall a b. (a -> b) -> a -> b
$ do
  AWS.S3Uri BucketName
b ObjectKey
k <- Either AppError S3Uri -> ExceptT AppError m S3Uri
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either AppError S3Uri -> ExceptT AppError m S3Uri)
-> Either AppError S3Uri -> ExceptT AppError m S3Uri
forall a b. (a -> b) -> a -> b
$ URI -> Either AppError S3Uri
uriToS3Uri (URI -> URI
reslashUri URI
uri)
  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 (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 () -> m (Either AppError ()))
-> m ()
-> ExceptT AppError m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> m (Either AppError ())
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either AppError a)
handleAwsError (m () -> ExceptT AppError m ()) -> m () -> ExceptT AppError m ()
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

reslashUri :: URI -> URI
reslashUri :: URI -> URI
reslashUri URI
uri = URI
uri URI -> (URI -> URI) -> URI
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 "uriPath" s t a b => Lens s t a b
the @"uriPath" ((String -> Identity String) -> URI -> Identity URI)
-> (String -> String) -> URI -> URI
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
reslashChar
  where reslashChar :: Char -> Char
        reslashChar :: Char -> Char
reslashChar Char
'\\' = Char
'/'
        reslashChar Char
c    = Char
c

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
  Local String
path -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> ByteString -> IO ()
LBS.writeFile String
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 ())
  Uri URI
uri       -> case URI
uri URI -> Getting String URI String -> String
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 s t a b. HasAny "uriScheme" s t a b => Lens s t a b
the @"uriScheme" of
    String
"s3:"   -> Env -> URI -> ByteString -> m (Either AppError ())
forall (m :: * -> *).
(MonadUnliftIO m, MonadCatch m) =>
Env -> URI -> ByteString -> m (Either AppError ())
uploadToS3 Env
envAws (URI -> URI
reslashUri URI
uri) ByteString
lbs
    String
"http:" -> 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"))
    String
scheme  -> 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
"Unrecognised uri scheme: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
scheme)))

createLocalDirectoryIfMissing :: (MonadCatch m, MonadIO m) => Location -> m ()
createLocalDirectoryIfMissing :: Location -> m ()
createLocalDirectoryIfMissing = \case
  Local String
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 -> String -> IO ()
IO.createDirectoryIfMissing Bool
True String
path
  Uri URI
uri       -> case URI
uri URI -> Getting String URI String -> String
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 s t a b. HasAny "uriScheme" s t a b => Lens s t a b
the @"uriScheme" of
    String
"s3:"   -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    String
"http:" -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    String
_scheme -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

copyS3Uri :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> URI -> URI -> ExceptT AppError m ()
copyS3Uri :: Env -> URI -> URI -> ExceptT AppError m ()
copyS3Uri Env
envAws URI
source URI
target = do
  AWS.S3Uri BucketName
sourceBucket ObjectKey
sourceObjectKey <- Either AppError S3Uri -> ExceptT AppError m S3Uri
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either AppError S3Uri -> ExceptT AppError m S3Uri)
-> Either AppError S3Uri -> ExceptT AppError m S3Uri
forall a b. (a -> b) -> a -> b
$ URI -> Either AppError S3Uri
uriToS3Uri (URI -> URI
reslashUri URI
source)
  AWS.S3Uri BucketName
targetBucket ObjectKey
targetObjectKey <- Either AppError S3Uri -> ExceptT AppError m S3Uri
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either AppError S3Uri -> ExceptT AppError m S3Uri)
-> Either AppError S3Uri -> ExceptT AppError m S3Uri
forall a b. (a -> b) -> a -> b
$ URI -> Either AppError S3Uri
uriToS3Uri (URI -> URI
reslashUri URI
target)
  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
  Local String
sourcePath -> case Location
target of
    Local String
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 -> String -> IO ()
IO.createDirectoryIfMissing Bool
True (String -> String
FP.takeDirectory String
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
$ String -> IO Bool
IO.doesFileExist String
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
$ String -> String -> IO ()
IO.createFileLink String
sourcePath String
targetPath
    Uri URI
_ -> AppError -> ExceptT AppError m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError AppError
"Can't copy between different file backends"
  Uri URI
sourceUri -> case Location
target of
    Local String
_targetPath -> AppError -> ExceptT AppError m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError AppError
"Can't copy between different file backends"
    Uri URI
targetUri    -> case (URI
sourceUri URI -> Getting String URI String -> String
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 s t a b. HasAny "uriScheme" s t a b => Lens s t a b
the @"uriScheme", URI
targetUri URI -> Getting String URI String -> String
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 s t a b. HasAny "uriScheme" s t a b => Lens s t a b
the @"uriScheme") of
      (String
"s3:", String
"s3:")               -> (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 -> URI -> URI -> ExceptT AppError m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadCatch m) =>
Env -> URI -> URI -> ExceptT AppError m ()
copyS3Uri Env
envAws (URI -> URI
reslashUri URI
sourceUri) (URI -> URI
reslashUri URI
targetUri))
      (String
"http:", String
"http:")           -> AppError -> ExceptT AppError m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError AppError
"Link and copy unsupported for http backend"
      (String
sourceScheme, String
targetScheme) -> AppError -> ExceptT AppError m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AppError -> ExceptT AppError m ())
-> AppError -> ExceptT AppError m ()
forall a b. (a -> b) -> a -> b
$ Text -> AppError
GenericAppError (Text -> AppError) -> Text -> AppError
forall a b. (a -> b) -> a -> b
$ Text
"Unsupported backend combination: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
sourceScheme Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
targetScheme

readHttpUri :: (MonadIO m, MonadCatch m) => URI -> m (Either AppError LBS.ByteString)
readHttpUri :: URI -> m (Either AppError ByteString)
readHttpUri URI
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
HTTPS.tlsManagerSettings
  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
$ String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
HTTP.parseUrlThrow (Text -> String
T.unpack (Text
"GET " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> URI -> Text
forall a. Show a => a -> Text
tshow (URI -> URI
reslashUri URI
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) => URI -> m (Either AppError LBS.ByteString)
headHttpUri :: URI -> m (Either AppError ByteString)
headHttpUri URI
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
$ String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
HTTP.parseUrlThrow (Text -> String
T.unpack (Text
"HEAD " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> URI -> Text
forall a. Show a => a -> Text
tshow (URI -> URI
reslashUri URI
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 :: String -> m (Either AppError ())
removePathRecursive String
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 (String -> IO ()
IO.removeDirectoryRecursive String
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)))