module URL ( copyUrl, copyUrlFirst, pipeliningEnabledByDefault,
setDebugHTTP, setHTTPPipelining, waitUrl,
Cachable(Cachable, Uncachable, MaxAge),
environmentHelpProxy, environmentHelpProxyPassword
) where
import Data.IORef ( newIORef, readIORef, writeIORef, IORef )
import Data.Map ( Map )
import Data.List ( delete )
import qualified Data.Map as Map
import System.Directory ( copyFile )
import System.IO.Unsafe ( unsafePerformIO )
import Control.Concurrent ( forkIO )
import Control.Concurrent.Chan ( isEmptyChan, newChan, readChan, writeChan, Chan )
import Control.Concurrent.MVar ( isEmptyMVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, readMVar, withMVar, MVar )
import Control.Monad ( unless, when )
import Control.Monad.Trans ( liftIO )
import Control.Monad.State ( evalStateT, get, modify, put, StateT )
import Foreign.C.Types ( CInt )
import Workaround ( renameFile )
import Darcs.Global ( atexit )
import Progress ( debugFail, debugMessage )
import Darcs.Lock ( removeFileMayNotExist )
import Numeric ( showHex )
import System.Random ( randomRIO )
#ifdef HAVE_CURL
import Foreign.C.String ( withCString, peekCString, CString )
#else
import qualified HTTP ( request_url, wait_next_url )
#endif
#include "impossible.h"
data UrlRequest = UrlRequest { url :: String
, file :: FilePath
, cachable :: Cachable
, priority :: Priority
, notifyVar :: MVar String }
data Cachable = Cachable | Uncachable | MaxAge !CInt
deriving (Show, Eq)
data UrlState = UrlState { inProgress :: Map String ( FilePath
, [FilePath]
, Cachable
, (MVar String) )
, waitToStart :: Q String
, pipeLength :: Int
, randomJunk :: String }
data Q a = Q [a] [a]
readQ :: Q a -> Maybe (a, Q a)
readQ (Q (x:xs) ys) = Just (x, Q xs ys)
readQ (Q [] ys) = do x:xs <- Just $ reverse ys
Just (x, Q xs [])
insertQ :: a -> Q a -> Q a
insertQ y (Q xs ys) = Q xs (y:ys)
pushQ :: a -> Q a -> Q a
pushQ x (Q xs ys) = Q (x:xs) ys
deleteQ :: Eq a => a -> Q a -> Q a
deleteQ x (Q xs ys) = Q (delete x xs) (delete x ys)
elemQ :: Eq a => a -> Q a -> Bool
elemQ x (Q xs ys) = x `elem` xs || x `elem` ys
emptyQ :: Q a
emptyQ = Q [] []
nullQ :: Q a -> Bool
nullQ (Q [] []) = True
nullQ _ = False
data Priority = High | Low deriving Eq
#if defined(CURL_PIPELINING) || defined(CURL_PIPELINING_DEFAULT)
pipeliningLimit :: Int
pipeliningLimit = 100
#endif
pipeliningEnabledByDefault :: Bool
#ifdef CURL_PIPELINING_DEFAULT
pipeliningEnabledByDefault = True
#else
pipeliningEnabledByDefault = False
#endif
maxPipeLength :: IORef Int
maxPipeLength = unsafePerformIO $ newIORef $
#ifdef CURL_PIPELINING_DEFAULT
pipeliningLimit
#else
1
#endif
urlNotifications :: MVar (Map String (MVar String))
urlNotifications = unsafePerformIO $ newMVar Map.empty
urlChan :: Chan UrlRequest
urlChan = unsafePerformIO $ do
ch <- newChan
forkIO (urlThread ch)
return ch
urlThread :: Chan UrlRequest -> IO ()
urlThread ch = do junk <- flip showHex "" `fmap` randomRIO rrange
evalStateT urlThread' (UrlState Map.empty emptyQ 0 junk)
where rrange = (0, 2^(128 :: Integer) :: Integer)
urlThread' = do
empty <- liftIO $ isEmptyChan ch
st <- get
let l = pipeLength st
w = waitToStart st
reqs <- if not empty || (nullQ w && l == 0)
then liftIO readAllRequests
else return []
mapM_ addReq reqs
checkWaitToStart
waitNextUrl
urlThread'
readAllRequests = do
r <- readChan ch
debugMessage $ "URL.urlThread ("++url r++"\n"++
" -> "++file r++")"
empty <- isEmptyChan ch
reqs <- if not empty
then readAllRequests
else return []
return (r:reqs)
addReq r = do
let u = url r
f = file r
c = cachable r
d <- liftIO $ alreadyDownloaded u
if d
then dbg "Ignoring UrlRequest of URL that is already downloaded."
else do
st <- get
let p = inProgress st
w = waitToStart st
e = (f, [], c, notifyVar r)
new_w = case priority r of
High -> pushQ u w
Low -> insertQ u w
new_st = st { inProgress = Map.insert u e p
, waitToStart = new_w }
case Map.lookup u p of
Just (f', fs', c', v) -> do
let new_c = minCachable c c'
when (c /= c') $ let new_p = Map.insert u (f', fs', new_c, v) p
in do modify (\s -> s { inProgress = new_p })
dbg $ "Changing "++u++" request cachability from "++show c++" to "++show new_c
when (u `elemQ` w && priority r == High) $ do
modify (\s -> s { waitToStart = pushQ u (deleteQ u w) })
dbg $ "Moving "++u++" to head of download queue."
if f `notElem` (f':fs')
then let new_p = Map.insert u (f', f:fs', new_c, v) p
in do modify (\s -> s { inProgress = new_p })
dbg "Adding new file to existing UrlRequest."
else dbg "Ignoring UrlRequest of file that's already queued."
_ -> put new_st
alreadyDownloaded u = do
n <- liftIO $ withMVar urlNotifications (return . (Map.lookup u))
case n of
Just v -> not `fmap` isEmptyMVar v
Nothing -> return True
checkWaitToStart :: StateT UrlState IO ()
checkWaitToStart = do
st <- get
let l = pipeLength st
mpl <- liftIO $ readIORef maxPipeLength
when (l < mpl) $ do
let w = waitToStart st
case readQ w of
Just (u,rest) -> do
case Map.lookup u (inProgress st) of
Just (f, _, c, v) -> do
dbg ("URL.request_url ("++u++"\n"++
" -> "++f++")")
let f_new = f++"-new_"++randomJunk st
err <- liftIO $ request_url u f_new c
if null err
then do dbg "URL.request_url succeeded"
liftIO $ atexit (removeFileMayNotExist f_new)
put $ st { waitToStart = rest
, pipeLength = l + 1 }
else do dbg $ "Failed to start download URL "++u++": "++err
liftIO $ do removeFileMayNotExist f_new
putMVar v err
put $ st { waitToStart = rest }
_ -> bug $ "Possible bug in URL.checkWaitToStart "++u
checkWaitToStart
_ -> return ()
copyUrlFirst :: String -> FilePath -> Cachable -> IO ()
copyUrlFirst = copyUrlWithPriority High
copyUrl :: String -> FilePath -> Cachable -> IO ()
copyUrl = copyUrlWithPriority Low
copyUrlWithPriority :: Priority -> String -> String -> Cachable -> IO ()
copyUrlWithPriority p u f c = do
debugMessage ("URL.copyUrlWithPriority ("++u++"\n"++
" -> "++f++")")
v <- newEmptyMVar
let fn _ old_val = old_val
modifyMVar_ urlNotifications (return . (Map.insertWith fn u v))
let r = UrlRequest u f c p v
writeChan urlChan r
waitNextUrl :: StateT UrlState IO ()
waitNextUrl = do
st <- get
let l = pipeLength st
when (l > 0) $ do
dbg "URL.waitNextUrl start"
(u, e) <- liftIO $ wait_next_url
let p = inProgress st
new_st = st { inProgress = Map.delete u p
, pipeLength = l 1 }
liftIO $ if null e
then case Map.lookup u p of
Just (f, fs, _, v) -> do
renameFile (f++"-new_"++randomJunk st) f
mapM_ (safeCopyFile st f) fs
putMVar v e
debugMessage $ "URL.waitNextUrl succeeded: "++u++" "++f
Nothing -> bug $ "Possible bug in URL.waitNextUrl: "++u
else case Map.lookup u p of
Just (f, _, _, v) -> do
removeFileMayNotExist (f++"-new_"++randomJunk st)
putMVar v e
debugMessage $ "URL.waitNextUrl failed: "++
u++" "++f++" "++e
Nothing -> bug $ "Another possible bug in URL.waitNextUrl: "++u++" "++e
unless (null u) $ put new_st
where safeCopyFile st f t = let new_t = t++"-new_"++randomJunk st
in do copyFile f new_t
renameFile new_t t
waitUrl :: String -> IO ()
waitUrl u = do debugMessage $ "URL.waitUrl "++u
r <- withMVar urlNotifications (return . (Map.lookup u))
case r of
Just var -> do
e <- readMVar var
modifyMVar_ urlNotifications (return . (Map.delete u))
unless (null e) (debugFail $ "Failed to download URL "++u++": "++e)
Nothing -> return ()
dbg :: String -> StateT a IO ()
dbg = liftIO . debugMessage
minCachable :: Cachable -> Cachable -> Cachable
minCachable Uncachable _ = Uncachable
minCachable _ Uncachable = Uncachable
minCachable (MaxAge a) (MaxAge b) = MaxAge $ min a b
minCachable (MaxAge a) _ = MaxAge a
minCachable _ (MaxAge b) = MaxAge b
minCachable _ _ = Cachable
#ifdef HAVE_CURL
cachableToInt :: Cachable -> CInt
cachableToInt Cachable = 1
cachableToInt Uncachable = 0
cachableToInt (MaxAge n) = n
#endif
setHTTPPipelining :: Bool -> IO ()
setHTTPPipelining False = writeIORef maxPipeLength 1
setHTTPPipelining True = writeIORef maxPipeLength
#ifdef CURL_PIPELINING
pipeliningLimit
#else
1 >> (putStrLn $ "Warning: darcs is compiled without HTTP pipelining "++
"support, '--http-pipelining' argument is ignored.")
#endif
setDebugHTTP :: IO ()
request_url :: String -> FilePath -> Cachable -> IO String
wait_next_url :: IO (String, String)
#ifdef HAVE_CURL
setDebugHTTP = curl_enable_debug
request_url u f cache =
withCString u $ \ustr ->
withCString f $ \fstr -> do
err <- curl_request_url ustr fstr (cachableToInt cache) >>= peekCString
return err
wait_next_url = do
e <- curl_wait_next_url >>= peekCString
u <- curl_last_url >>= peekCString
return (u, e)
foreign import ccall "hscurl.h curl_request_url"
curl_request_url :: CString -> CString -> CInt -> IO CString
foreign import ccall "hscurl.h curl_wait_next_url"
curl_wait_next_url :: IO CString
foreign import ccall "hscurl.h curl_last_url"
curl_last_url :: IO CString
foreign import ccall "hscurl.h curl_enable_debug"
curl_enable_debug :: IO ()
#elif defined(HAVE_HTTP)
setDebugHTTP = return ()
request_url = HTTP.request_url
wait_next_url = HTTP.wait_next_url
#else
setDebugHTTP = debugMessage "URL.setDebugHttp works only with libcurl"
request_url _ _ _ = debugFail "URL.request_url: there is no libcurl!"
wait_next_url = debugFail "URL.wait_next_url: there is no libcurl!"
#endif
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 = (["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."])