module URL ( copyUrl, copyUrlFirst, setDebugHTTP,
disableHTTPPipelining, maxPipelineLength,
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 ( requestUrl, waitNextUrl )
#endif
#include "impossible.h"
data UrlRequest = UrlRequest { url :: String
, file :: FilePath
, cachable :: Cachable
, priority :: Priority }
data Cachable = Cachable | Uncachable | MaxAge !CInt
deriving (Show, Eq)
data UrlState = UrlState { inProgress :: Map String ( FilePath
, [FilePath]
, Cachable )
, 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
maxPipelineLengthRef :: IORef Int
maxPipelineLengthRef = unsafePerformIO $ do
enabled <- pipeliningEnabled
#ifdef HAVE_CURL
when (not enabled) (debugMessage $
"Warning: pipelining is disabled, because libcurl "++
"version darcs was compiled with is too old (< 7.19.1)")
#endif
newIORef $ if enabled then 100 else 1
maxPipelineLength :: IO Int
maxPipelineLength = readIORef maxPipelineLengthRef
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)
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') -> do
let new_c = minCachable c c'
when (c /= c') $ let new_p = Map.insert u (f', fs', new_c) 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) 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 maxPipelineLength
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) -> do
dbg ("URL.requestUrl ("++u++"\n"++
" -> "++f++")")
let f_new = f++"-new_"++randomJunk st
err <- liftIO $ requestUrl u f_new c
if null err
then do dbg "URL.requestUrl 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
downloadComplete u 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
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 $ waitNextUrl'
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, _) -> do
renameFile (f++"-new_"++randomJunk st) f
mapM_ (safeCopyFile st f) fs
downloadComplete u e
debugMessage $ "URL.waitNextUrl succeeded: "++u++" "++f
Nothing -> bug $ "Possible bug in URL.waitNextUrl: "++u
else case Map.lookup u p of
Just (f, _, _) -> do
removeFileMayNotExist (f++"-new_"++randomJunk st)
downloadComplete u 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
downloadComplete :: String -> String -> IO ()
downloadComplete u e = do
r <- withMVar urlNotifications (return . (Map.lookup u))
case r of
Just notifyVar -> putMVar notifyVar e
Nothing -> debugMessage $ "downloadComplete URL '"++u++"' downloaded several times"
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
disableHTTPPipelining :: IO ()
disableHTTPPipelining = writeIORef maxPipelineLengthRef 1
setDebugHTTP :: IO ()
requestUrl :: String -> FilePath -> Cachable -> IO String
waitNextUrl' :: IO (String, String)
pipeliningEnabled :: IO Bool
#ifdef HAVE_CURL
setDebugHTTP = curl_enable_debug
requestUrl u f cache =
withCString u $ \ustr ->
withCString f $ \fstr -> do
err <- curl_request_url ustr fstr (cachableToInt cache) >>= peekCString
return err
waitNextUrl' = do
e <- curl_wait_next_url >>= peekCString
u <- curl_last_url >>= peekCString
return (u, e)
pipeliningEnabled = do
r <- curl_pipelining_enabled
return $ r /= 0
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 ()
foreign import ccall "hscurl.h curl_pipelining_enabled"
curl_pipelining_enabled :: IO CInt
#elif defined(HAVE_HTTP)
setDebugHTTP = return ()
requestUrl = HTTP.requestUrl
waitNextUrl' = HTTP.waitNextUrl
pipeliningEnabled = return False
#else
setDebugHTTP = debugMessage "URL.setDebugHttp works only with libcurl"
requestUrl _ _ _ = debugFail "URL.requestUrl: there is no libcurl!"
waitNextUrl' = debugFail "URL.waitNextUrl': there is no libcurl!"
pipeliningEnabled = return False
#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."])