{-# OPTIONS_GHC -cpp -fffi #-}
module URL ( copyUrl, copyUrlFirst, waitUrl,
Cachable(Cachable, Uncachable, MaxAge)
) where
import Data.IORef
import Data.Map ( Map )
import Data.List ( delete )
import qualified Data.Map as Map
import System.IO.Unsafe ( unsafePerformIO )
import Control.Monad ( when )
import Autoconf ( have_libwww )
import Foreign.C.Types ( CInt )
import Foreign.C.String ( withCString, peekCString, CString )
import Workaround ( renameFile )
import Darcs.Progress ( debugMessage, debugFail )
import Darcs.Global ( atexit )
import Darcs.Lock ( removeFileMayNotExist )
#if !defined(HAVE_CURL) || !defined(HAVE_LIBWWW)
import Foreign.Ptr ( nullPtr )
#endif
#include "impossible.h"
data Cachable = Cachable | Uncachable | MaxAge !CInt deriving Eq
data UrlState = UrlState { inProgress :: Map String FilePath,
waitToStart :: Q (String, String, Cachable),
pipeLength :: Int
}
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 [] []
data Priority = High | Low deriving Eq
maxPipeLength :: Int
maxPipeLength = if have_libwww then 100
#ifdef CURL_PIPELINING
else 100
#else
else 1
#endif
urlState :: IORef UrlState
urlState = unsafePerformIO $ newIORef (UrlState Map.empty emptyQ 0)
copyUrlWithPriority :: Priority -> String -> String -> Cachable -> IO ()
copyUrlWithPriority prio url file c = do
st <- readIORef urlState
let p = inProgress st
w = waitToStart st
new_w = case prio of
High -> pushQ (url, file, c) w
Low -> insertQ (url, file, c) w
new_st = st { inProgress = Map.insert url file p,
waitToStart = new_w
}
if Map.member url p
then if prio == High && (url, file, c) `elemQ` w
then do writeIORef urlState (st { waitToStart = pushQ (url, file, c) (deleteQ (url, file, c) w) })
debugMessage $ "Moving "++url++" to head of download queue."
checkWaitToStart
else debugMessage "Ignoring copyUrlWithPriority of file that's already queued."
else do writeIORef urlState new_st
checkWaitToStart
copyUrlFirst :: String -> String -> Cachable -> IO ()
copyUrlFirst = copyUrlWithPriority High
copyUrl :: String -> String -> Cachable -> IO ()
copyUrl = copyUrlWithPriority Low
waitNextUrl :: IO (String, Maybe String)
waitNextUrl = do st <- readIORef urlState
let l = pipeLength st
if l > 0
then do err <- waitNextUrl'
url <- lastUrl'
let p = inProgress st
new_st = st { inProgress = Map.delete url p,
pipeLength = l - 1
}
if null err
then
case Map.lookup url p of
Just f -> do renameFile (f++"-new") f
debugMessage $ "URL.waitNextUrl succeeded: "++url++" "++f
Nothing -> bug $ "Possible bug in URL.waitNextUrl: "++url
else when (not $ null url) $ case Map.lookup url p of
Just f -> do removeFileMayNotExist (f++"-new")
debugMessage $ "URL.waitNextUrl failed: "++
url++" "++f++" "++err
Nothing -> bug $ "Another possible bug in URL.waitNextUrl: "++url++" "++err
when (not $ null url) $ do
writeIORef urlState new_st
checkWaitToStart
return (url, if null err then Nothing else Just err)
else return ("", Nothing)
where waitNextUrl' = do let fn = if have_libwww then libwww_wait_next_url
else curl_wait_next_url
err <- fn >>= peekCString
return err
lastUrl' = let fn = if have_libwww then libwww_last_url
else curl_last_url
in fn >>= peekCString
waitUrl :: String -> IO ()
waitUrl u = do st <- readIORef urlState
when (u `Map.member` inProgress st) waitUrl'
debugMessage ("URL.waitUrl "++u++" succeeded")
where waitUrl' = do (url, merr) <- waitNextUrl
if u /= url
then waitUrl'
else case merr of
Just err -> debugFail $ "Failed to download URL "++url++": "++err
Nothing -> return ()
checkWaitToStart :: IO ()
checkWaitToStart = do st <- readIORef urlState
let l = pipeLength st
when (l < maxPipeLength) $
do let w = waitToStart st
case readQ w of
Just ((u,f,c),rest) -> do
let new_st = st { waitToStart = rest,
pipeLength = l + 1
}
writeIORef urlState new_st
err <- copyUrl' u f c
when (not $ null err) (debugFail $ "Failed to start download URL "
++u++": "++err)
checkWaitToStart
_ -> return ()
where copyUrl' u f cache = withCString u $ \ustr ->
withCString (f++"-new") $ \fstr -> do
atexit $ removeFileMayNotExist (f++"-new")
debugMessage ("URL.copyUrl ("++u++"\n"++
" -> "++f++")")
let fn = if have_libwww then libwww_request_url
else curl_request_url
err <- fn ustr fstr (cachableToInt cache) >>= peekCString
when (null err) (debugMessage "URL.copyUrl succeeded")
return err
cachableToInt :: Cachable -> CInt
cachableToInt Cachable = -1
cachableToInt Uncachable = 0
cachableToInt (MaxAge n) = n
#ifdef HAVE_CURL
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
#else
no_curl :: IO ()
no_curl = debugFail "There is no libcurl!"
curl_request_url :: CString -> CString -> CInt -> IO CString
curl_request_url _ _ _ = no_curl >> return nullPtr
curl_wait_next_url :: IO CString
curl_wait_next_url = no_curl >> return nullPtr
curl_last_url :: IO CString
curl_last_url = no_curl >> return nullPtr
#endif
#ifdef HAVE_LIBWWW
foreign import ccall "hslibwww.h libwww_request_url"
libwww_request_url :: CString -> CString -> CInt -> IO CString
foreign import ccall "hslibwww.h libwww_wait_next_url"
libwww_wait_next_url :: IO CString
foreign import ccall "hslibwww.h libwww_last_url"
libwww_last_url :: IO CString
#else
no_libwww :: IO ()
no_libwww = debugFail "There is no libwww!"
libwww_request_url :: CString -> CString -> CInt -> IO CString
libwww_request_url _ _ _ = no_libwww >> return nullPtr
libwww_wait_next_url :: IO CString
libwww_wait_next_url = no_libwww >> return nullPtr
libwww_last_url :: IO CString
libwww_last_url = no_libwww >> return nullPtr
#endif