{-# LANGUAGE CPP #-}
module Darcs.Util.Download
( copyUrl
, copyUrlFirst
, setDebugHTTP
, disableHTTPPipelining
, maxPipelineLength
, waitUrl
, Cachable(Cachable, Uncachable, MaxAge)
, environmentHelpProxy
, environmentHelpProxyPassword
, ConnectionError(..)
) where
import Prelude ( (^) )
import Darcs.Prelude
import Control.Arrow ( (&&&) )
import Control.Concurrent ( forkIO )
import Control.Concurrent.STM.TChan
( isEmptyTChan, newTChanIO, readTChan, writeTChan, TChan )
import Control.Concurrent.MVar ( isEmptyMVar, modifyMVar_, modifyMVar, newEmptyMVar,
newMVar, putMVar, readMVar, withMVar, MVar )
import Control.Monad ( unless, when )
import Control.Monad.State ( evalStateT, get, modify, put, StateT )
import Control.Monad.STM ( atomically )
import Control.Monad.Trans ( liftIO )
import Data.IORef ( newIORef, readIORef, writeIORef, IORef )
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Tuple ( swap )
import System.Directory ( copyFile )
import System.IO.Unsafe ( unsafePerformIO )
import System.Random ( randomRIO )
import Darcs.Util.AtExit ( atexit )
import Darcs.Util.File ( removeFileMayNotExist )
import Numeric ( showHex )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Download.Request
import Darcs.Util.Workaround ( renameFile )
#ifdef HAVE_CURL
import qualified Darcs.Util.Download.Curl as Curl
#else
import qualified Darcs.Util.Download.HTTP as HTTP
#endif
{-# NOINLINE maxPipelineLengthRef #-}
maxPipelineLengthRef :: IORef Int
maxPipelineLengthRef :: IORef Int
maxPipelineLengthRef = IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (IO (IORef Int) -> IORef Int) -> IO (IORef Int) -> IORef Int
forall a b. (a -> b) -> a -> b
$ do
Bool
enabled <- IO Bool
pipeliningEnabled
#ifdef HAVE_CURL
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
enabled (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
"Warning: pipelining is disabled, because libcurl version darcs was "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "compiled with is too old (< 7.19.1)"
#endif
Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int -> IO (IORef Int)) -> Int -> IO (IORef Int)
forall a b. (a -> b) -> a -> b
$ if Bool
enabled then 100 else 1
maxPipelineLength :: IO Int
maxPipelineLength :: IO Int
maxPipelineLength = IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
maxPipelineLengthRef
{-# NOINLINE urlNotifications #-}
urlNotifications :: MVar (Map String (MVar (Maybe String)))
urlNotifications :: MVar (Map String (MVar (Maybe String)))
urlNotifications = IO (MVar (Map String (MVar (Maybe String))))
-> MVar (Map String (MVar (Maybe String)))
forall a. IO a -> a
unsafePerformIO (IO (MVar (Map String (MVar (Maybe String))))
-> MVar (Map String (MVar (Maybe String))))
-> IO (MVar (Map String (MVar (Maybe String))))
-> MVar (Map String (MVar (Maybe String)))
forall a b. (a -> b) -> a -> b
$ Map String (MVar (Maybe String))
-> IO (MVar (Map String (MVar (Maybe String))))
forall a. a -> IO (MVar a)
newMVar Map String (MVar (Maybe String))
forall k a. Map k a
Map.empty
{-# NOINLINE urlChan #-}
urlChan :: TChan UrlRequest
urlChan :: TChan UrlRequest
urlChan = IO (TChan UrlRequest) -> TChan UrlRequest
forall a. IO a -> a
unsafePerformIO (IO (TChan UrlRequest) -> TChan UrlRequest)
-> IO (TChan UrlRequest) -> TChan UrlRequest
forall a b. (a -> b) -> a -> b
$ do
TChan UrlRequest
ch <- IO (TChan UrlRequest)
forall a. IO (TChan a)
newTChanIO
ThreadId
_ <- IO () -> IO ThreadId
forkIO (TChan UrlRequest -> IO ()
urlThread TChan UrlRequest
ch)
TChan UrlRequest -> IO (TChan UrlRequest)
forall (m :: * -> *) a. Monad m => a -> m a
return TChan UrlRequest
ch
type UrlM a = StateT UrlState IO a
urlThread :: TChan UrlRequest -> IO ()
urlThread :: TChan UrlRequest -> IO ()
urlThread ch :: TChan UrlRequest
ch = do
String
junk <- (Integer -> String -> String) -> String -> Integer -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Integer -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex "" (Integer -> String) -> IO Integer -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Integer, Integer) -> IO Integer
forall a. Random a => (a, a) -> IO a
randomRIO (Integer, Integer)
rrange
StateT UrlState IO () -> UrlState -> IO ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT UrlState IO ()
urlThread' (Map String InProgressStatus
-> Q String -> Int -> String -> UrlState
UrlState Map String InProgressStatus
forall k a. Map k a
Map.empty Q String
forall a. Q a
emptyQ 0 String
junk)
where
rrange :: (Integer, Integer)
rrange = (0, 2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (128 :: Integer) :: Integer)
urlThread' :: UrlM ()
urlThread' :: StateT UrlState IO ()
urlThread' = do
Bool
empty <- IO Bool -> StateT UrlState IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> StateT UrlState IO Bool)
-> IO Bool -> StateT UrlState IO Bool
forall a b. (a -> b) -> a -> b
$ STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TChan UrlRequest -> STM Bool
forall a. TChan a -> STM Bool
isEmptyTChan TChan UrlRequest
ch
(l :: Int
l, w :: Q String
w) <- (UrlState -> Int
pipeLength (UrlState -> Int)
-> (UrlState -> Q String) -> UrlState -> (Int, Q String)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& UrlState -> Q String
waitToStart) (UrlState -> (Int, Q String))
-> StateT UrlState IO UrlState
-> StateT UrlState IO (Int, Q String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` StateT UrlState IO UrlState
forall s (m :: * -> *). MonadState s m => m s
get
[UrlRequest]
reqs <- if Bool -> Bool
not Bool
empty Bool -> Bool -> Bool
|| (Q String -> Bool
forall a. Q a -> Bool
nullQ Q String
w Bool -> Bool -> Bool
&& Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0)
then IO [UrlRequest] -> StateT UrlState IO [UrlRequest]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [UrlRequest]
readAllRequests
else [UrlRequest] -> StateT UrlState IO [UrlRequest]
forall (m :: * -> *) a. Monad m => a -> m a
return []
(UrlRequest -> StateT UrlState IO ())
-> [UrlRequest] -> StateT UrlState IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ UrlRequest -> StateT UrlState IO ()
addReq [UrlRequest]
reqs
StateT UrlState IO ()
checkWaitToStart
StateT UrlState IO ()
waitNextUrl
StateT UrlState IO ()
urlThread'
readAllRequests :: IO [UrlRequest]
readAllRequests :: IO [UrlRequest]
readAllRequests = do
UrlRequest
r <- STM UrlRequest -> IO UrlRequest
forall a. STM a -> IO a
atomically (STM UrlRequest -> IO UrlRequest)
-> STM UrlRequest -> IO UrlRequest
forall a b. (a -> b) -> a -> b
$ TChan UrlRequest -> STM UrlRequest
forall a. TChan a -> STM a
readTChan TChan UrlRequest
ch
String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "URL.urlThread (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UrlRequest -> String
url UrlRequest
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
"-> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UrlRequest -> String
file UrlRequest
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
Bool
empty <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TChan UrlRequest -> STM Bool
forall a. TChan a -> STM Bool
isEmptyTChan TChan UrlRequest
ch
[UrlRequest]
reqs <- if Bool -> Bool
not Bool
empty
then IO [UrlRequest]
readAllRequests
else [UrlRequest] -> IO [UrlRequest]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[UrlRequest] -> IO [UrlRequest]
forall (m :: * -> *) a. Monad m => a -> m a
return (UrlRequest
r UrlRequest -> [UrlRequest] -> [UrlRequest]
forall a. a -> [a] -> [a]
: [UrlRequest]
reqs)
addReq :: UrlRequest -> UrlM ()
addReq :: UrlRequest -> StateT UrlState IO ()
addReq (UrlRequest u :: String
u f :: String
f c :: Cachable
c p :: Priority
p) = do
Bool
d <- IO Bool -> StateT UrlState IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
alreadyDownloaded String
u)
if Bool
d
then String -> StateT UrlState IO ()
forall a. String -> StateT a IO ()
dbg "Ignoring UrlRequest of URL that is already downloaded."
else do
(ip :: Map String InProgressStatus
ip, wts :: Q String
wts) <- (UrlState -> Map String InProgressStatus
inProgress (UrlState -> Map String InProgressStatus)
-> (UrlState -> Q String)
-> UrlState
-> (Map String InProgressStatus, Q String)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& UrlState -> Q String
waitToStart) (UrlState -> (Map String InProgressStatus, Q String))
-> StateT UrlState IO UrlState
-> StateT UrlState IO (Map String InProgressStatus, Q String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` StateT UrlState IO UrlState
forall s (m :: * -> *). MonadState s m => m s
get
case String -> Map String InProgressStatus -> Maybe InProgressStatus
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
u Map String InProgressStatus
ip of
Nothing -> (UrlState -> UrlState) -> StateT UrlState IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((UrlState -> UrlState) -> StateT UrlState IO ())
-> (UrlState -> UrlState) -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ \st :: UrlState
st ->
UrlState
st { inProgress :: Map String InProgressStatus
inProgress = String
-> InProgressStatus
-> Map String InProgressStatus
-> Map String InProgressStatus
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
u (String
f, [], Cachable
c) Map String InProgressStatus
ip
, waitToStart :: Q String
waitToStart = Priority -> String -> Q String -> Q String
forall a. Priority -> a -> Q a -> Q a
addUsingPriority Priority
p String
u Q String
wts }
Just (f' :: String
f', fs' :: [String]
fs', c' :: Cachable
c') -> do
let new_c :: Cachable
new_c = Cachable -> Cachable -> Cachable
minCachable Cachable
c Cachable
c'
Bool -> StateT UrlState IO () -> StateT UrlState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Cachable
c Cachable -> Cachable -> Bool
forall a. Eq a => a -> a -> Bool
/= Cachable
c') (StateT UrlState IO () -> StateT UrlState IO ())
-> StateT UrlState IO () -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ do
let new_p :: Map String InProgressStatus
new_p = String
-> InProgressStatus
-> Map String InProgressStatus
-> Map String InProgressStatus
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
u (String
f', [String]
fs', Cachable
new_c) Map String InProgressStatus
ip
(UrlState -> UrlState) -> StateT UrlState IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\s :: UrlState
s -> UrlState
s { inProgress :: Map String InProgressStatus
inProgress = Map String InProgressStatus
new_p })
String -> StateT UrlState IO ()
forall a. String -> StateT a IO ()
dbg (String -> StateT UrlState IO ())
-> String -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ "Changing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ " request cachability from "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cachable -> String
forall a. Show a => a -> String
show Cachable
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ " to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cachable -> String
forall a. Show a => a -> String
show Cachable
new_c
Bool -> StateT UrlState IO () -> StateT UrlState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
u String -> Q String -> Bool
forall a. Eq a => a -> Q a -> Bool
`elemQ` Q String
wts Bool -> Bool -> Bool
&& Priority
p Priority -> Priority -> Bool
forall a. Eq a => a -> a -> Bool
== Priority
High) (StateT UrlState IO () -> StateT UrlState IO ())
-> StateT UrlState IO () -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ do
(UrlState -> UrlState) -> StateT UrlState IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((UrlState -> UrlState) -> StateT UrlState IO ())
-> (UrlState -> UrlState) -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ \s :: UrlState
s ->
UrlState
s { waitToStart :: Q String
waitToStart = String -> Q String -> Q String
forall a. a -> Q a -> Q a
pushQ String
u (String -> Q String -> Q String
forall a. Eq a => a -> Q a -> Q a
deleteQ String
u Q String
wts) }
String -> StateT UrlState IO ()
forall a. String -> StateT a IO ()
dbg (String -> StateT UrlState IO ())
-> String -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ "Moving " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ " to head of download queue."
if String
f String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (String
f' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
fs')
then do
let new_ip :: Map String InProgressStatus
new_ip = String
-> InProgressStatus
-> Map String InProgressStatus
-> Map String InProgressStatus
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
u (String
f', String
f String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
fs', Cachable
new_c) Map String InProgressStatus
ip
(UrlState -> UrlState) -> StateT UrlState IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\s :: UrlState
s -> UrlState
s { inProgress :: Map String InProgressStatus
inProgress = Map String InProgressStatus
new_ip })
String -> StateT UrlState IO ()
forall a. String -> StateT a IO ()
dbg "Adding new file to existing UrlRequest."
else String -> StateT UrlState IO ()
forall a. String -> StateT a IO ()
dbg (String -> StateT UrlState IO ())
-> String -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ "Ignoring UrlRequest of file that's "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "already queued."
alreadyDownloaded :: String -> IO Bool
alreadyDownloaded :: String -> IO Bool
alreadyDownloaded u :: String
u = do
Maybe (MVar (Maybe String))
n <- MVar (Map String (MVar (Maybe String)))
-> (Map String (MVar (Maybe String))
-> IO (Maybe (MVar (Maybe String))))
-> IO (Maybe (MVar (Maybe String)))
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (Map String (MVar (Maybe String)))
urlNotifications ((Map String (MVar (Maybe String))
-> IO (Maybe (MVar (Maybe String))))
-> IO (Maybe (MVar (Maybe String))))
-> (Map String (MVar (Maybe String))
-> IO (Maybe (MVar (Maybe String))))
-> IO (Maybe (MVar (Maybe String)))
forall a b. (a -> b) -> a -> b
$ Maybe (MVar (Maybe String)) -> IO (Maybe (MVar (Maybe String)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MVar (Maybe String)) -> IO (Maybe (MVar (Maybe String))))
-> (Map String (MVar (Maybe String))
-> Maybe (MVar (Maybe String)))
-> Map String (MVar (Maybe String))
-> IO (Maybe (MVar (Maybe String)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Map String (MVar (Maybe String)) -> Maybe (MVar (Maybe String))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
u
IO Bool
-> (MVar (Maybe String) -> IO Bool)
-> Maybe (MVar (Maybe String))
-> IO Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) (\v :: MVar (Maybe String)
v -> Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` MVar (Maybe String) -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar MVar (Maybe String)
v) Maybe (MVar (Maybe String))
n
checkWaitToStart :: UrlM ()
checkWaitToStart :: StateT UrlState IO ()
checkWaitToStart = do
UrlState
st <- StateT UrlState IO UrlState
forall s (m :: * -> *). MonadState s m => m s
get
let l :: Int
l = UrlState -> Int
pipeLength UrlState
st
Int
mpl <- IO Int -> StateT UrlState IO Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
maxPipelineLength
Bool -> StateT UrlState IO () -> StateT UrlState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
mpl) (StateT UrlState IO () -> StateT UrlState IO ())
-> StateT UrlState IO () -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$
case Q String -> Maybe (String, Q String)
forall a. Q a -> Maybe (a, Q a)
readQ (UrlState -> Q String
waitToStart UrlState
st) of
Nothing -> () -> StateT UrlState IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (u :: String
u, rest :: Q String
rest) -> do
case String -> Map String InProgressStatus -> Maybe InProgressStatus
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
u (UrlState -> Map String InProgressStatus
inProgress UrlState
st) of
Nothing -> String -> StateT UrlState IO ()
forall a. String -> a
bug (String -> StateT UrlState IO ())
-> String -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ "bug in URL.checkWaitToStart " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u
Just (f :: String
f, _, c :: Cachable
c) -> do
String -> StateT UrlState IO ()
forall a. String -> StateT a IO ()
dbg (String -> StateT UrlState IO ())
-> String -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ "URL.requestUrl (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
let f_new :: String
f_new = String -> UrlState -> String
createDownloadFileName String
f UrlState
st
String
err <- IO String -> StateT UrlState IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> StateT UrlState IO String)
-> IO String -> StateT UrlState IO String
forall a b. (a -> b) -> a -> b
$ String -> String -> Cachable -> IO String
requestUrl String
u String
f_new Cachable
c
if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
err
then do
IO () -> StateT UrlState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT UrlState IO ()) -> IO () -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
atexit (String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist String
f_new)
UrlState -> StateT UrlState IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (UrlState -> StateT UrlState IO ())
-> UrlState -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ UrlState
st { waitToStart :: Q String
waitToStart = Q String
rest
, pipeLength :: Int
pipeLength = Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 }
else do
String -> StateT UrlState IO ()
forall a. String -> StateT a IO ()
dbg (String -> StateT UrlState IO ())
-> String -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ "Failed to start download URL " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
IO () -> StateT UrlState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT UrlState IO ()) -> IO () -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist String
f_new
String -> String -> IO ()
downloadComplete String
u String
err
UrlState -> StateT UrlState IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (UrlState -> StateT UrlState IO ())
-> UrlState -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ UrlState
st { waitToStart :: Q String
waitToStart = Q String
rest }
StateT UrlState IO ()
checkWaitToStart
copyUrlFirst :: String -> FilePath -> Cachable -> IO ()
copyUrlFirst :: String -> String -> Cachable -> IO ()
copyUrlFirst = Priority -> String -> String -> Cachable -> IO ()
copyUrlWithPriority Priority
High
copyUrl :: String -> FilePath -> Cachable -> IO ()
copyUrl :: String -> String -> Cachable -> IO ()
copyUrl = Priority -> String -> String -> Cachable -> IO ()
copyUrlWithPriority Priority
Low
copyUrlWithPriority :: Priority -> String -> String -> Cachable -> IO ()
copyUrlWithPriority :: Priority -> String -> String -> Cachable -> IO ()
copyUrlWithPriority p :: Priority
p u :: String
u f :: String
f c :: Cachable
c = do
String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "URL.copyUrlWithPriority (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
MVar (Maybe String)
v <- IO (MVar (Maybe String))
forall a. IO (MVar a)
newEmptyMVar
Maybe (MVar (Maybe String))
old_mv <- MVar (Map String (MVar (Maybe String)))
-> (Map String (MVar (Maybe String))
-> IO
(Map String (MVar (Maybe String)), Maybe (MVar (Maybe String))))
-> IO (Maybe (MVar (Maybe String)))
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Map String (MVar (Maybe String)))
urlNotifications ((Map String (MVar (Maybe String)), Maybe (MVar (Maybe String)))
-> IO
(Map String (MVar (Maybe String)), Maybe (MVar (Maybe String)))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Map String (MVar (Maybe String)), Maybe (MVar (Maybe String)))
-> IO
(Map String (MVar (Maybe String)), Maybe (MVar (Maybe String))))
-> (Map String (MVar (Maybe String))
-> (Map String (MVar (Maybe String)), Maybe (MVar (Maybe String))))
-> Map String (MVar (Maybe String))
-> IO
(Map String (MVar (Maybe String)), Maybe (MVar (Maybe String)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (MVar (Maybe String)), Map String (MVar (Maybe String)))
-> (Map String (MVar (Maybe String)), Maybe (MVar (Maybe String)))
forall a b. (a, b) -> (b, a)
swap ((Maybe (MVar (Maybe String)), Map String (MVar (Maybe String)))
-> (Map String (MVar (Maybe String)), Maybe (MVar (Maybe String))))
-> (Map String (MVar (Maybe String))
-> (Maybe (MVar (Maybe String)), Map String (MVar (Maybe String))))
-> Map String (MVar (Maybe String))
-> (Map String (MVar (Maybe String)), Maybe (MVar (Maybe String)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
-> MVar (Maybe String)
-> MVar (Maybe String)
-> MVar (Maybe String))
-> String
-> MVar (Maybe String)
-> Map String (MVar (Maybe String))
-> (Maybe (MVar (Maybe String)), Map String (MVar (Maybe String)))
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
Map.insertLookupWithKey (\_k :: String
_k _n :: MVar (Maybe String)
_n old :: MVar (Maybe String)
old -> MVar (Maybe String)
old) String
u MVar (Maybe String)
v)
case Maybe (MVar (Maybe String))
old_mv of
Nothing -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan UrlRequest -> UrlRequest -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan UrlRequest
urlChan (UrlRequest -> STM ()) -> UrlRequest -> STM ()
forall a b. (a -> b) -> a -> b
$ String -> String -> Cachable -> Priority -> UrlRequest
UrlRequest String
u String
f Cachable
c Priority
p
Just _ -> String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "URL.copyUrlWithPriority already in progress, skip (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
createDownloadFileName :: FilePath -> UrlState -> FilePath
createDownloadFileName :: String -> UrlState -> String
createDownloadFileName f :: String
f st :: UrlState
st = String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-new_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UrlState -> String
randomJunk UrlState
st
waitNextUrl :: UrlM ()
waitNextUrl :: StateT UrlState IO ()
waitNextUrl = do
UrlState
st <- StateT UrlState IO UrlState
forall s (m :: * -> *). MonadState s m => m s
get
let l :: Int
l = UrlState -> Int
pipeLength UrlState
st
Bool -> StateT UrlState IO () -> StateT UrlState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (StateT UrlState IO () -> StateT UrlState IO ())
-> StateT UrlState IO () -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> StateT UrlState IO ()
forall a. String -> StateT a IO ()
dbg "URL.waitNextUrl start"
(u :: String
u, e :: String
e, ce :: Maybe ConnectionError
ce) <- IO (String, String, Maybe ConnectionError)
-> StateT UrlState IO (String, String, Maybe ConnectionError)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (String, String, Maybe ConnectionError)
waitNextUrl'
let p :: Map String InProgressStatus
p = UrlState -> Map String InProgressStatus
inProgress UrlState
st
IO () -> StateT UrlState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT UrlState IO ()) -> IO () -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ case String -> Map String InProgressStatus -> Maybe InProgressStatus
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
u Map String InProgressStatus
p of
Nothing ->
String -> IO ()
forall a. String -> a
bug (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "bug in URL.waitNextUrl: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u
Just (f :: String
f, fs :: [String]
fs, _) -> if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
e
then do
String -> String -> IO ()
renameFile (String -> UrlState -> String
createDownloadFileName String
f UrlState
st) String
f
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UrlState -> String -> String -> IO ()
safeCopyFile UrlState
st String
f) [String]
fs
String -> String -> IO ()
downloadComplete String
u String
e
String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
"URL.waitNextUrl succeeded: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f
else do
String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist (String -> UrlState -> String
createDownloadFileName String
f UrlState
st)
String -> String -> IO ()
downloadComplete String
u (String
-> (ConnectionError -> String) -> Maybe ConnectionError -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
e ConnectionError -> String
forall a. Show a => a -> String
show Maybe ConnectionError
ce)
String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
"URL.waitNextUrl failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e
Bool -> StateT UrlState IO () -> StateT UrlState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
u) (StateT UrlState IO () -> StateT UrlState IO ())
-> (UrlState -> StateT UrlState IO ())
-> UrlState
-> StateT UrlState IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UrlState -> StateT UrlState IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (UrlState -> StateT UrlState IO ())
-> UrlState -> StateT UrlState IO ()
forall a b. (a -> b) -> a -> b
$ UrlState
st { inProgress :: Map String InProgressStatus
inProgress = String
-> Map String InProgressStatus -> Map String InProgressStatus
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete String
u Map String InProgressStatus
p
, pipeLength :: Int
pipeLength = Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 }
where
safeCopyFile :: UrlState -> String -> String -> IO ()
safeCopyFile st :: UrlState
st f :: String
f t :: String
t = do
let new_t :: String
new_t = String -> UrlState -> String
createDownloadFileName String
t UrlState
st
String -> String -> IO ()
copyFile String
f String
new_t
String -> String -> IO ()
renameFile String
new_t String
t
downloadComplete :: String -> String -> IO ()
downloadComplete :: String -> String -> IO ()
downloadComplete u :: String
u e :: String
e = do
Maybe (MVar (Maybe String))
r <- MVar (Map String (MVar (Maybe String)))
-> (Map String (MVar (Maybe String))
-> IO (Maybe (MVar (Maybe String))))
-> IO (Maybe (MVar (Maybe String)))
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (Map String (MVar (Maybe String)))
urlNotifications (Maybe (MVar (Maybe String)) -> IO (Maybe (MVar (Maybe String)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MVar (Maybe String)) -> IO (Maybe (MVar (Maybe String))))
-> (Map String (MVar (Maybe String))
-> Maybe (MVar (Maybe String)))
-> Map String (MVar (Maybe String))
-> IO (Maybe (MVar (Maybe String)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Map String (MVar (Maybe String)) -> Maybe (MVar (Maybe String))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
u)
case Maybe (MVar (Maybe String))
r of
Just notifyVar :: MVar (Maybe String)
notifyVar ->
MVar (Maybe String) -> Maybe String -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe String)
notifyVar (Maybe String -> IO ()) -> Maybe String -> IO ()
forall a b. (a -> b) -> a -> b
$ if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
e then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
e
Nothing -> String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "downloadComplete URL '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' downloaded several times"
waitUrl :: String -> IO ()
waitUrl :: String -> IO ()
waitUrl u :: String
u = do
String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "URL.waitUrl " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u
Maybe (MVar (Maybe String))
r <- MVar (Map String (MVar (Maybe String)))
-> (Map String (MVar (Maybe String))
-> IO (Maybe (MVar (Maybe String))))
-> IO (Maybe (MVar (Maybe String)))
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (Map String (MVar (Maybe String)))
urlNotifications (Maybe (MVar (Maybe String)) -> IO (Maybe (MVar (Maybe String)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MVar (Maybe String)) -> IO (Maybe (MVar (Maybe String))))
-> (Map String (MVar (Maybe String))
-> Maybe (MVar (Maybe String)))
-> Map String (MVar (Maybe String))
-> IO (Maybe (MVar (Maybe String)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Map String (MVar (Maybe String)) -> Maybe (MVar (Maybe String))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
u)
case Maybe (MVar (Maybe String))
r of
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just var :: MVar (Maybe String)
var -> do
Maybe String
mbErr <- MVar (Maybe String) -> IO (Maybe String)
forall a. MVar a -> IO a
readMVar MVar (Maybe String)
var
MVar (Map String (MVar (Maybe String)))
-> (Map String (MVar (Maybe String))
-> IO (Map String (MVar (Maybe String))))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map String (MVar (Maybe String)))
urlNotifications (Map String (MVar (Maybe String))
-> IO (Map String (MVar (Maybe String)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map String (MVar (Maybe String))
-> IO (Map String (MVar (Maybe String))))
-> (Map String (MVar (Maybe String))
-> Map String (MVar (Maybe String)))
-> Map String (MVar (Maybe String))
-> IO (Map String (MVar (Maybe String)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Map String (MVar (Maybe String))
-> Map String (MVar (Maybe String))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete String
u)
((String -> IO ()) -> Maybe String -> IO ())
-> Maybe String -> (String -> IO ()) -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())) Maybe String
mbErr ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \e :: String
e -> do
String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Failed to download URL " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e
String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
dbg :: String -> StateT a IO ()
dbg :: String -> StateT a IO ()
dbg = IO () -> StateT a IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT a IO ())
-> (String -> IO ()) -> String -> StateT a IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
debugMessage
minCachable :: Cachable -> Cachable -> Cachable
minCachable :: Cachable -> Cachable -> Cachable
minCachable Uncachable _ = Cachable
Uncachable
minCachable _ Uncachable = Cachable
Uncachable
minCachable (MaxAge a :: CInt
a) (MaxAge b :: CInt
b) = CInt -> Cachable
MaxAge (CInt -> Cachable) -> CInt -> Cachable
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> CInt
forall a. Ord a => a -> a -> a
min CInt
a CInt
b
minCachable (MaxAge a :: CInt
a) _ = CInt -> Cachable
MaxAge CInt
a
minCachable _ (MaxAge b :: CInt
b) = CInt -> Cachable
MaxAge CInt
b
minCachable _ _ = Cachable
Cachable
disableHTTPPipelining :: IO ()
disableHTTPPipelining :: IO ()
disableHTTPPipelining = IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
maxPipelineLengthRef 1
setDebugHTTP :: IO ()
requestUrl :: String -> FilePath -> Cachable -> IO String
waitNextUrl' :: IO (String, String, Maybe ConnectionError)
pipeliningEnabled :: IO Bool
#ifdef HAVE_CURL
setDebugHTTP :: IO ()
setDebugHTTP = IO ()
Curl.setDebugHTTP
requestUrl :: String -> String -> Cachable -> IO String
requestUrl = String -> String -> Cachable -> IO String
Curl.requestUrl
waitNextUrl' :: IO (String, String, Maybe ConnectionError)
waitNextUrl' = IO (String, String, Maybe ConnectionError)
Curl.waitNextUrl
pipeliningEnabled :: IO Bool
pipeliningEnabled = IO Bool
Curl.pipeliningEnabled
#else
setDebugHTTP = return ()
requestUrl = HTTP.requestUrl
waitNextUrl' = HTTP.waitNextUrl
pipeliningEnabled = return False
#endif
environmentHelpProxy :: ([String], [String])
environmentHelpProxy :: ([String], [String])
environmentHelpProxy =
( [ "HTTP_PROXY", "HTTPS_PROXY", "FTP_PROXY", "ALL_PROXY", "NO_PROXY"]
, [ "If Darcs was built with libcurl, the environment variables"
, "HTTP_PROXY, HTTPS_PROXY and FTP_PROXY can be set to the URL of a"
, "proxy in the form"
, ""
, " [protocol://]<host>[:port]"
, ""
, "In which case libcurl will use the proxy for the associated protocol"
, "(HTTP, HTTPS and FTP). The environment variable ALL_PROXY can be used"
, "to set a single proxy for all libcurl requests."
, ""
, "If the environment variable NO_PROXY is a comma-separated list of"
, "host names, access to those hosts will bypass proxies defined by the"
, "above variables. For example, it is quite common to avoid proxying"
, "requests to machines on the local network with"
, ""
, " NO_PROXY=localhost,*.localdomain"
, ""
, "For compatibility with lynx et al, lowercase equivalents of these"
, "environment variables (e.g. $http_proxy) are also understood and are"
, "used in preference to the uppercase versions."
, ""
, "If Darcs was not built with libcurl, all these environment variables"
, "are silently ignored, and there is no way to use a web proxy."
]
)
environmentHelpProxyPassword :: ([String], [String])
environmentHelpProxyPassword :: ([String], [String])
environmentHelpProxyPassword =
( [ "DARCS_PROXYUSERPWD" ]
, [ "If Darcs was built with libcurl, and you are using a web proxy that"
, "requires authentication, you can set the $DARCS_PROXYUSERPWD"
, "environment variable to the username and password expected by the"
, "proxy, separated by a colon. This environment variable is silently"
, "ignored if Darcs was not built with libcurl."
]
)