{-# LANGUAGE FlexibleContexts #-}{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE ScopedTypeVariables #-}{-# LANGUAGE CPP #-}moduleNetwork.HTTP.Conduit.Manager(Manager,ManagerSettings(..),ConnKey(..),newManager,closeManager,getConn,ConnReuse(..),withManager,ConnRelease,ManagedConn(..),defaultCheckCerts)whereimportPreludehiding(catch)importData.Monoid(mappend)importSystem.IO(hClose,hFlush,IOMode(..))importqualifiedData.IORefasIimportqualifiedData.MapasMapimportqualifiedData.ByteString.Char8asS8importqualifiedData.ByteString.LazyasLimportqualifiedBlaze.ByteString.BuilderasBlazeimportData.Text(Text)importqualifiedData.TextasTimportControl.Monad.Trans.Control(MonadBaseControl)importControl.Monad.IO.Class(MonadIO,liftIO)importControl.Exception(mask_,SomeException,catch)importControl.Monad.Trans.Resource(ResourceT,runResourceT,MonadResource(..),MonadThrow,MonadUnsafeIO)importControl.Concurrent(forkIO,threadDelay)importData.Time(UTCTime,getCurrentTime,addUTCTime)importNetwork(connectTo,PortID(PortNumber),HostName)importNetwork.Socket(socketToHandle)importData.Certificate.X509(X509,encodeCertificate)importqualifiedNetwork.HTTP.TypesasWimportNetwork.TLS.Extra(certificateVerifyChain,certificateVerifyDomain)importNetwork.HTTP.Conduit.ConnInfoimportNetwork.HTTP.Conduit.Util(hGetSome)importNetwork.HTTP.Conduit.Parser(parserHeadersFromByteString)importNetwork.HTTP.Conduit.RequestimportNetwork.Socks5(SocksConf,socksConnectWith)importData.DefaultimportData.Maybe(mapMaybe)importSystem.IO(Handle)-- | Settings for a @Manager@. Please use the 'def' function and then modify-- individual settings.dataManagerSettings=ManagerSettings{managerConnCount::Int-- ^ Number of connections to a single host to keep alive. Default: 10.,managerCheckCerts::W.Ascii->[X509]->IOTLSCertificateUsage-- ^ Check if the server certificate is valid. Only relevant for HTTPS.}typeX509Encoded=L.ByteStringinstanceDefaultManagerSettingswheredef=ManagerSettings{managerConnCount=10,managerCheckCerts=defaultCheckCerts}-- | Check certificates using the operating system's certificate checker.defaultCheckCerts::W.Ascii->[X509]->IOTLSCertificateUsagedefaultCheckCertshost'certs=casecertificateVerifyDomain(S8.unpackhost')certsofCertificateUsageAccept->certificateVerifyChaincertsrejected->returnrejected-- | Keeps track of open connections for keep-alive. May be used-- concurrently by multiple threads.dataManager=Manager{mConns::!(I.IORef(Maybe(Map.MapConnKey(NonEmptyListConnInfo))))-- ^ @Nothing@ indicates that the manager is closed.,mMaxConns::!Int-- ^ This is a per-@ConnKey@ value.,mCheckCerts::W.Ascii->[X509]->IOTLSCertificateUsage-- ^ Check if a certificate is valid.,mCertCache::!(I.IORef(Map.MapW.Ascii(Map.MapX509EncodedUTCTime)))-- ^ Cache of validated certificates. The @UTCTime@ gives the expiration-- time for the validity of the certificate. The @Ascii@ is the hostname.}dataNonEmptyLista=One!a!UTCTime|Cons!a!Int!UTCTime!(NonEmptyLista)-- | @ConnKey@ consists of a hostname, a port and a @Bool@-- specifying whether to use SSL.dataConnKey=ConnKey!Text!Int!Boolderiving(Eq,Show,Ord)takeSocket::Manager->ConnKey->IO(MaybeConnInfo)takeSocketmankey=I.atomicModifyIORef(mConnsman)gowheregoNothing=(Nothing,Nothing)go(Justm)=caseMap.lookupkeymofNothing->(Justm,Nothing)Just(Onea_)->(Just$Map.deletekeym,Justa)Just(Consa__rest)->(Just$Map.insertkeyrestm,Justa)putSocket::Manager->ConnKey->ConnInfo->IO()putSocketmankeyci=donow<-getCurrentTimemsock<-I.atomicModifyIORef(mConnsman)(gonow)maybe(return())connClosemsockwherego_Nothing=(Nothing,Justci)gonow(Justm)=caseMap.lookupkeymofNothing->(Just$Map.insertkey(Onecinow)m,Nothing)Justl->let(l',mx)=addToListnow(mMaxConnsman)cilin(Just$Map.insertkeyl'm,mx)-- | Add a new element to the list, up to the given maximum number. If we're-- already at the maximum, return the new value as leftover.addToList::UTCTime->Int->a->NonEmptyLista->(NonEmptyLista,Maybea)addToList_ixl|i<=1=(l,Justx)addToListnow_xl@One{}=(Consx2nowl,Nothing)addToListnowmaxCountxl@(Cons_currCount__)|maxCount>currCount=(Consx(currCount+1)nowl,Nothing)|otherwise=(l,Justx)-- | Create a 'Manager'. You must manually call 'closeManager' to shut it down.newManager::ManagerSettings->IOManagernewManagerms=domapRef<-I.newIORef(JustMap.empty)certCache<-I.newIORefMap.empty_<-forkIO$reapmapRefcertCachereturn$ManagermapRef(managerConnCountms)(managerCheckCertsms)certCache-- | Collect and destroy any stale connections.reap::I.IORef(Maybe(Map.MapConnKey(NonEmptyListConnInfo)))->I.IORef(Map.MapW.Ascii(Map.MapX509EncodedUTCTime))->IO()reapmapRefcertCacheRef=mask_loopwhereloop=dothreadDelay(5*1000*1000)now<-getCurrentTimeletisNotStaletime=30`addUTCTime`time>=nowmtoDestroy<-I.atomicModifyIORefmapRef(findStaleWrapisNotStale)casemtoDestroyofNothing->return()-- manager is closedJusttoDestroy->domapM_safeConnClosetoDestroyloopI.atomicModifyIORefcertCacheRef$\x->(flushStaleCertsnowx,())findStaleWrap_Nothing=(Nothing,Nothing)findStaleWrapisNotStale(Justm)=let(x,y)=findStaleisNotStalemin(Justx,Justy)findStaleisNotStale=findStale'idid.Map.toListwherefindStale'destroykeep[]=(Map.fromList$keep[],destroy[])findStale'destroykeep((connkey,nelist):rest)=findStale'destroy'keep'restwhere-- Note: By definition, the timestamps must be in descending order,-- so we don't need to traverse the whole list.(notStale,stale)=span(isNotStale.fst)$neToListnelistdestroy'=destroy.(mapsndstale++)keep'=caseneFromListnotStaleofNothing->keepJustx->keep.((connkey,x):)flushStaleCertsnow=Map.fromList.mapMaybeflushStaleCerts'.Map.toListwhereflushStaleCerts'(host',inner)=casemapMaybeflushStaleCerts''$Map.toListinnerof[]->Nothingpairs->Just(host',Map.fromList$take10pairs)flushStaleCerts''(certs,expires)|expires>now=Just(certs,expires)|otherwise=NothingneToList::NonEmptyLista->[(UTCTime,a)]neToList(Oneat)=[(t,a)]neToList(Consa_tnelist)=(t,a):neToListnelistneFromList::[(UTCTime,a)]->Maybe(NonEmptyLista)neFromList[]=NothingneFromList[(t,a)]=Just(Oneat)neFromListxs=Just.snd.go$xswherego[]=error"neFromList.go []"go[(t,a)]=(2,Oneat)go((t,a):rest)=let(i,rest')=goresti'=i+1ini'`seq`(i',Consaitrest')-- | Create a new manager, use it in the provided function, and then release it.---- This function uses the default manager settings. For more control, use-- 'newManager'.withManager::(MonadIOm,MonadBaseControlIOm,MonadThrowm,MonadUnsafeIOm)=>(Manager->ResourceTma)->mawithManagerf=runResourceT$do(_,manager)<-allocate(newManagerdef)closeManagerfmanager-- | Close all connections in a 'Manager'. Afterwards, the-- 'Manager' can be reused if desired.closeManager::Manager->IO()closeManagermanager=mask_$dom<-I.atomicModifyIORef(mConnsmanager)$\x->(Nothing,x)mapM_(nonEmptyMapM_safeConnClose)$maybe[]Map.elemsmsafeConnClose::ConnInfo->IO()safeConnCloseci=connCloseci`catch`\(_::SomeException)->return()nonEmptyMapM_::Monadm=>(a->m())->NonEmptyLista->m()nonEmptyMapM_f(Onex_)=fxnonEmptyMapM_f(Consx__l)=fx>>nonEmptyMapM_flgetSocketConn::MonadResourcem=>Manager->String->Int->MaybeSocksConf-- ^ optional socks proxy->m(ConnReleasem,ConnInfo,ManagedConn)getSocketConnmanhost'port'socksProxy'=getManagedConnman(ConnKey(T.packhost')port'False)$getSockethost'port'socksProxy'>>=socketConndescwheredesc=socketDeschost'port'"unsecured"socketDesc::String->Int->String->StringsocketDeschpt=unwords[h,showp,t]getSslConn::MonadResourcem=>([X509]->IOTLSCertificateUsage)->Manager->String-- ^ host->Int-- ^ port->MaybeSocksConf-- ^ optional socks proxy->m(ConnReleasem,ConnInfo,ManagedConn)getSslConncheckCertmanhost'port'socksProxy'=getManagedConnman(ConnKey(T.packhost')port'True)$(connectionTohost'(PortNumber$fromIntegralport')socksProxy'>>=sslClientConndesccheckCert)wheredesc=socketDeschost'port'"secured"getSslProxyConn::MonadResourcem=>([X509]->IOTLSCertificateUsage)->S8.ByteString-- ^ Target host->Int-- ^ Target port->Manager->String-- ^ Proxy host->Int-- ^ Proxy port->MaybeSocksConf-- ^ optional SOCKS proxy->m(ConnReleasem,ConnInfo,ManagedConn)getSslProxyConncheckCertthosttportmanphostpportsocksProxy'=getManagedConnman(ConnKey(T.packphost)pportTrue)$doConnect>>=sslClientConndesccheckCertwheredesc=socketDescphostpport"secured-proxy"doConnect=doh<-connectionTophost(PortNumber$fromIntegralpport)socksProxy'L.hPutStrh$Blaze.toLazyByteStringconnectRequesthFlushhr<-hGetSomeh2048res<-parserHeadersFromByteStringrcaseresofRight((_,200,_),_)->returnhRight((_,_,msg),_)->hCloseh>>proxyError(S8.unpackmsg)Lefts->hCloseh>>proxyErrorsconnectRequest=Blaze.fromByteString"CONNECT "`mappend`Blaze.fromByteStringthost`mappend`Blaze.fromByteString(S8.pack(':':showtport))`mappend`Blaze.fromByteString" HTTP/1.1\r\n\r\n"proxyErrors=error$"Proxy failed to CONNECT to '"++S8.unpackthost++":"++showtport++"' : "++sdataManagedConn=Fresh|Reused-- | This function needs to acquire a @ConnInfo@- either from the @Manager@ or-- via I\/O, and register it with the @ResourceT@ so it is guaranteed to be-- either released or returned to the manager.getManagedConn::MonadResourcem=>Manager->ConnKey->IOConnInfo->m(ConnReleasem,ConnInfo,ManagedConn)-- We want to avoid any holes caused by async exceptions, so let's mask.getManagedConnmankeyopen=resourceMask$\restore->do-- Try to take the socket out of the manager.mci<-liftIO$takeSocketmankey(ci,isManaged)<-casemciof-- There wasn't a matching connection in the manager, so create a-- new one.Nothing->doci<-restore$liftIOopenreturn(ci,Fresh)-- Return the existing oneJustci->return(ci,Reused)-- When we release this connection, we can either reuse it (put it back in-- the manager) or not reuse it (close the socket). We set up a mutable-- reference to track what we want to do. By default, we say not to reuse-- it, that way if an exception is thrown, the connection won't be reused.toReuseRef<-liftIO$I.newIORefDontReuse-- Now register our release action.releaseKey<-register$dotoReuse<-I.readIOReftoReuseRef-- Determine what action to take based on the value stored in the-- toReuseRef variable.casetoReuseofReuse->putSocketmankeyciDontReuse->connCloseci-- When the connection is explicitly released, we update our toReuseRef to-- indicate what action should be taken, and then call release.letconnReleasex=doliftIO$I.writeIOReftoReuseRefxreleasereleaseKeyreturn(connRelease,ci,isManaged)dataConnReuse=Reuse|DontReusetypeConnReleasem=ConnReuse->m()getConn::MonadResourcem=>Requestm->Manager->m(ConnReleasem,ConnInfo,ManagedConn)getConnreqm=gomconnhostconnport(socksProxyreq)whereh=hostreq(useProxy,connhost,connport)=caseproxyreqofJustp->(True,S8.unpack(proxyHostp),proxyPortp)Nothing->(False,S8.unpackh,portreq)go=case(securereq,useProxy)of(False,_)->getSocketConn(True,False)->getSslConn$checkCertsmh(True,True)->getSslProxyConn(checkCertsmh)h(portreq)checkCerts::Manager->W.Ascii->[X509]->IOTLSCertificateUsagecheckCertsmanhost'certs=do#if DEBUGputStrLn$"checkCerts for host: "++showhost'#endifcache<-I.readIORef$mCertCachemancaseMap.lookuphost'cache>>=Map.lookupencodedofNothing->do#if DEBUGputStrLn$concat["checkCerts ",showhost'," no cached certs found"]#endifres<-mCheckCertsmanhost'certscaseresofCertificateUsageAccept->do#if DEBUGputStrLn$concat["checkCerts ",showhost'," valid cert, adding to cache"]#endifnow<-getCurrentTime-- keep it valid for 1 hourletexpire=(60*60)`addUTCTime`nowI.atomicModifyIORef(mCertCacheman)$addValidCertsexpire_->return()returnresJust_->do#if DEBUGputStrLn$concat["checkCerts ",showhost'," cert already cached"]#endifreturnCertificateUsageAcceptwhereencoded=L.concat$mapencodeCertificatecertsaddValidCertsexpirecache=(Map.inserthost'innercache,())whereinner=caseMap.lookuphost'cacheofNothing->Map.singletonencodedexpireJustm->Map.insertencodedexpiremconnectionTo::HostName->PortID->MaybeSocksConf->IOHandleconnectionTohost'port'Nothing=connectTohost'port'connectionTohost'port'(JustsocksConf)=socksConnectWithsocksConfhost'port'>>=flipsocketToHandleReadWriteMode