{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeApplications    #-}

{-# OPTIONS_GHC -Wno-incomplete-patterns #-}

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

import Control.Monad.Catch              (MonadCatch(..))
import Control.Monad.Except             (MonadError)
import Control.Monad.Trans.Resource     (MonadResource, runResourceT, MonadUnliftIO)
import Data.Generics.Product.Any        (HasAny(the))
import Data.List.NonEmpty               (NonEmpty ((:|)))
import HaskellWorks.CabalCache.AppError (AwsError(..), HttpError(..), statusCodeOf)
import HaskellWorks.CabalCache.Error    (CopyFailed(..), InvalidUrl(..), NotFound(..), NotImplemented(..), UnsupportedUri(..))
import HaskellWorks.CabalCache.Location (Location (..))
import HaskellWorks.Prelude
import Lens.Micro
import Network.URI                      (URI)

import qualified Amazonka                             as AWS
import qualified Control.Concurrent                   as IO
import qualified Control.Monad.Oops                   as OO
import qualified Data.ByteString.Lazy                 as LBS
import qualified Data.List.NonEmpty                   as NEL
import qualified Data.Text                            as T
import qualified HaskellWorks.CabalCache.AWS.S3       as S3
import qualified HaskellWorks.CabalCache.IO.Console   as CIO
import qualified HaskellWorks.CabalCache.URI          as URI
import qualified Network.HTTP.Client                  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"   -}

handleHttpError :: ()
  => MonadError (OO.Variant e) m
  => MonadCatch m
  => e `OO.CouldBe` HttpError
  => e `OO.CouldBe` InvalidUrl
  => MonadIO m
  => Monad m
  => m a
  -> m a
handleHttpError :: forall (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, MonadCatch m, CouldBe e HttpError,
 CouldBe e InvalidUrl, MonadIO m, Monad m) =>
m a -> m a
handleHttpError m a
f = m a -> (HttpException -> m a) -> m a
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch m a
f ((HttpException -> m a) -> m a) -> (HttpException -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \(HttpException
e :: HTTP.HttpException) ->
  case HttpException
e of
    HTTP.HttpExceptionRequest Request
request HttpExceptionContent
content' -> HttpError -> m a
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw (HttpError -> m a) -> HttpError -> m a
forall a b. (a -> b) -> a -> b
$ Request -> HttpExceptionContent -> HttpError
HttpError Request
request HttpExceptionContent
content'
    HTTP.InvalidUrlException String
url' String
reason' -> InvalidUrl -> m a
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw (InvalidUrl -> m a) -> InvalidUrl -> m a
forall a b. (a -> b) -> a -> b
$ Text -> Text -> InvalidUrl
InvalidUrl (String -> Text
forall a. Show a => a -> Text
tshow String
url') (String -> Text
forall a. Show a => a -> Text
tshow String
reason')

readResource :: ()
  => MonadResource m
  => MonadCatch m
  => e `OO.CouldBe` AwsError
  => e `OO.CouldBe` UnsupportedUri
  => e `OO.CouldBe` HttpError
  => e `OO.CouldBe` InvalidUrl
  => e `OO.CouldBe` NotFound
  => AWS.Env
  -> Int
  -> Location
  -> ExceptT (OO.Variant e) m LBS.ByteString
readResource :: forall (m :: * -> *) (e :: [*]).
(MonadResource m, MonadCatch m, CouldBe e AwsError,
 CouldBe e UnsupportedUri, CouldBe e HttpError,
 CouldBe e InvalidUrl, CouldBe e NotFound) =>
Env -> Int -> Location -> ExceptT (Variant e) m ByteString
readResource Env
envAws Int
maxRetries = \case
  Local String
path -> do
    Bool
fileExists <- IO Bool -> ExceptT (Variant e) m Bool
forall a. IO a -> ExceptT (Variant e) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT (Variant e) m Bool)
-> IO Bool -> ExceptT (Variant e) m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
IO.doesFileExist String
path
    if Bool
fileExists
      then IO ByteString -> ExceptT (Variant e) m ByteString
forall a. IO a -> ExceptT (Variant e) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT (Variant e) m ByteString)
-> IO ByteString -> ExceptT (Variant e) m ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
LBS.readFile String
path
      else NotFound -> ExceptT (Variant e) m ByteString
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw NotFound
NotFound
  Uri URI
uri -> Int
-> ExceptT (Variant e) m ByteString
-> ExceptT (Variant e) m ByteString
forall (m :: * -> *) (e :: [*]) a.
(MonadIO m, CouldBe e AwsError) =>
Int -> ExceptT (Variant e) m a -> ExceptT (Variant e) m a
retryS3 Int
maxRetries (ExceptT (Variant e) m ByteString
 -> ExceptT (Variant e) m ByteString)
-> ExceptT (Variant e) m ByteString
-> ExceptT (Variant e) m ByteString
forall a b. (a -> b) -> a -> b
$ 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 (sel :: Symbol) s t a b. HasAny sel s t a b => Lens s t a b
the @"uriScheme" of
    String
"s3:"     -> Env -> URI -> ExceptT (Variant e) m ByteString
forall (e :: [*]) (m :: * -> *).
(MonadError (Variant e) m, CouldBe e AwsError,
 CouldBe e UnsupportedUri, MonadCatch m, MonadResource m) =>
Env -> URI -> m ByteString
S3.getS3Uri Env
envAws (URI -> URI
URI.reslashUri URI
uri)
    String
"http:"   -> URI -> ExceptT (Variant e) m ByteString
forall (e :: [*]) (m :: * -> *).
(MonadError (Variant e) m, MonadCatch m, CouldBe e HttpError,
 CouldBe e InvalidUrl, MonadIO m) =>
URI -> m ByteString
readHttpUri (URI -> URI
URI.reslashUri URI
uri)
    String
"https:"  -> URI -> ExceptT (Variant e) m ByteString
forall (e :: [*]) (m :: * -> *).
(MonadError (Variant e) m, MonadCatch m, CouldBe e HttpError,
 CouldBe e InvalidUrl, MonadIO m) =>
URI -> m ByteString
readHttpUri (URI -> URI
URI.reslashUri URI
uri)
    String
scheme    -> UnsupportedUri -> ExceptT (Variant e) m ByteString
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw (UnsupportedUri -> ExceptT (Variant e) m ByteString)
-> UnsupportedUri -> ExceptT (Variant e) m ByteString
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
"Unrecognised uri scheme: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
scheme

readFirstAvailableResource :: ()
  => MonadResource m
  => MonadCatch m
  => e `OO.CouldBe` AwsError
  => e `OO.CouldBe` HttpError
  => e `OO.CouldBe` InvalidUrl
  => e `OO.CouldBe` NotFound
  => e `OO.CouldBe` UnsupportedUri
  => AWS.Env
  -> NonEmpty Location
  -> Int
  -> ExceptT (OO.Variant e) m (LBS.ByteString, Location)
readFirstAvailableResource :: forall (m :: * -> *) (e :: [*]).
(MonadResource m, MonadCatch m, CouldBe e AwsError,
 CouldBe e HttpError, CouldBe e InvalidUrl, CouldBe e NotFound,
 CouldBe e UnsupportedUri) =>
Env
-> NonEmpty Location
-> Int
-> ExceptT (Variant e) m (ByteString, Location)
readFirstAvailableResource Env
envAws (Location
a:|[Location]
as) Int
maxRetries = do
  (, Location
a) (ByteString -> (ByteString, Location))
-> ExceptT
     (Variant (NotFound : AwsError : HttpError : e)) m ByteString
-> ExceptT
     (Variant (NotFound : AwsError : HttpError : e))
     m
     (ByteString, Location)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env
-> Int
-> Location
-> ExceptT
     (Variant (NotFound : AwsError : HttpError : e)) m ByteString
forall (m :: * -> *) (e :: [*]).
(MonadResource m, MonadCatch m, CouldBe e AwsError,
 CouldBe e UnsupportedUri, CouldBe e HttpError,
 CouldBe e InvalidUrl, CouldBe e NotFound) =>
Env -> Int -> Location -> ExceptT (Variant e) m ByteString
readResource Env
envAws Int
maxRetries Location
a
    ExceptT
  (Variant (NotFound : AwsError : HttpError : e))
  m
  (ByteString, Location)
-> (ExceptT
      (Variant (NotFound : AwsError : HttpError : e))
      m
      (ByteString, Location)
    -> ExceptT
         (VariantF Identity (AwsError : HttpError : e))
         m
         (ByteString, Location))
-> ExceptT
     (VariantF Identity (AwsError : HttpError : e))
     m
     (ByteString, Location)
forall a b. a -> (a -> b) -> b
& do forall x (e :: [*]) (e' :: [*]) (m :: * -> *) a.
(Monad m, Catch x e e') =>
(x -> ExceptT (Variant e') m a)
-> ExceptT (Variant e) m a -> ExceptT (Variant e') m a
OO.catch @NotFound \NotFound
e -> do
          case [Location] -> Maybe (NonEmpty Location)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [Location]
as of
            Maybe (NonEmpty Location)
Nothing -> Identity NotFound
-> ExceptT
     (VariantF Identity (AwsError : HttpError : e))
     m
     (ByteString, Location)
forall x (e :: [*]) (f :: * -> *) (m :: * -> *) a.
(MonadError (VariantF f e) m, CouldBe e x) =>
f x -> m a
OO.throwF (NotFound -> Identity NotFound
forall a. a -> Identity a
Identity NotFound
e)
            Just NonEmpty Location
nas -> Env
-> NonEmpty Location
-> Int
-> ExceptT
     (VariantF Identity (AwsError : HttpError : e))
     m
     (ByteString, Location)
forall (m :: * -> *) (e :: [*]).
(MonadResource m, MonadCatch m, CouldBe e AwsError,
 CouldBe e HttpError, CouldBe e InvalidUrl, CouldBe e NotFound,
 CouldBe e UnsupportedUri) =>
Env
-> NonEmpty Location
-> Int
-> ExceptT (Variant e) m (ByteString, Location)
readFirstAvailableResource Env
envAws NonEmpty Location
nas Int
maxRetries
    ExceptT
  (VariantF Identity (AwsError : HttpError : e))
  m
  (ByteString, Location)
-> (ExceptT
      (VariantF Identity (AwsError : HttpError : e))
      m
      (ByteString, Location)
    -> ExceptT
         (VariantF Identity (HttpError : e)) m (ByteString, Location))
-> ExceptT
     (VariantF Identity (HttpError : e)) m (ByteString, Location)
forall a b. a -> (a -> b) -> b
& do forall x (e :: [*]) (e' :: [*]) (m :: * -> *) a.
(Monad m, Catch x e e') =>
(x -> ExceptT (Variant e') m a)
-> ExceptT (Variant e) m a -> ExceptT (Variant e') m a
OO.catch @AwsError \AwsError
e -> do
          case [Location] -> Maybe (NonEmpty Location)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [Location]
as of
            Maybe (NonEmpty Location)
Nothing -> Identity AwsError
-> ExceptT
     (VariantF Identity (HttpError : e)) m (ByteString, Location)
forall x (e :: [*]) (f :: * -> *) (m :: * -> *) a.
(MonadError (VariantF f e) m, CouldBe e x) =>
f x -> m a
OO.throwF (AwsError -> Identity AwsError
forall a. a -> Identity a
Identity AwsError
e)
            Just NonEmpty Location
nas -> Env
-> NonEmpty Location
-> Int
-> ExceptT
     (VariantF Identity (HttpError : e)) m (ByteString, Location)
forall (m :: * -> *) (e :: [*]).
(MonadResource m, MonadCatch m, CouldBe e AwsError,
 CouldBe e HttpError, CouldBe e InvalidUrl, CouldBe e NotFound,
 CouldBe e UnsupportedUri) =>
Env
-> NonEmpty Location
-> Int
-> ExceptT (Variant e) m (ByteString, Location)
readFirstAvailableResource Env
envAws NonEmpty Location
nas Int
maxRetries
    ExceptT
  (VariantF Identity (HttpError : e)) m (ByteString, Location)
-> (ExceptT
      (VariantF Identity (HttpError : e)) m (ByteString, Location)
    -> ExceptT (VariantF Identity e) m (ByteString, Location))
-> ExceptT (VariantF Identity e) m (ByteString, Location)
forall a b. a -> (a -> b) -> b
& do forall x (e :: [*]) (e' :: [*]) (m :: * -> *) a.
(Monad m, Catch x e e') =>
(x -> ExceptT (Variant e') m a)
-> ExceptT (Variant e) m a -> ExceptT (Variant e') m a
OO.catch @HttpError \HttpError
e -> do
          case [Location] -> Maybe (NonEmpty Location)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [Location]
as of
            Maybe (NonEmpty Location)
Nothing -> Identity HttpError
-> ExceptT (VariantF Identity e) m (ByteString, Location)
forall x (e :: [*]) (f :: * -> *) (m :: * -> *) a.
(MonadError (VariantF f e) m, CouldBe e x) =>
f x -> m a
OO.throwF (HttpError -> Identity HttpError
forall a. a -> Identity a
Identity HttpError
e)
            Just NonEmpty Location
nas -> Env
-> NonEmpty Location
-> Int
-> ExceptT (VariantF Identity e) m (ByteString, Location)
forall (m :: * -> *) (e :: [*]).
(MonadResource m, MonadCatch m, CouldBe e AwsError,
 CouldBe e HttpError, CouldBe e InvalidUrl, CouldBe e NotFound,
 CouldBe e UnsupportedUri) =>
Env
-> NonEmpty Location
-> Int
-> ExceptT (Variant e) m (ByteString, Location)
readFirstAvailableResource Env
envAws NonEmpty Location
nas Int
maxRetries

safePathIsSymbolLink :: FilePath -> IO Bool
safePathIsSymbolLink :: String -> IO Bool
safePathIsSymbolLink String
filePath = IO Bool -> (IOError -> IO Bool) -> IO Bool
forall e a.
(HasCallStack, Exception e) =>
IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          else Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

resourceExists :: ()
  => MonadUnliftIO m
  => MonadCatch m
  => e `OO.CouldBe` InvalidUrl
  => e `OO.CouldBe` UnsupportedUri
  => AWS.Env
  -> Location
  -> ExceptT (OO.Variant e) m Bool
resourceExists :: forall (m :: * -> *) (e :: [*]).
(MonadUnliftIO m, MonadCatch m, CouldBe e InvalidUrl,
 CouldBe e UnsupportedUri) =>
Env -> Location -> ExceptT (Variant e) m Bool
resourceExists Env
envAws = \case
  Local String
path -> do
    Bool
fileExists <- IO Bool -> ExceptT (Variant e) m Bool
forall a. IO a -> ExceptT (Variant e) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT (Variant e) m Bool)
-> IO Bool -> ExceptT (Variant e) m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
IO.doesFileExist String
path
    if Bool
fileExists
      then Bool -> ExceptT (Variant e) m Bool
forall a. a -> ExceptT (Variant e) m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      else do
        Bool
symbolicLinkExists <- IO Bool -> ExceptT (Variant e) m Bool
forall a. IO a -> ExceptT (Variant e) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT (Variant e) m Bool)
-> IO Bool -> ExceptT (Variant e) m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
safePathIsSymbolLink String
path
        if Bool
symbolicLinkExists
          then do
            String
target <- IO String -> ExceptT (Variant e) m String
forall a. IO a -> ExceptT (Variant e) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT (Variant e) m String)
-> IO String -> ExceptT (Variant e) m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
IO.getSymbolicLinkTarget String
path
            Env -> Location -> ExceptT (Variant e) m Bool
forall (m :: * -> *) (e :: [*]).
(MonadUnliftIO m, MonadCatch m, CouldBe e InvalidUrl,
 CouldBe e UnsupportedUri) =>
Env -> Location -> ExceptT (Variant e) m Bool
resourceExists Env
envAws (String -> Location
Local String
target)
          else Bool -> ExceptT (Variant e) m Bool
forall a. a -> ExceptT (Variant e) m a
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 (sel :: Symbol) s t a b. HasAny sel s t a b => Lens s t a b
the @"uriScheme" of
    String
"s3:" -> do
      (ResourceT m (Either (Variant e) Bool)
 -> m (Either (Variant e) Bool))
-> ExceptT (Variant e) (ResourceT m) Bool
-> ExceptT (Variant e) m Bool
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) Bool)
-> m (Either (Variant e) Bool)
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ExceptT (Variant e) (ResourceT m) Bool
 -> ExceptT (Variant e) m Bool)
-> ExceptT (Variant e) (ResourceT m) Bool
-> ExceptT (Variant e) m Bool
forall a b. (a -> b) -> a -> b
$ (Bool
True Bool
-> ExceptT
     (Variant (AwsError : HttpError : e))
     (ResourceT m)
     HeadObjectResponse
-> ExceptT (Variant (AwsError : HttpError : e)) (ResourceT m) Bool
forall a b.
a
-> ExceptT (Variant (AwsError : HttpError : e)) (ResourceT m) b
-> ExceptT (Variant (AwsError : HttpError : e)) (ResourceT m) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Env
-> URI
-> ExceptT
     (Variant (AwsError : HttpError : e))
     (ResourceT m)
     HeadObjectResponse
forall (e :: [*]) (m :: * -> *).
(MonadError (Variant e) m, CouldBe e AwsError,
 CouldBe e UnsupportedUri, MonadCatch m, MonadResource m) =>
Env -> URI -> m HeadObjectResponse
S3.headS3Uri Env
envAws (URI -> URI
URI.reslashUri URI
uri))
        ExceptT (Variant (AwsError : HttpError : e)) (ResourceT m) Bool
-> (ExceptT (Variant (AwsError : HttpError : e)) (ResourceT m) Bool
    -> ExceptT (Variant (HttpError : e)) (ResourceT m) Bool)
-> ExceptT (Variant (HttpError : e)) (ResourceT m) Bool
forall a b. a -> (a -> b) -> b
& forall x (e :: [*]) (e' :: [*]) (m :: * -> *) a.
(Monad m, Catch x e e') =>
(x -> ExceptT (Variant e') m a)
-> ExceptT (Variant e) m a -> ExceptT (Variant e') m a
OO.catch @AwsError (Bool -> ExceptT (Variant (HttpError : e)) (ResourceT m) Bool
forall a. a -> ExceptT (Variant (HttpError : e)) (ResourceT m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ExceptT (Variant (HttpError : e)) (ResourceT m) Bool)
-> (AwsError -> Bool)
-> AwsError
-> ExceptT (Variant (HttpError : e)) (ResourceT m) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> AwsError -> Bool
forall a b. a -> b -> a
const Bool
False)
        ExceptT (Variant (HttpError : e)) (ResourceT m) Bool
-> (ExceptT (Variant (HttpError : e)) (ResourceT m) Bool
    -> ExceptT (Variant e) (ResourceT m) Bool)
-> ExceptT (Variant e) (ResourceT m) Bool
forall a b. a -> (a -> b) -> b
& forall x (e :: [*]) (e' :: [*]) (m :: * -> *) a.
(Monad m, Catch x e e') =>
(x -> ExceptT (Variant e') m a)
-> ExceptT (Variant e) m a -> ExceptT (Variant e') m a
OO.catch @HttpError (Bool -> ExceptT (Variant e) (ResourceT m) Bool
forall a. a -> ExceptT (Variant e) (ResourceT m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ExceptT (Variant e) (ResourceT m) Bool)
-> (HttpError -> Bool)
-> HttpError
-> ExceptT (Variant e) (ResourceT m) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> HttpError -> Bool
forall a b. a -> b -> a
const Bool
False)
    String
"http:" -> do
      (Bool
True Bool
-> ExceptT (Variant (AwsError : HttpError : e)) m ByteString
-> ExceptT (Variant (AwsError : HttpError : e)) m Bool
forall a b.
a
-> ExceptT (Variant (AwsError : HttpError : e)) m b
-> ExceptT (Variant (AwsError : HttpError : e)) m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ URI -> ExceptT (Variant (AwsError : HttpError : e)) m ByteString
forall (e :: [*]) (m :: * -> *).
(MonadError (Variant e) m, MonadCatch m, CouldBe e HttpError,
 CouldBe e InvalidUrl, MonadIO m) =>
URI -> m ByteString
headHttpUri (URI -> URI
URI.reslashUri URI
uri))
        ExceptT (Variant (AwsError : HttpError : e)) m Bool
-> (ExceptT (Variant (AwsError : HttpError : e)) m Bool
    -> ExceptT (Variant (HttpError : e)) m Bool)
-> ExceptT (Variant (HttpError : e)) m Bool
forall a b. a -> (a -> b) -> b
& forall x (e :: [*]) (e' :: [*]) (m :: * -> *) a.
(Monad m, Catch x e e') =>
(x -> ExceptT (Variant e') m a)
-> ExceptT (Variant e) m a -> ExceptT (Variant e') m a
OO.catch @AwsError (Bool -> ExceptT (Variant (HttpError : e)) m Bool
forall a. a -> ExceptT (Variant (HttpError : e)) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ExceptT (Variant (HttpError : e)) m Bool)
-> (AwsError -> Bool)
-> AwsError
-> ExceptT (Variant (HttpError : e)) m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> AwsError -> Bool
forall a b. a -> b -> a
const Bool
False)
        ExceptT (Variant (HttpError : e)) m Bool
-> (ExceptT (Variant (HttpError : e)) m Bool
    -> ExceptT (Variant e) m Bool)
-> ExceptT (Variant e) m Bool
forall a b. a -> (a -> b) -> b
& forall x (e :: [*]) (e' :: [*]) (m :: * -> *) a.
(Monad m, Catch x e e') =>
(x -> ExceptT (Variant e') m a)
-> ExceptT (Variant e) m a -> ExceptT (Variant e') m a
OO.catch @HttpError (Bool -> ExceptT (Variant e) m Bool
forall a. a -> ExceptT (Variant e) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ExceptT (Variant e) m Bool)
-> (HttpError -> Bool) -> HttpError -> ExceptT (Variant e) m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> HttpError -> Bool
forall a b. a -> b -> a
const Bool
False)
    String
_scheme -> Bool -> ExceptT (Variant e) m Bool
forall a. a -> ExceptT (Variant e) m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

writeResource :: ()
  => e `OO.CouldBe` AwsError
  => e `OO.CouldBe` HttpError
  => e `OO.CouldBe` NotImplemented
  => e `OO.CouldBe` UnsupportedUri
  => MonadIO m
  => MonadCatch m
  => MonadUnliftIO m
  => AWS.Env
  -> Location
  -> Int
  -> LBS.ByteString
  -> ExceptT (OO.Variant e) m ()
writeResource :: forall (e :: [*]) (m :: * -> *).
(CouldBe e AwsError, CouldBe e HttpError, CouldBe e NotImplemented,
 CouldBe e UnsupportedUri, MonadIO m, MonadCatch m,
 MonadUnliftIO m) =>
Env -> Location -> Int -> ByteString -> ExceptT (Variant e) m ()
writeResource Env
envAws Location
loc Int
maxRetries ByteString
lbs = case Location
loc of
  Local String
path -> IO () -> ExceptT (Variant e) m ()
forall a. IO a -> ExceptT (Variant e) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> ByteString -> IO ()
LBS.writeFile String
path ByteString
lbs) ExceptT (Variant e) m ()
-> ExceptT (Variant e) m () -> ExceptT (Variant e) m ()
forall a b.
ExceptT (Variant e) m a
-> ExceptT (Variant e) m b -> ExceptT (Variant e) m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ExceptT (Variant e) m ()
forall a. a -> ExceptT (Variant e) m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Uri URI
uri' -> Int -> ExceptT (Variant e) m () -> ExceptT (Variant e) m ()
forall (m :: * -> *) (e :: [*]) a.
(MonadIO m, CouldBe e AwsError) =>
Int -> ExceptT (Variant e) m a -> ExceptT (Variant e) m a
retryS3 Int
maxRetries (ExceptT (Variant e) m () -> ExceptT (Variant e) m ())
-> ExceptT (Variant e) m () -> ExceptT (Variant e) m ()
forall a b. (a -> b) -> a -> b
$ 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 (sel :: Symbol) s t a b. HasAny sel s t a b => Lens s t a b
the @"uriScheme" of
    String
"s3:"   -> Env -> URI -> ByteString -> ExceptT (Variant e) m ()
forall (e :: [*]) (m :: * -> *) a.
(CouldBe e AwsError, CouldBe e UnsupportedUri, MonadCatch m,
 MonadUnliftIO m, ToBody a) =>
Env -> URI -> a -> ExceptT (Variant e) m ()
S3.putObject Env
envAws (URI -> URI
URI.reslashUri URI
uri') ByteString
lbs
    String
"http:" -> NotImplemented -> ExceptT (Variant e) m ()
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw (NotImplemented -> ExceptT (Variant e) m ())
-> NotImplemented -> ExceptT (Variant e) m ()
forall a b. (a -> b) -> a -> b
$ Text -> NotImplemented
NotImplemented Text
"HTTP PUT method not supported"
    String
scheme  -> UnsupportedUri -> ExceptT (Variant e) m ()
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw (UnsupportedUri -> ExceptT (Variant e) m ())
-> UnsupportedUri -> ExceptT (Variant e) m ()
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
"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 :: forall (m :: * -> *). (MonadCatch m, MonadIO m) => Location -> m ()
createLocalDirectoryIfMissing = \case
  Local String
path -> IO () -> m ()
forall a. IO a -> m a
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 (sel :: Symbol) s t a b. HasAny sel s t a b => Lens s t a b
the @"uriScheme" of
    String
"s3:"   -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    String
"http:" -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    String
_scheme -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

retryOnE :: forall e e' m a. ()
  => Monad m
  => Int
  -> ExceptT (OO.Variant e') m a
  -> ExceptT (OO.Variant (e : e')) m a
  -> ExceptT (OO.Variant e') m a
retryOnE :: forall e (e' :: [*]) (m :: * -> *) a.
Monad m =>
Int
-> ExceptT (Variant e') m a
-> ExceptT (Variant (e : e')) m a
-> ExceptT (Variant e') m a
retryOnE Int
n ExceptT (Variant e') m a
g ExceptT (Variant (e : e')) m a
f = ExceptT (Variant (e : e')) m a
f
  ExceptT (Variant (e : e')) m a
-> (ExceptT (Variant (e : e')) m a -> ExceptT (Variant e') m a)
-> ExceptT (Variant e') m a
forall a b. a -> (a -> b) -> b
& do forall x (e :: [*]) (e' :: [*]) (m :: * -> *) a.
(Monad m, Catch x e e') =>
(x -> ExceptT (Variant e') m a)
-> ExceptT (Variant e) m a -> ExceptT (Variant e') m a
OO.catch @e \e
_ -> if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        then Int
-> ExceptT (Variant e') m a
-> ExceptT (Variant (e : e')) m a
-> ExceptT (Variant e') m a
forall e (e' :: [*]) (m :: * -> *) a.
Monad m =>
Int
-> ExceptT (Variant e') m a
-> ExceptT (Variant (e : e')) m a
-> ExceptT (Variant e') m a
retryOnE (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ExceptT (Variant e') m a
g ExceptT (Variant (e : e')) m a
f
        else ExceptT (Variant e') m a
g

retryWhen :: ()
  => MonadIO m
  => Show x
  => e `OO.CouldBe` x
  => (x -> Bool)
  -> Int
  -> ExceptT (OO.Variant e) m a
  -> ExceptT (OO.Variant e) m a
retryWhen :: forall (m :: * -> *) x (e :: [*]) a.
(MonadIO m, Show x, CouldBe e x) =>
(x -> Bool)
-> Int -> ExceptT (Variant e) m a -> ExceptT (Variant e) m a
retryWhen x -> Bool
p Int
n ExceptT (Variant e) m a
f = ExceptT (Variant e) m a
f
  ExceptT (Variant e) m a
-> (ExceptT (Variant e) m a -> ExceptT (Variant e) m a)
-> ExceptT (Variant e) m a
forall a b. a -> (a -> b) -> b
& do (x -> ExceptT (Variant e) m a)
-> ExceptT (Variant e) m a -> ExceptT (Variant e) m a
forall x (e :: [*]) (m :: * -> *) a.
(Monad m, CouldBe e x) =>
(x -> ExceptT (Variant e) m a)
-> ExceptT (Variant e) m a -> ExceptT (Variant e) m a
OO.snatch \x
exception -> do
        if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
          then do
            if x -> Bool
p x
exception
              then 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
"WARNING: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> x -> Text
forall a. Show a => a -> Text
tshow x
exception Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (retrying)"
                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
$ Int -> IO ()
IO.threadDelay Int
1000000
                (x -> Bool)
-> Int -> ExceptT (Variant e) m a -> ExceptT (Variant e) m a
forall (m :: * -> *) x (e :: [*]) a.
(MonadIO m, Show x, CouldBe e x) =>
(x -> Bool)
-> Int -> ExceptT (Variant e) m a -> ExceptT (Variant e) m a
retryWhen x -> Bool
p (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ExceptT (Variant e) m a
f
              else x -> ExceptT (Variant e) m a
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw x
exception
          else x -> ExceptT (Variant e) m a
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw x
exception

retryUnless :: forall x e m a. ()
  => MonadIO m
  => Show x
  => e `OO.CouldBe` x
  => (x -> Bool)
  -> Int
  -> ExceptT (OO.Variant e) m a
  -> ExceptT (OO.Variant e) m a
retryUnless :: forall x (e :: [*]) (m :: * -> *) a.
(MonadIO m, Show x, CouldBe e x) =>
(x -> Bool)
-> Int -> ExceptT (Variant e) m a -> ExceptT (Variant e) m a
retryUnless x -> Bool
p = (x -> Bool)
-> Int -> ExceptT (Variant e) m a -> ExceptT (Variant e) m a
forall (m :: * -> *) x (e :: [*]) a.
(MonadIO m, Show x, CouldBe e x) =>
(x -> Bool)
-> Int -> ExceptT (Variant e) m a -> ExceptT (Variant e) m a
retryWhen (Bool -> Bool
not (Bool -> Bool) -> (x -> Bool) -> x -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> Bool
p)

retryS3 :: ()
  => MonadIO m
  => e `OO.CouldBe` AwsError
  => Int
  -> ExceptT (OO.Variant e) m a
  -> ExceptT (OO.Variant e) m a
retryS3 :: forall (m :: * -> *) (e :: [*]) a.
(MonadIO m, CouldBe e AwsError) =>
Int -> ExceptT (Variant e) m a -> ExceptT (Variant e) m a
retryS3 Int
maxRetries ExceptT (Variant e) m a
a = do
  (AwsError -> Bool)
-> Int -> ExceptT (Variant e) m a -> ExceptT (Variant e) m a
forall (m :: * -> *) x (e :: [*]) a.
(MonadIO m, Show x, CouldBe e x) =>
(x -> Bool)
-> Int -> ExceptT (Variant e) m a -> ExceptT (Variant e) m a
retryWhen AwsError -> Bool
retryPredicate Int
maxRetries ExceptT (Variant e) m a
a
  where retryPredicate :: AwsError -> Bool
        retryPredicate :: AwsError -> Bool
retryPredicate AwsError
e = AwsError -> Int
forall a. HasStatusCode a => a -> Int
statusCodeOf AwsError
e Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
retryableHTTPStatuses

  -- https://docs.aws.amazon.com/AmazonS3/latest/API/ErrorResponses.html#ErrorCodeList
  -- https://stackoverflow.com/a/51770411/2976251
  -- another note: linode rate limiting returns 503
retryableHTTPStatuses :: [Int]
retryableHTTPStatuses :: [Int]
retryableHTTPStatuses = [Int
408, Int
409, Int
425, Int
426, Int
502, Int
503, Int
504]

linkOrCopyResource :: ()
  => MonadUnliftIO m
  => e `OO.CouldBe` AwsError
  => e `OO.CouldBe` CopyFailed
  => e `OO.CouldBe` NotImplemented
  => e `OO.CouldBe` UnsupportedUri
  => AWS.Env
  -> Location
  -> Location
  -> ExceptT (OO.Variant e) m ()
linkOrCopyResource :: forall (m :: * -> *) (e :: [*]).
(MonadUnliftIO m, CouldBe e AwsError, CouldBe e CopyFailed,
 CouldBe e NotImplemented, CouldBe e UnsupportedUri) =>
Env -> Location -> Location -> ExceptT (Variant e) 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 (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
$ Bool -> String -> IO ()
IO.createDirectoryIfMissing Bool
True (String -> String
FP.takeDirectory String
targetPath)
      Bool
targetPathExists <- IO Bool -> ExceptT (Variant e) m Bool
forall a. IO a -> ExceptT (Variant e) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT (Variant e) m Bool)
-> IO Bool -> ExceptT (Variant e) m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
IO.doesFileExist String
targetPath
      Bool -> ExceptT (Variant e) m () -> ExceptT (Variant e) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
targetPathExists (ExceptT (Variant e) m () -> ExceptT (Variant e) m ())
-> ExceptT (Variant e) m () -> ExceptT (Variant e) m ()
forall a b. (a -> b) -> a -> b
$ 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
$ String -> String -> IO ()
IO.createFileLink String
sourcePath String
targetPath
    Uri URI
_ -> NotImplemented -> ExceptT (Variant e) m ()
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw (NotImplemented -> ExceptT (Variant e) m ())
-> NotImplemented -> ExceptT (Variant e) m ()
forall a b. (a -> b) -> a -> b
$ Text -> NotImplemented
NotImplemented Text
"Can't copy between different file backends"
  Uri URI
sourceUri -> case Location
target of
    Local String
_targetPath -> NotImplemented -> ExceptT (Variant e) m ()
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw (NotImplemented -> ExceptT (Variant e) m ())
-> NotImplemented -> ExceptT (Variant e) m ()
forall a b. (a -> b) -> a -> b
$ Text -> NotImplemented
NotImplemented Text
"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 (sel :: Symbol) s t a b. HasAny sel 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 (sel :: Symbol) s t a b. HasAny sel s t a b => Lens s t a b
the @"uriScheme") of
      (String
"s3:", String
"s3:")               -> forall x (e :: [*]) (m :: * -> *) a.
(MonadIO m, Show x, CouldBe e x) =>
(x -> Bool)
-> Int -> ExceptT (Variant e) m a -> ExceptT (Variant e) m a
retryUnless @AwsError ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
301) (Int -> Bool) -> (AwsError -> Int) -> AwsError -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AwsError -> Int
forall a. HasStatusCode a => a -> Int
statusCodeOf) Int
3 (Env -> URI -> URI -> ExceptT (Variant e) m ()
forall (m :: * -> *) (e :: [*]).
(MonadUnliftIO m, CouldBe e AwsError, CouldBe e CopyFailed,
 CouldBe e UnsupportedUri) =>
Env -> URI -> URI -> ExceptT (Variant e) m ()
S3.copyS3Uri Env
envAws (URI -> URI
URI.reslashUri URI
sourceUri) (URI -> URI
URI.reslashUri URI
targetUri))
      (String
"http:", String
"http:")           -> NotImplemented -> ExceptT (Variant e) m ()
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw (NotImplemented -> ExceptT (Variant e) m ())
-> NotImplemented -> ExceptT (Variant e) m ()
forall a b. (a -> b) -> a -> b
$ Text -> NotImplemented
NotImplemented Text
"Link and copy unsupported for http backend"
      (String
sourceScheme, String
targetScheme) -> NotImplemented -> ExceptT (Variant e) m ()
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw (NotImplemented -> ExceptT (Variant e) m ())
-> NotImplemented -> ExceptT (Variant e) m ()
forall a b. (a -> b) -> a -> b
$ Text -> NotImplemented
NotImplemented (Text -> NotImplemented) -> Text -> NotImplemented
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 :: ()
  => MonadError (OO.Variant e) m
  => MonadCatch m
  => e `OO.CouldBe` HttpError
  => e `OO.CouldBe` InvalidUrl
  => MonadIO m
  => URI
  -> m LBS.ByteString
readHttpUri :: forall (e :: [*]) (m :: * -> *).
(MonadError (Variant e) m, MonadCatch m, CouldBe e HttpError,
 CouldBe e InvalidUrl, MonadIO m) =>
URI -> m ByteString
readHttpUri URI
httpUri = m ByteString -> m ByteString
forall (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, MonadCatch m, CouldBe e HttpError,
 CouldBe e InvalidUrl, MonadIO m, Monad m) =>
m a -> m a
handleHttpError do
  Manager
manager <- IO Manager -> m Manager
forall a. IO a -> m a
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 a. IO a -> m a
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
URI.reslashUri URI
httpUri)))
  Response ByteString
response <- IO (Response ByteString) -> m (Response ByteString)
forall a. IO a -> m a
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 a. a -> m a
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 :: ()
  => MonadError (OO.Variant e) m
  => MonadCatch m
  => e `OO.CouldBe` HttpError
  => e `OO.CouldBe` InvalidUrl
  => MonadIO m
  => URI
  -> m LBS.ByteString
headHttpUri :: forall (e :: [*]) (m :: * -> *).
(MonadError (Variant e) m, MonadCatch m, CouldBe e HttpError,
 CouldBe e InvalidUrl, MonadIO m) =>
URI -> m ByteString
headHttpUri URI
httpUri = m ByteString -> m ByteString
forall (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, MonadCatch m, CouldBe e HttpError,
 CouldBe e InvalidUrl, MonadIO m, Monad m) =>
m a -> m a
handleHttpError do
  Manager
manager <- IO Manager -> m Manager
forall a. IO a -> m a
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 a. IO a -> m a
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
URI.reslashUri URI
httpUri)))
  Response ByteString
response <- IO (Response ByteString) -> m (Response ByteString)
forall a. IO a -> m a
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 a. a -> m a
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 :: ()
  => MonadCatch m
  => MonadIO m
  => [Char]
  -> ExceptT (OO.Variant e) m ()
removePathRecursive :: forall (m :: * -> *) (e :: [*]).
(MonadCatch m, MonadIO m) =>
String -> ExceptT (Variant e) m ()
removePathRecursive String
pkgStorePath = IO () -> ExceptT (Variant e) m ()
forall a. IO a -> ExceptT (Variant e) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
IO.removeDirectoryRecursive String
pkgStorePath)