{-# LANGUAGE CPP, ForeignFunctionInterface #-}moduleURL(copyUrl,copyUrlFirst,setDebugHTTP,disableHTTPPipelining,maxPipelineLength,waitUrl,Cachable(Cachable,Uncachable,MaxAge),environmentHelpProxy,environmentHelpProxyPassword)whereimportData.IORef(newIORef,readIORef,writeIORef,IORef)importData.Map(Map)importData.List(delete)importqualifiedData.MapasMapimportSystem.Directory(copyFile)importSystem.IO.Unsafe(unsafePerformIO)importControl.Concurrent(forkIO)importControl.Concurrent.Chan(isEmptyChan,newChan,readChan,writeChan,Chan)importControl.Concurrent.MVar(isEmptyMVar,modifyMVar_,newEmptyMVar,newMVar,putMVar,readMVar,withMVar,MVar)importControl.Monad(unless,when)importControl.Monad.Trans(liftIO)importControl.Monad.State(evalStateT,get,modify,put,StateT)importForeign.C.Types(CInt)importWorkaround(renameFile)importDarcs.Global(atexit)importProgress(debugFail,debugMessage)importDarcs.Lock(removeFileMayNotExist)importNumeric(showHex)importSystem.Random(randomRIO)#ifdef HAVE_CURLimportForeign.C.String(withCString,peekCString,CString)#elseimportqualifiedHTTP(requestUrl,waitNextUrl)#endif#include "impossible.h"dataUrlRequest=UrlRequest{url::String,file::FilePath,cachable::Cachable,priority::Priority}dataCachable=Cachable|Uncachable|MaxAge!CIntderiving(Show,Eq)dataUrlState=UrlState{inProgress::MapString(FilePath,[FilePath],Cachable),waitToStart::QString,pipeLength::Int,randomJunk::String}dataQa=Q[a][a]readQ::Qa->Maybe(a,Qa)readQ(Q(x:xs)ys)=Just(x,Qxsys)readQ(Q[]ys)=dox:xs<-Just$reverseysJust(x,Qxs[])insertQ::a->Qa->QainsertQy(Qxsys)=Qxs(y:ys)pushQ::a->Qa->QapushQx(Qxsys)=Q(x:xs)ysdeleteQ::Eqa=>a->Qa->QadeleteQx(Qxsys)=Q(deletexxs)(deletexys)elemQ::Eqa=>a->Qa->BoolelemQx(Qxsys)=x`elem`xs||x`elem`ysemptyQ::QaemptyQ=Q[][]nullQ::Qa->BoolnullQ(Q[][])=TruenullQ_=FalsedataPriority=High|LowderivingEq{-# NOINLINE maxPipelineLengthRef #-}maxPipelineLengthRef::IORefIntmaxPipelineLengthRef=unsafePerformIO$doenabled<-pipeliningEnabled#ifdef HAVE_CURLwhen(notenabled)(debugMessage$"Warning: pipelining is disabled, because libcurl "++"version darcs was compiled with is too old (< 7.19.1)")#endifnewIORef$ifenabledthen100else1maxPipelineLength::IOIntmaxPipelineLength=readIORefmaxPipelineLengthRef{-# NOINLINE urlNotifications #-}urlNotifications::MVar(MapString(MVarString))urlNotifications=unsafePerformIO$newMVarMap.empty{-# NOINLINE urlChan #-}urlChan::ChanUrlRequesturlChan=unsafePerformIO$doch<-newChanforkIO(urlThreadch)returnchurlThread::ChanUrlRequest->IO()urlThreadch=dojunk<-flipshowHex""`fmap`randomRIOrrangeevalStateTurlThread'(UrlStateMap.emptyemptyQ0junk)whererrange=(0,2^(128::Integer)::Integer)urlThread'=doempty<-liftIO$isEmptyChanchst<-getletl=pipeLengthstw=waitToStartstreqs<-ifnotempty||(nullQw&&l==0)thenliftIOreadAllRequestselsereturn[]mapM_addReqreqscheckWaitToStartwaitNextUrlurlThread'readAllRequests=dor<-readChanchdebugMessage$"URL.urlThread ("++urlr++"\n"++" -> "++filer++")"empty<-isEmptyChanchreqs<-ifnotemptythenreadAllRequestselsereturn[]return(r:reqs)addReqr=doletu=urlrf=filerc=cachablerd<-liftIO$alreadyDownloadeduifdthendbg"Ignoring UrlRequest of URL that is already downloaded."elsedost<-getletp=inProgressstw=waitToStartste=(f,[],c)new_w=casepriorityrofHigh->pushQuwLow->insertQuwnew_st=st{inProgress=Map.insertuep,waitToStart=new_w}caseMap.lookupupofJust(f',fs',c')->doletnew_c=minCachablecc'when(c/=c')$letnew_p=Map.insertu(f',fs',new_c)pindomodify(\s->s{inProgress=new_p})dbg$"Changing "++u++" request cachability from "++showc++" to "++shownew_cwhen(u`elemQ`w&&priorityr==High)$domodify(\s->s{waitToStart=pushQu(deleteQuw)})dbg$"Moving "++u++" to head of download queue."iff`notElem`(f':fs')thenletnew_p=Map.insertu(f',f:fs',new_c)pindomodify(\s->s{inProgress=new_p})dbg"Adding new file to existing UrlRequest."elsedbg"Ignoring UrlRequest of file that's already queued."_->putnew_stalreadyDownloadedu=don<-liftIO$withMVarurlNotifications(return.(Map.lookupu))casenofJustv->not`fmap`isEmptyMVarvNothing->returnTruecheckWaitToStart::StateTUrlStateIO()checkWaitToStart=dost<-getletl=pipeLengthstmpl<-liftIOmaxPipelineLengthwhen(l<mpl)$doletw=waitToStartstcasereadQwofJust(u,rest)->docaseMap.lookupu(inProgressst)ofJust(f,_,c)->dodbg("URL.requestUrl ("++u++"\n"++" -> "++f++")")letf_new=f++"-new_"++randomJunksterr<-liftIO$requestUrluf_newcifnullerrthendodbg"URL.requestUrl succeeded"liftIO$atexit(removeFileMayNotExistf_new)put$st{waitToStart=rest,pipeLength=l+1}elsedodbg$"Failed to start download URL "++u++": "++errliftIO$doremoveFileMayNotExistf_newdownloadCompleteuerrput$st{waitToStart=rest}_->bug$"Possible bug in URL.checkWaitToStart "++ucheckWaitToStart_->return()copyUrlFirst::String->FilePath->Cachable->IO()copyUrlFirst=copyUrlWithPriorityHighcopyUrl::String->FilePath->Cachable->IO()copyUrl=copyUrlWithPriorityLowcopyUrlWithPriority::Priority->String->String->Cachable->IO()copyUrlWithPrioritypufc=dodebugMessage("URL.copyUrlWithPriority ("++u++"\n"++" -> "++f++")")v<-newEmptyMVarletfn_old_val=old_valmodifyMVar_urlNotifications(return.(Map.insertWithfnuv))letr=UrlRequestufcpwriteChanurlChanrwaitNextUrl::StateTUrlStateIO()waitNextUrl=dost<-getletl=pipeLengthstwhen(l>0)$dodbg"URL.waitNextUrl start"(u,e)<-liftIO$waitNextUrl'letp=inProgressstnew_st=st{inProgress=Map.deleteup,pipeLength=l-1}liftIO$ifnullethencaseMap.lookupupofJust(f,fs,_)->dorenameFile(f++"-new_"++randomJunkst)fmapM_(safeCopyFilestf)fsdownloadCompleteuedebugMessage$"URL.waitNextUrl succeeded: "++u++" "++fNothing->bug$"Possible bug in URL.waitNextUrl: "++uelsecaseMap.lookupupofJust(f,_,_)->doremoveFileMayNotExist(f++"-new_"++randomJunkst)downloadCompleteuedebugMessage$"URL.waitNextUrl failed: "++u++" "++f++" "++eNothing->bug$"Another possible bug in URL.waitNextUrl: "++u++" "++eunless(nullu)$putnew_stwheresafeCopyFilestft=letnew_t=t++"-new_"++randomJunkstindocopyFilefnew_trenameFilenew_ttdownloadComplete::String->String->IO()downloadCompleteue=dor<-withMVarurlNotifications(return.(Map.lookupu))caserofJustnotifyVar->putMVarnotifyVareNothing->debugMessage$"downloadComplete URL '"++u++"' downloaded several times"waitUrl::String->IO()waitUrlu=dodebugMessage$"URL.waitUrl "++ur<-withMVarurlNotifications(return.(Map.lookupu))caserofJustvar->doe<-readMVarvarmodifyMVar_urlNotifications(return.(Map.deleteu))unless(nulle)(debugFail$"Failed to download URL "++u++": "++e)Nothing->return()-- file was already downloadeddbg::String->StateTaIO()dbg=liftIO.debugMessageminCachable::Cachable->Cachable->CachableminCachableUncachable_=UncachableminCachable_Uncachable=UncachableminCachable(MaxAgea)(MaxAgeb)=MaxAge$minabminCachable(MaxAgea)_=MaxAgeaminCachable_(MaxAgeb)=MaxAgebminCachable__=Cachable#ifdef HAVE_CURLcachableToInt::Cachable->CIntcachableToIntCachable=-1cachableToIntUncachable=0cachableToInt(MaxAgen)=n#endifdisableHTTPPipelining::IO()disableHTTPPipelining=writeIORefmaxPipelineLengthRef1setDebugHTTP::IO()requestUrl::String->FilePath->Cachable->IOStringwaitNextUrl'::IO(String,String)pipeliningEnabled::IOBool#ifdef HAVE_CURLsetDebugHTTP=curl_enable_debugrequestUrlufcache=withCStringu$\ustr->withCStringf$\fstr->doerr<-curl_request_urlustrfstr(cachableToIntcache)>>=peekCStringreturnerrwaitNextUrl'=doe<-curl_wait_next_url>>=peekCStringu<-curl_last_url>>=peekCStringreturn(u,e)pipeliningEnabled=dor<-curl_pipelining_enabledreturn$r/=0foreignimportccall"hscurl.h curl_request_url"curl_request_url::CString->CString->CInt->IOCStringforeignimportccall"hscurl.h curl_wait_next_url"curl_wait_next_url::IOCStringforeignimportccall"hscurl.h curl_last_url"curl_last_url::IOCStringforeignimportccall"hscurl.h curl_enable_debug"curl_enable_debug::IO()foreignimportccall"hscurl.h curl_pipelining_enabled"curl_pipelining_enabled::IOCInt#elif defined(HAVE_HTTP)setDebugHTTP=return()requestUrl=HTTP.requestUrlwaitNextUrl'=HTTP.waitNextUrlpipeliningEnabled=returnFalse#elsesetDebugHTTP=debugMessage"URL.setDebugHttp works only with libcurl"requestUrl___=debugFail"URL.requestUrl: there is no libcurl!"waitNextUrl'=debugFail"URL.waitNextUrl': there is no libcurl!"pipeliningEnabled=returnFalse#endif-- Usage of these environment variables happens in C code, so the-- closest to "literate" user documentation is here, where the-- offending function 'curl_request_url' is imported.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."])