Merge branch 'issue-193'
This commit is contained in:
commit
07604a2eb5
GPG Key ID:
3786C5262ECB4A3F
@ -12,6 +12,10 @@ ecabal() {
|
||||
cabal "$@"
|
||||
}
|
||||
|
||||
raw_eghcup() {
|
||||
ghcup -v -c "$@"
|
||||
}
|
||||
|
||||
eghcup() {
|
||||
if [ "${OS}" = "WINDOWS" ] ; then
|
||||
ghcup -v -c -s file:/$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
|
||||
@ -20,6 +24,12 @@ eghcup() {
|
||||
fi
|
||||
}
|
||||
|
||||
if [ "${OS}" = "WINDOWS" ] ; then
|
||||
GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/ghcup
|
||||
else
|
||||
GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
|
||||
fi
|
||||
|
||||
git describe --always
|
||||
|
||||
### build
|
||||
@ -65,11 +75,7 @@ fi
|
||||
|
||||
### cleanup
|
||||
|
||||
if [ "${OS}" = "WINDOWS" ] ; then
|
||||
rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/ghcup
|
||||
else
|
||||
rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
|
||||
fi
|
||||
rm -rf "${GHCUP_DIR}"
|
||||
|
||||
### manual cli based testing
|
||||
|
||||
@ -88,6 +94,7 @@ cabal --version
|
||||
|
||||
eghcup debug-info
|
||||
|
||||
# also test etags
|
||||
eghcup list
|
||||
eghcup list -t ghc
|
||||
eghcup list -t cabal
|
||||
@ -155,6 +162,40 @@ if [ "${OS}" = "LINUX" ] ; then
|
||||
fi
|
||||
fi
|
||||
|
||||
sha_sum() {
|
||||
if [ "${OS}" = "FREEBSD" ] ; then
|
||||
sha256 "$@"
|
||||
else
|
||||
sha256sum "$@"
|
||||
fi
|
||||
|
||||
}
|
||||
|
||||
# test etags
|
||||
rm -f "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml"
|
||||
raw_eghcup -s https://www.haskell.org/ghcup/data/ghcup-${JSON_VERSION}.yaml list
|
||||
# snapshot yaml and etags file
|
||||
etag=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags")
|
||||
sha=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
|
||||
# invalidate access time timer, which is 5minutes, so we re-download
|
||||
touch -a -m -t '199901010101' "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml"
|
||||
# redownload same file with some newlines added
|
||||
raw_eghcup -s https://www.haskell.org/ghcup/exp/ghcup-${JSON_VERSION}.yaml list
|
||||
# snapshot new yaml and etags file
|
||||
etag2=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags")
|
||||
sha2=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
|
||||
# compare
|
||||
[ "${etag}" != "${etag2}" ]
|
||||
[ "${sha}" != "${sha2}" ]
|
||||
# invalidate access time timer, which is 5minutes, but don't expect a re-download
|
||||
touch -a -m -t '199901010101' "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml"
|
||||
# this time, we expect the same hash and etag
|
||||
raw_eghcup -s https://www.haskell.org/ghcup/exp/ghcup-${JSON_VERSION}.yaml list
|
||||
etag3=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags")
|
||||
sha3=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
|
||||
[ "${etag2}" = "${etag3}" ]
|
||||
[ "${sha2}" = "${sha3}" ]
|
||||
|
||||
|
||||
eghcup upgrade
|
||||
eghcup upgrade -f
|
||||
@ -162,8 +203,4 @@ eghcup upgrade -f
|
||||
|
||||
# nuke
|
||||
eghcup nuke
|
||||
if [ "${OS}" = "WINDOWS" ] ; then
|
||||
[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/ghcup" ]
|
||||
else
|
||||
[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup" ]
|
||||
fi
|
||||
[ ! -e "${GHCUP_DIR}" ]
|
||||
|
||||
@ -256,7 +256,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
|
||||
case etool of
|
||||
Right (Just GHCup) -> do
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
_ <- liftE $ download dli tmpUnpack Nothing
|
||||
_ <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmpUnpack Nothing False
|
||||
pure Nothing
|
||||
Right _ -> do
|
||||
p <- liftE $ downloadCached dli Nothing
|
||||
@ -266,7 +266,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
|
||||
$ p
|
||||
Left ShimGen -> do
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
_ <- liftE $ download dli tmpUnpack Nothing
|
||||
_ <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmpUnpack Nothing False
|
||||
pure Nothing
|
||||
case r of
|
||||
VRight (Just basePath) -> do
|
||||
|
||||
@ -2137,7 +2137,7 @@ upgradeGHCup mtarget force' = do
|
||||
dli <- liftE $ getDownloadInfo GHCup latestVer
|
||||
tmp <- lift withGHCupTmpDir
|
||||
let fn = "ghcup" <> exeExt
|
||||
p <- liftE $ download dli tmp (Just fn)
|
||||
p <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp (Just fn) False
|
||||
let destDir = takeDirectory destFile
|
||||
destFile = fromMaybe (binDir </> fn) mtarget
|
||||
lift $ $(logDebug) [i|mkdir -p #{destDir}|]
|
||||
|
||||
@ -55,20 +55,19 @@ import Data.Aeson
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString ( ByteString )
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
import Data.CaseInsensitive ( CI )
|
||||
import Data.CaseInsensitive ( mk )
|
||||
#endif
|
||||
import Data.List.Extra
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Clock.POSIX
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
import Data.Time.Format
|
||||
#endif
|
||||
import Data.Versions
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import Data.Word8 hiding ( isSpace )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
import Network.Http.Client hiding ( URL )
|
||||
#endif
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
@ -76,8 +75,11 @@ import Prelude hiding ( abs
|
||||
)
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
import System.IO.Error
|
||||
import System.IO.Temp
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Crypto.Hash.SHA256 as SHA256
|
||||
@ -85,10 +87,8 @@ import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Base16 as B16
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Map.Strict as M
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
#endif
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Yaml as Y
|
||||
|
||||
@ -149,19 +149,14 @@ getDownloadsF = do
|
||||
in GHCupInfo tr newDownloads newGlobalTools
|
||||
|
||||
|
||||
readFromCache :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadCatch m)
|
||||
=> URI
|
||||
-> Excepts '[JSONError, FileDoesNotExistError] m L.ByteString
|
||||
readFromCache uri = do
|
||||
Dirs{..} <- lift getDirs
|
||||
let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri)
|
||||
handleIO' NoSuchThing (\_ -> throwE $ FileDoesNotExistError yaml_file)
|
||||
. liftIO
|
||||
. L.readFile
|
||||
$ yaml_file
|
||||
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
|
||||
yamlFromCache uri = do
|
||||
Dirs{..} <- getDirs
|
||||
pure (cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
|
||||
|
||||
|
||||
etagsFile :: FilePath -> FilePath
|
||||
etagsFile = (<.> "etags")
|
||||
|
||||
|
||||
getBase :: ( MonadReader env m
|
||||
@ -174,33 +169,41 @@ getBase :: ( MonadReader env m
|
||||
, MonadMask m
|
||||
)
|
||||
=> URI
|
||||
-> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
|
||||
-> Excepts '[JSONError] m GHCupInfo
|
||||
getBase uri = do
|
||||
Settings { noNetwork } <- lift getSettings
|
||||
bs <- if noNetwork
|
||||
then readFromCache uri
|
||||
else handleIO (\_ -> warnCache >> readFromCache uri)
|
||||
. catchE @_ @'[JSONError, FileDoesNotExistError] (\(DownloadFailed _) -> warnCache >> readFromCache uri)
|
||||
. reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed
|
||||
$ smartDl uri
|
||||
yaml <- lift $ yamlFromCache uri
|
||||
unless noNetwork $
|
||||
handleIO (\e -> warnCache (displayException e))
|
||||
. catchE @_ @_ @'[] (\e@(DownloadFailed _) -> warnCache (prettyShow e))
|
||||
. reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed
|
||||
. smartDl
|
||||
$ uri
|
||||
liftE
|
||||
. lE' @_ @_ @'[JSONError] JSONDecodeError
|
||||
. first show
|
||||
. Y.decodeEither'
|
||||
. L.toStrict
|
||||
$ bs
|
||||
. onE_ (onError yaml)
|
||||
. lEM' @_ @_ @'[JSONError] JSONDecodeError
|
||||
. fmap (first (\e -> [i|#{displayException e}
|
||||
Consider removing "#{yaml}" manually.|]))
|
||||
. liftIO
|
||||
. Y.decodeFileEither
|
||||
$ yaml
|
||||
where
|
||||
warnCache = lift $ $(logWarn)
|
||||
[i|Could not get download info, trying cached version (this may not be recent!)|]
|
||||
-- On error, remove the etags file and set access time to 0. This should ensure the next invocation
|
||||
-- may re-download and succeed.
|
||||
onError :: (MonadLogger m, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
|
||||
onError fp = do
|
||||
let efp = etagsFile fp
|
||||
handleIO (\e -> $(logWarn) [i|Couldn't remove file #{efp}, error was: #{displayException e}|])
|
||||
(hideError doesNotExistErrorType $ rmFile efp)
|
||||
liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
|
||||
warnCache s = do
|
||||
lift $ $(logWarn) [i|Could not get download info, trying cached version (this may not be recent!)|]
|
||||
lift $ $(logDebug) [i|Error was: #{s}|]
|
||||
|
||||
-- First check if the json file is in the ~/.ghcup/cache dir
|
||||
-- and check it's access time. If it has been accessed within the
|
||||
-- last 5 minutes, just reuse it.
|
||||
--
|
||||
-- If not, then send a HEAD request and check for modification time.
|
||||
-- Only download the file if the modification time is newer
|
||||
-- than the local file.
|
||||
--
|
||||
-- Always save the local file with the mod time of the remote file.
|
||||
smartDl :: forall m1 env1
|
||||
. ( MonadReader env1 m1
|
||||
@ -214,93 +217,33 @@ getBase uri = do
|
||||
)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ FileDoesNotExistError
|
||||
, HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
, ProcessError
|
||||
, NoNetwork
|
||||
'[ DownloadFailed
|
||||
, DigestError
|
||||
]
|
||||
m1
|
||||
L.ByteString
|
||||
()
|
||||
smartDl uri' = do
|
||||
Dirs{..} <- lift getDirs
|
||||
let path = view pathL' uri'
|
||||
let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
|
||||
json_file <- lift $ yamlFromCache uri'
|
||||
e <- liftIO $ doesFileExist json_file
|
||||
currentTime <- liftIO getCurrentTime
|
||||
if e
|
||||
then do
|
||||
accessTime <- liftIO $ getAccessTime json_file
|
||||
currentTime <- liftIO getCurrentTime
|
||||
|
||||
-- access time won't work on most linuxes, but we can try regardless
|
||||
if (utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300
|
||||
then do -- no access in last 5 minutes, re-check upstream mod time
|
||||
getModTime >>= \case
|
||||
Just modTime -> do
|
||||
fileMod <- liftIO $ getModificationTime json_file
|
||||
if modTime > fileMod
|
||||
then dlWithMod modTime json_file
|
||||
else liftIO $ L.readFile json_file
|
||||
Nothing -> do
|
||||
lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
|
||||
dlWithoutMod json_file
|
||||
else -- access in less than 5 minutes, re-use file
|
||||
liftIO $ L.readFile json_file
|
||||
else do
|
||||
getModTime >>= \case
|
||||
Just modTime -> dlWithMod modTime json_file
|
||||
Nothing -> do
|
||||
-- although we don't know last-modified, we still save
|
||||
-- it to a file, so we might use it in offline mode
|
||||
lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
|
||||
dlWithoutMod json_file
|
||||
|
||||
when ((utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300) $
|
||||
-- no access in last 5 minutes, re-check upstream mod time
|
||||
dlWithMod currentTime json_file
|
||||
else
|
||||
dlWithMod currentTime json_file
|
||||
where
|
||||
dlWithMod modTime json_file = do
|
||||
bs <- liftE $ downloadBS uri'
|
||||
liftIO $ writeFileWithModTime modTime json_file bs
|
||||
pure bs
|
||||
dlWithoutMod json_file = do
|
||||
bs <- liftE $ downloadBS uri'
|
||||
lift $ hideError doesNotExistErrorType $ recycleFile json_file
|
||||
liftIO $ L.writeFile json_file bs
|
||||
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
|
||||
pure bs
|
||||
let (dir, fn) = splitFileName json_file
|
||||
f <- liftE $ download uri' Nothing dir (Just fn) True
|
||||
liftIO $ setModificationTime f modTime
|
||||
liftIO $ setAccessTime f modTime
|
||||
|
||||
|
||||
getModTime = do
|
||||
#if !defined(INTERNAL_DOWNLOADER)
|
||||
pure Nothing
|
||||
#else
|
||||
headers <-
|
||||
handleIO (\_ -> pure mempty)
|
||||
$ liftE
|
||||
$ ( catchAllE
|
||||
(\_ ->
|
||||
pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
|
||||
)
|
||||
$ getHead uri'
|
||||
)
|
||||
pure $ parseModifiedHeader headers
|
||||
|
||||
parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
|
||||
parseModifiedHeader headers =
|
||||
(M.lookup (CI.mk "Last-Modified") headers) >>= \h -> parseTimeM
|
||||
True
|
||||
defaultTimeLocale
|
||||
"%a, %d %b %Y %H:%M:%S %Z"
|
||||
(T.unpack . decUTF8Safe $ h)
|
||||
|
||||
#endif
|
||||
|
||||
writeFileWithModTime :: UTCTime -> FilePath -> L.ByteString -> IO ()
|
||||
writeFileWithModTime utctime path content = do
|
||||
L.writeFile path content
|
||||
setModificationTime path utctime
|
||||
|
||||
|
||||
getDownloadInfo :: ( MonadReader env m
|
||||
, HasPlatformReq env
|
||||
@ -359,32 +302,32 @@ download :: ( MonadReader env m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
)
|
||||
=> DownloadInfo
|
||||
=> URI
|
||||
-> Maybe T.Text -- ^ expected hash
|
||||
-> FilePath -- ^ destination dir
|
||||
-> Maybe FilePath -- ^ optional filename
|
||||
-> Bool -- ^ whether to read an write etags
|
||||
-> Excepts '[DigestError , DownloadFailed] m FilePath
|
||||
download dli dest mfn
|
||||
download uri eDigest dest mfn etags
|
||||
| scheme == "https" = dl
|
||||
| scheme == "http" = dl
|
||||
| scheme == "file" = cp
|
||||
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
|
||||
|
||||
where
|
||||
scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
|
||||
scheme = view (uriSchemeL' % schemeBSL') uri
|
||||
cp = do
|
||||
-- destination dir must exist
|
||||
liftIO $ createDirRecursive' dest
|
||||
let destFile = getDestFile
|
||||
let fromFile = T.unpack . decUTF8Safe $ path
|
||||
liftIO $ copyFile fromFile destFile
|
||||
pure destFile
|
||||
dl = do
|
||||
let uri' = decUTF8Safe (serializeURIRef' (view dlUri dli))
|
||||
let uri' = decUTF8Safe (serializeURIRef' uri)
|
||||
lift $ $(logInfo) [i|downloading: #{uri'}|]
|
||||
|
||||
-- destination dir must exist
|
||||
liftIO $ createDirRecursive' dest
|
||||
let destFile = getDestFile
|
||||
|
||||
-- download
|
||||
flip onException
|
||||
@ -399,28 +342,134 @@ download dli dest mfn
|
||||
case downloader of
|
||||
Curl -> do
|
||||
o' <- liftIO getCurlOpts
|
||||
if etags
|
||||
then do
|
||||
dh <- liftIO $ emptySystemTempFile "curl-header"
|
||||
flip finally (try @_ @SomeException $ rmFile dh) $
|
||||
flip finally (try @_ @SomeException $ rmFile (destFile <.> "tmp")) $ do
|
||||
metag <- readETag destFile
|
||||
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
|
||||
(o' ++ ["-fL", "-o", destFile, (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
|
||||
(o' ++ (if etags then ["--dump-header", dh] else [])
|
||||
++ maybe [] (\t -> ["-H", [i|If-None-Match: #{t}|]]) metag
|
||||
++ ["-fL", "-o", destFile <.> "tmp", T.unpack uri']) Nothing Nothing
|
||||
headers <- liftIO $ T.readFile dh
|
||||
|
||||
-- this nonsense is necessary, because some older versions of curl would overwrite
|
||||
-- the destination file when 304 is returned
|
||||
case fmap T.words . listToMaybe . fmap T.strip . T.lines $ headers of
|
||||
Just (http':sc:_)
|
||||
| sc == "304"
|
||||
, T.pack "HTTP" `T.isPrefixOf` http' -> $logDebug [i|Status code was 304, not overwriting|]
|
||||
| T.pack "HTTP" `T.isPrefixOf` http' -> do
|
||||
$logDebug [i|Status code was #{sc}, overwriting|]
|
||||
liftIO $ copyFile (destFile <.> "tmp") destFile
|
||||
_ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
|
||||
:: V '[MalformedHeaders]))
|
||||
|
||||
writeEtags (parseEtags headers)
|
||||
else
|
||||
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
|
||||
(o' ++ ["-fL", "-o", destFile, T.unpack uri']) Nothing Nothing
|
||||
Wget -> do
|
||||
destFileTemp <- liftIO $ emptySystemTempFile "wget-tmp"
|
||||
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
|
||||
o' <- liftIO getWgetOpts
|
||||
liftE $ lEM @_ @'[ProcessError] $ exec "wget"
|
||||
(o' ++ ["-O", destFile , (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
|
||||
if etags
|
||||
then do
|
||||
metag <- readETag destFile
|
||||
let opts = o' ++ maybe [] (\t -> ["--header", [i|If-None-Match: #{t}|]]) metag
|
||||
++ ["-q", "-S", "-O", destFileTemp , T.unpack uri']
|
||||
CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing
|
||||
case _exitCode of
|
||||
ExitSuccess -> do
|
||||
liftIO $ copyFile destFileTemp destFile
|
||||
writeEtags (parseEtags (decUTF8Safe' _stdErr))
|
||||
ExitFailure i'
|
||||
| i' == 8
|
||||
, Just _ <- find (T.pack "304 Not Modified" `T.isInfixOf`) . T.lines . decUTF8Safe' $ _stdErr
|
||||
-> do
|
||||
$logDebug "Not modified, skipping download"
|
||||
writeEtags (parseEtags (decUTF8Safe' _stdErr))
|
||||
| otherwise -> throwE (NonZeroExit i' "wget" opts)
|
||||
else do
|
||||
let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
|
||||
liftE $ lEM @_ @'[ProcessError] $ exec "wget" opts Nothing Nothing
|
||||
liftIO $ copyFile destFileTemp destFile
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
Internal -> do
|
||||
(https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
|
||||
liftE $ downloadToFile https host fullPath port destFile
|
||||
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri
|
||||
if etags
|
||||
then do
|
||||
metag <- readETag destFile
|
||||
let addHeaders = maybe mempty (\etag -> M.fromList [ (mk . E.encodeUtf8 . T.pack $ "If-None-Match"
|
||||
, E.encodeUtf8 etag)]) metag
|
||||
liftE
|
||||
$ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags (pure $ Just etag))
|
||||
$ do
|
||||
r <- downloadToFile https host fullPath port destFile addHeaders
|
||||
writeEtags (pure $ decUTF8Safe <$> getHeader r "etag")
|
||||
else void $ liftE $ catchE @HTTPNotModified
|
||||
@'[DownloadFailed]
|
||||
(\e@(HTTPNotModified _) ->
|
||||
throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 e :: V '[HTTPNotModified])))
|
||||
$ downloadToFile https host fullPath port destFile mempty
|
||||
#endif
|
||||
|
||||
liftE $ checkDigest dli destFile
|
||||
forM_ eDigest (liftE . flip checkDigest destFile)
|
||||
pure destFile
|
||||
|
||||
|
||||
-- Manage to find a file we can write the body into.
|
||||
getDestFile :: FilePath
|
||||
getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path)))
|
||||
destFile :: FilePath
|
||||
destFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path)))
|
||||
(dest </>)
|
||||
mfn
|
||||
|
||||
path = view (dlUri % pathL') dli
|
||||
path = view pathL' uri
|
||||
|
||||
parseEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
|
||||
parseEtags stderr = do
|
||||
let mEtag = find (\line -> T.pack "etag:" `T.isPrefixOf` T.toLower line) . fmap T.strip . T.lines $ stderr
|
||||
case T.words <$> mEtag of
|
||||
(Just []) -> do
|
||||
$logDebug "Couldn't parse etags, no input: "
|
||||
pure Nothing
|
||||
(Just [_, etag']) -> do
|
||||
$logDebug [i|Parsed etag: #{etag'}|]
|
||||
pure (Just etag')
|
||||
(Just xs) -> do
|
||||
$logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs)
|
||||
pure Nothing
|
||||
Nothing -> do
|
||||
$logDebug "No etags header found"
|
||||
pure Nothing
|
||||
|
||||
writeEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => m (Maybe T.Text) -> m ()
|
||||
writeEtags getTags = do
|
||||
getTags >>= \case
|
||||
Just t -> do
|
||||
$logDebug [i|Writing etagsFile #{(etagsFile destFile)}|]
|
||||
liftIO $ T.writeFile (etagsFile destFile) t
|
||||
Nothing ->
|
||||
$logDebug [i|No etags files written|]
|
||||
|
||||
readETag :: (MonadLogger m, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
|
||||
readETag fp = do
|
||||
e <- liftIO $ doesFileExist fp
|
||||
if e
|
||||
then do
|
||||
rE <- try @_ @SomeException $ liftIO $ fmap stripNewline' $ T.readFile (etagsFile fp)
|
||||
case rE of
|
||||
(Right et) -> do
|
||||
$logDebug [i|Read etag: #{et}|]
|
||||
pure (Just et)
|
||||
(Left _) -> do
|
||||
$logDebug [i|Etag file doesn't exist (yet)|]
|
||||
pure Nothing
|
||||
else do
|
||||
$logDebug [i|Skipping and deleting etags file because destination file #{fp} doesn't exist|]
|
||||
liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp)
|
||||
pure Nothing
|
||||
|
||||
|
||||
-- | Download into tmpdir or use cached version, if it exists. If filename
|
||||
@ -444,7 +493,7 @@ downloadCached dli mfn = do
|
||||
True -> downloadCached' dli mfn Nothing
|
||||
False -> do
|
||||
tmp <- lift withGHCupTmpDir
|
||||
liftE $ download dli tmp mfn
|
||||
liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp mfn False
|
||||
|
||||
|
||||
downloadCached' :: ( MonadReader env m
|
||||
@ -468,9 +517,9 @@ downloadCached' dli mfn mDestDir = do
|
||||
fileExists <- liftIO $ doesFileExist cachfile
|
||||
if
|
||||
| fileExists -> do
|
||||
liftE $ checkDigest dli cachfile
|
||||
liftE $ checkDigest (view dlHash dli) cachfile
|
||||
pure cachfile
|
||||
| otherwise -> liftE $ download dli destDir mfn
|
||||
| otherwise -> liftE $ download (_dlUri dli) (Just (_dlHash dli)) destDir mfn False
|
||||
|
||||
|
||||
|
||||
@ -481,73 +530,6 @@ downloadCached' dli mfn mDestDir = do
|
||||
|
||||
|
||||
|
||||
|
||||
-- | This is used for downloading the JSON.
|
||||
downloadBS :: ( MonadReader env m
|
||||
, HasSettings env
|
||||
, MonadCatch m
|
||||
, MonadIO m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ FileDoesNotExistError
|
||||
, HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
, ProcessError
|
||||
, NoNetwork
|
||||
]
|
||||
m
|
||||
L.ByteString
|
||||
downloadBS uri'
|
||||
| scheme == "https"
|
||||
= dl True
|
||||
| scheme == "http"
|
||||
= dl False
|
||||
| scheme == "file"
|
||||
= liftIOException doesNotExistErrorType (FileDoesNotExistError $ T.unpack $ decUTF8Safe path)
|
||||
(liftIO $ L.readFile (T.unpack $ decUTF8Safe path))
|
||||
| otherwise
|
||||
= throwE UnsupportedScheme
|
||||
|
||||
where
|
||||
scheme = view (uriSchemeL' % schemeBSL') uri'
|
||||
path = view pathL' uri'
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
dl https = do
|
||||
#else
|
||||
dl _ = do
|
||||
#endif
|
||||
lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
|
||||
Settings{ downloader, noNetwork } <- lift getSettings
|
||||
when noNetwork $ throwE NoNetwork
|
||||
case downloader of
|
||||
Curl -> do
|
||||
o' <- liftIO getCurlOpts
|
||||
let exe = "curl"
|
||||
args = o' ++ ["-sSfL", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
|
||||
lift (executeOut exe args Nothing) >>= \case
|
||||
CapturedProcess ExitSuccess stdout _ -> do
|
||||
pure stdout
|
||||
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
|
||||
Wget -> do
|
||||
o' <- liftIO getWgetOpts
|
||||
let exe = "wget"
|
||||
args = o' ++ ["-qO-", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
|
||||
lift (executeOut exe args Nothing) >>= \case
|
||||
CapturedProcess ExitSuccess stdout _ -> do
|
||||
pure stdout
|
||||
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
Internal -> do
|
||||
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
|
||||
liftE $ downloadBS' https host' fullPath' port'
|
||||
#endif
|
||||
|
||||
|
||||
checkDigest :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
@ -555,10 +537,10 @@ checkDigest :: ( MonadReader env m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> DownloadInfo
|
||||
=> T.Text -- ^ the hash
|
||||
-> FilePath
|
||||
-> Excepts '[DigestError] m ()
|
||||
checkDigest dli file = do
|
||||
checkDigest eDigest file = do
|
||||
Settings{ noVerify } <- lift getSettings
|
||||
let verify = not noVerify
|
||||
when verify $ do
|
||||
@ -566,7 +548,6 @@ checkDigest dli file = do
|
||||
lift $ $(logInfo) [i|verifying digest of: #{p'}|]
|
||||
c <- liftIO $ L.readFile file
|
||||
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
|
||||
let eDigest = view dlHash dli
|
||||
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
|
||||
|
||||
|
||||
|
||||
@ -9,9 +9,7 @@ module GHCup.Download.IOStreams where
|
||||
|
||||
import GHCup.Download.Utils
|
||||
import GHCup.Errors
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Applicative
|
||||
@ -20,7 +18,7 @@ import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.ByteString.Builder
|
||||
import Data.CaseInsensitive ( CI )
|
||||
import Data.CaseInsensitive ( CI, original, mk )
|
||||
import Data.IORef
|
||||
import Data.Maybe
|
||||
import Data.Text.Read
|
||||
@ -32,7 +30,6 @@ import Prelude hiding ( abs
|
||||
, writeFile
|
||||
)
|
||||
import System.ProgressBar
|
||||
import System.IO
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
@ -67,7 +64,7 @@ downloadBS' :: MonadIO m
|
||||
downloadBS' https host path port = do
|
||||
bref <- liftIO $ newIORef (mempty :: Builder)
|
||||
let stepper bs = modifyIORef bref (<> byteString bs)
|
||||
downloadInternal False https host path port stepper
|
||||
void $ downloadInternal False https host path port stepper (pure ()) mempty
|
||||
liftIO (readIORef bref <&> toLazyByteString)
|
||||
|
||||
|
||||
@ -77,12 +74,17 @@ downloadToFile :: (MonadMask m, MonadIO m)
|
||||
-> ByteString -- ^ path (e.g. "/my/file") including query
|
||||
-> Maybe Int -- ^ optional port (e.g. 3000)
|
||||
-> FilePath -- ^ destination file to create and write to
|
||||
-> Excepts '[DownloadFailed] m ()
|
||||
downloadToFile https host fullPath port destFile = do
|
||||
fd <- liftIO $ openFile destFile WriteMode
|
||||
let stepper = BS.hPut fd
|
||||
flip finally (liftIO $ hClose fd)
|
||||
$ reThrowAll DownloadFailed $ downloadInternal True https host fullPath port stepper
|
||||
-> M.Map (CI ByteString) ByteString -- ^ additional headers
|
||||
-> Excepts '[DownloadFailed, HTTPNotModified] m Response
|
||||
downloadToFile https host fullPath port destFile addHeaders = do
|
||||
let stepper = BS.appendFile destFile
|
||||
setup = BS.writeFile destFile mempty
|
||||
catchAllE (\case
|
||||
(V (HTTPStatusError i headers))
|
||||
| i == 304
|
||||
, Just e <- M.lookup (mk "etag") headers -> throwE $ HTTPNotModified (decUTF8Safe e)
|
||||
v -> throwE $ DownloadFailed v
|
||||
) $ downloadInternal True https host fullPath port stepper setup addHeaders
|
||||
|
||||
|
||||
downloadInternal :: MonadIO m
|
||||
@ -92,6 +94,8 @@ downloadInternal :: MonadIO m
|
||||
-> ByteString -- ^ path with query
|
||||
-> Maybe Int -- ^ optional port
|
||||
-> (ByteString -> IO a) -- ^ the consuming step function
|
||||
-> IO a -- ^ setup action
|
||||
-> M.Map (CI ByteString) ByteString -- ^ additional headers
|
||||
-> Excepts
|
||||
'[ HTTPStatusError
|
||||
, URIParseError
|
||||
@ -100,19 +104,21 @@ downloadInternal :: MonadIO m
|
||||
, TooManyRedirs
|
||||
]
|
||||
m
|
||||
()
|
||||
Response
|
||||
downloadInternal = go (5 :: Int)
|
||||
|
||||
where
|
||||
go redirs progressBar https host path port consumer = do
|
||||
go redirs progressBar https host path port consumer setup addHeaders = do
|
||||
r <- liftIO $ withConnection' https host port action
|
||||
veitherToExcepts r >>= \case
|
||||
Just r' ->
|
||||
Right r' ->
|
||||
if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
|
||||
Nothing -> pure ()
|
||||
Left res -> pure res
|
||||
where
|
||||
action c = do
|
||||
let q = buildRequest1 $ http GET path
|
||||
let q = buildRequest1 $ do
|
||||
http GET path
|
||||
flip M.traverseWithKey addHeaders $ \key val -> setHeader (original key) val
|
||||
|
||||
sendRequest c q emptyBody
|
||||
|
||||
@ -121,28 +127,30 @@ downloadInternal = go (5 :: Int)
|
||||
(\r i' -> runE $ do
|
||||
let scode = getStatusCode r
|
||||
if
|
||||
| scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
|
||||
| scode >= 200 && scode < 300 -> liftIO $ downloadStream r i' >> pure (Left r)
|
||||
| scode == 304 -> throwE $ HTTPStatusError scode (getHeaderMap r)
|
||||
| scode >= 300 && scode < 400 -> case getHeader r "Location" of
|
||||
Just r' -> pure $ Just r'
|
||||
Just r' -> pure $ Right r'
|
||||
Nothing -> throwE NoLocationHeader
|
||||
| otherwise -> throwE $ HTTPStatusError scode
|
||||
| otherwise -> throwE $ HTTPStatusError scode (getHeaderMap r)
|
||||
)
|
||||
|
||||
followRedirectURL bs = case parseURI strictURIParserOptions bs of
|
||||
Right uri' -> do
|
||||
(https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
|
||||
go (redirs - 1) progressBar https' host' fullPath' port' consumer
|
||||
go (redirs - 1) progressBar https' host' fullPath' port' consumer setup addHeaders
|
||||
Left e -> throwE e
|
||||
|
||||
downloadStream r i' = do
|
||||
void setup
|
||||
let size = case getHeader r "Content-Length" of
|
||||
Just x' -> case decimal $ decUTF8Safe x' of
|
||||
Left _ -> 0
|
||||
Right (r', _) -> r'
|
||||
Nothing -> 0
|
||||
|
||||
mpb <- if progressBar
|
||||
then Just <$> liftIO (newProgressBar defStyle 10 (Progress 0 size ()))
|
||||
(mpb :: Maybe (ProgressBar ())) <- if progressBar
|
||||
then Just <$> newProgressBar defStyle 10 (Progress 0 size ())
|
||||
else pure Nothing
|
||||
|
||||
outStream <- liftIO $ Streams.makeOutputStream
|
||||
@ -155,79 +163,6 @@ downloadInternal = go (5 :: Int)
|
||||
liftIO $ Streams.connect i' outStream
|
||||
|
||||
|
||||
getHead :: (MonadCatch m, MonadIO m)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
, ProcessError
|
||||
]
|
||||
m
|
||||
(M.Map (CI ByteString) ByteString)
|
||||
getHead uri' | scheme == "https" = head' True
|
||||
| scheme == "http" = head' False
|
||||
| otherwise = throwE UnsupportedScheme
|
||||
|
||||
where
|
||||
scheme = view (uriSchemeL' % schemeBSL') uri'
|
||||
head' https = do
|
||||
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
|
||||
liftE $ headInternal https host' fullPath' port'
|
||||
|
||||
|
||||
headInternal :: MonadIO m
|
||||
=> Bool -- ^ https?
|
||||
-> ByteString -- ^ host
|
||||
-> ByteString -- ^ path with query
|
||||
-> Maybe Int -- ^ optional port
|
||||
-> Excepts
|
||||
'[ HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, TooManyRedirs
|
||||
, NoLocationHeader
|
||||
]
|
||||
m
|
||||
(M.Map (CI ByteString) ByteString)
|
||||
headInternal = go (5 :: Int)
|
||||
|
||||
where
|
||||
go redirs https host path port = do
|
||||
r <- liftIO $ withConnection' https host port action
|
||||
veitherToExcepts r >>= \case
|
||||
Left r' ->
|
||||
if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
|
||||
Right hs -> pure hs
|
||||
where
|
||||
|
||||
action c = do
|
||||
let q = buildRequest1 $ http HEAD path
|
||||
|
||||
sendRequest c q emptyBody
|
||||
|
||||
unsafeReceiveResponse
|
||||
c
|
||||
(\r _ -> runE $ do
|
||||
let scode = getStatusCode r
|
||||
if
|
||||
| scode >= 200 && scode < 300 -> do
|
||||
let headers = getHeaderMap r
|
||||
pure $ Right headers
|
||||
| scode >= 300 && scode < 400 -> case getHeader r "Location" of
|
||||
Just r' -> pure $ Left r'
|
||||
Nothing -> throwE NoLocationHeader
|
||||
| otherwise -> throwE $ HTTPStatusError scode
|
||||
)
|
||||
|
||||
followRedirectURL bs = case parseURI strictURIParserOptions bs of
|
||||
Right uri' -> do
|
||||
(https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
|
||||
go (redirs - 1) https' host' fullPath' port'
|
||||
Left e -> throwE e
|
||||
|
||||
|
||||
withConnection' :: Bool
|
||||
-> ByteString
|
||||
|
||||
@ -27,6 +27,8 @@ import Codec.Archive
|
||||
import qualified Codec.Archive.Tar as Tar
|
||||
#endif
|
||||
import Control.Exception.Safe
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.CaseInsensitive ( CI )
|
||||
import Data.String.Interpolate
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
@ -35,6 +37,8 @@ import Text.PrettyPrint hiding ( (<>) )
|
||||
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Data.Map.Strict as M
|
||||
|
||||
|
||||
|
||||
------------------------
|
||||
@ -180,13 +184,29 @@ instance Pretty DigestError where
|
||||
text [i|Digest error: expected "#{expectedDigest}", but got "#{currentDigest}"|]
|
||||
|
||||
-- | Unexpected HTTP status.
|
||||
data HTTPStatusError = HTTPStatusError Int
|
||||
data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
|
||||
deriving Show
|
||||
|
||||
instance Pretty HTTPStatusError where
|
||||
pPrint (HTTPStatusError status) =
|
||||
pPrint (HTTPStatusError status _) =
|
||||
text [i|Unexpected HTTP status: #{status}|]
|
||||
|
||||
-- | Malformed headers.
|
||||
data MalformedHeaders = MalformedHeaders Text
|
||||
deriving Show
|
||||
|
||||
instance Pretty MalformedHeaders where
|
||||
pPrint (MalformedHeaders h) =
|
||||
text [i|Headers are malformed: #{h}|]
|
||||
|
||||
-- | Unexpected HTTP status.
|
||||
data HTTPNotModified = HTTPNotModified Text
|
||||
deriving Show
|
||||
|
||||
instance Pretty HTTPNotModified where
|
||||
pPrint (HTTPNotModified etag) =
|
||||
text [i|Remote resource not modifed, etag was: #{etag}|]
|
||||
|
||||
-- | The 'Location' header was expected during a 3xx redirect, but not found.
|
||||
data NoLocationHeader = NoLocationHeader
|
||||
deriving Show
|
||||
|
||||
@ -209,6 +209,20 @@ exec exe args chdir env = do
|
||||
pure $ toProcessError exe args exit_code
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
execShell :: MonadIO m
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [FilePath] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
execShell exe args chdir env = do
|
||||
let cmd = exe <> " " <> concatMap (' ':) args
|
||||
cp <- createProcessWithMingwPath ((shell cmd) { cwd = chdir, env = env })
|
||||
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
|
||||
pure $ toProcessError cmd [] exit_code
|
||||
|
||||
|
||||
chmod_755 :: MonadIO m => FilePath -> m ()
|
||||
chmod_755 fp =
|
||||
let perm = setOwnerWritable True emptyPermissions
|
||||
|
||||
@ -410,12 +410,7 @@ rmPathForcibly :: ( MonadIO m
|
||||
-> m ()
|
||||
rmPathForcibly fp =
|
||||
#if defined(IS_WINDOWS)
|
||||
recovering (fullJitterBackoff 25000 <> limitRetries 10)
|
||||
[\_ -> Handler (\e -> pure $ isPermissionError e)
|
||||
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
|
||||
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
|
||||
]
|
||||
(\_ -> liftIO $ removePathForcibly fp)
|
||||
recover (liftIO $ removePathForcibly fp)
|
||||
#else
|
||||
liftIO $ removePathForcibly fp
|
||||
#endif
|
||||
@ -426,12 +421,7 @@ rmDirectory :: (MonadIO m, MonadMask m)
|
||||
-> m ()
|
||||
rmDirectory fp =
|
||||
#if defined(IS_WINDOWS)
|
||||
recovering (fullJitterBackoff 25000 <> limitRetries 10)
|
||||
[\_ -> Handler (\e -> pure $ isPermissionError e)
|
||||
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
|
||||
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
|
||||
]
|
||||
(\_ -> liftIO $ removeDirectory fp)
|
||||
recover (liftIO $ removeDirectory fp)
|
||||
#else
|
||||
liftIO $ removeDirectory fp
|
||||
#endif
|
||||
@ -469,12 +459,7 @@ rmFile :: ( MonadIO m
|
||||
-> m ()
|
||||
rmFile fp =
|
||||
#if defined(IS_WINDOWS)
|
||||
recovering (fullJitterBackoff 25000 <> limitRetries 10)
|
||||
[\_ -> Handler (\e -> pure $ isPermissionError e)
|
||||
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
|
||||
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
|
||||
]
|
||||
(\_ -> liftIO $ removeFile fp)
|
||||
recover (liftIO $ removeFile fp)
|
||||
#else
|
||||
liftIO $ removeFile fp
|
||||
#endif
|
||||
@ -485,12 +470,7 @@ rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
|
||||
-> m ()
|
||||
rmDirectoryLink fp =
|
||||
#if defined(IS_WINDOWS)
|
||||
recovering (fullJitterBackoff 25000 <> limitRetries 10)
|
||||
[\_ -> Handler (\e -> pure $ isPermissionError e)
|
||||
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
|
||||
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
|
||||
]
|
||||
(\_ -> liftIO $ removeDirectoryLink fp)
|
||||
recover (liftIO $ removeDirectoryLink fp)
|
||||
#else
|
||||
liftIO $ removeDirectoryLink fp
|
||||
#endif
|
||||
@ -525,6 +505,14 @@ stripNewline s
|
||||
| otherwise = head s : stripNewline (tail s)
|
||||
|
||||
|
||||
-- | Strip @\\r@ and @\\n@ from 'ByteString's
|
||||
stripNewline' :: T.Text -> T.Text
|
||||
stripNewline' s
|
||||
| T.null s = mempty
|
||||
| T.head s `elem` "\n\r" = stripNewline' (T.tail s)
|
||||
| otherwise = T.singleton (T.head s) <> stripNewline' (T.tail s)
|
||||
|
||||
|
||||
isNewLine :: Word8 -> Bool
|
||||
isNewLine w
|
||||
| w == _lf = True
|
||||
|
||||
Loading…
Reference in New Issue
Block a user