{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable, RecursiveDo,
BangPatterns, UnboxedTuples #-}------------------------------------------------------------------------------- |-- Module : Happstack.Util.TimeOut-- Copyright : (c) Happstack.com, 2009; (c) HAppS.org, 2005-- License : BSD3-- -- Portability : uses mdo---- Timeout implementation for performing operations in the IO monad-- with a timeout added. Both using Maybe and exceptions to handle-- timeouts are supported.---- Timeouts can be implemented in GHC with either a global handler-- or a per-timeout thread which sleeps until the timeout. The latter-- is used in this module. Blocking on foreign calls can cause-- problems as GHC has no way of interrupting such threads.-- The module provides a slightly slower alternative implementation-- which returns even if the computation has blocked on a foreign-- call. This should not be an issue unless -threaded is used.---- The timeouts are currently limited to a maximum of about-- 2000 seconds. This is a feature of threadDelay, but-- supporting longer timeouts is certainly possible if-- that is desirable.---- For nested timeouts there are different ways to implement them:-- a) attach an id to the exception so that the catch knows wether it may catch-- this timout exception. I've choosen this because overhead is only passing-- and incrementing an integer value. A integer wrap araound is possible but-- too unlikely to happen to make me worry about it-- b) start a new workiing and killing thread so that if the original thread-- was run within withTimeOut itself it catches the exception and not an inner-- timout. (this is done in withSafeTimeOut, for another reason though)-- c) keep throwing exceptions until the the withTimeOut function kills the-- killing thread. But consider sequence (forever (timeOut threadDelay 10sec) )-- In this case the exception will be called and the next timOut may be entered-- before the second Exception has been thrown---- All exceptions but the internal TimeOutExceptionI are rethrown in the calling thread-----------------------------------------------------------------------------moduleHappstack.Util.TimeOut(withTimeOut,withTimeOutMaybe,withSafeTimeOut,withSafeTimeOutMaybe,TimeOutException(..),second)whereimportControl.ConcurrentimportqualifiedControl.Concurrent.MVar.StrictasSMimportControl.Exception.ExtensibleasEimportData.Typeable(Typeable)importData.MaybeimportSystem.IO.Unsafe(unsafePerformIO)importControl.Monad(when)importHappstack.Util.ConcurrenttypeTimeOutTId=Int-- must be distinct within a thread only {-# NOINLINE timeOutIdState #-}timeOutIdState::SM.MVarTimeOutTIdtimeOutIdState=unsafePerformIO$SM.newMVarminBoundnextTimeOutId::IOTimeOutTIdnextTimeOutId=SM.modifyMVartimeOutIdState$\a->letnid=nextIdainreturn(nid`seq`(nid,nid))wherenextId!i|i==maxBound=minBoundnextId!i=i+1dataTimeOutExceptionI=TimeOutExceptionI!TimeOutTId-- internal exception, should only be used within this module deriving(Typeable)dataTimeOutException=TimeOutException-- that's the exception the user may catch deriving(Typeable)instanceShowTimeOutExceptionIwhereshow_=error"this TimeOutExceptionI should have been caught within this module"instanceE.ExceptionTimeOutExceptionIderivinginstanceShowTimeOutExceptioninstanceE.ExceptionTimeOutExceptionthrow'::Exceptionexception=>exception->bthrow'=throwthrowTo'::Exceptione=>ThreadId->e->IO()throwTo'=E.throwTocatch'::Exceptione=>IOa->(e->IOa)->IOacatch'=E.catchtry'::IOa->IO(EitherSomeExceptiona)-- give a type signature for try try'=E.try-- module internal function catchTimeOutI::TimeOutTId->IOa->IOa->IOacatchTimeOutItoIdophandler=op`catch'`(\e@(TimeOutExceptionIi)->ifi==toIdthenhandlerelsethrow'e)-- | This handler returns @Nothing@ if the timeout occurs and @Just a@ if computation -- returns @a@.withTimeOutMaybe::Int->IOa->IO(Maybea)withTimeOutMaybetoutop=dotoId<-nextTimeOutIdwtid<-myThreadIdktid<-fork(dothreadDelaytoutthrowTo'wtid(TimeOutExceptionItoId))catchTimeOutItoId(fmapJust(op>>=\r->killThreadktid>>returnr))(returnNothing)-- | This is the normal timeout handler. It throws a TimeOutException exception,-- if the timeout occurs.withTimeOut::Int->IOa->IOawithTimeOuttoutop=maybeToEx=<<withTimeOutMaybetoutopmaybeToEx::(Monadm)=>Maybet->mtmaybeToEx(Justr)=returnrmaybeToExNothing=throw'TimeOutException-- | Like timeOut, but additionally it works even if the computation is blocking-- async exceptions (explicitely or by a blocking FFI call). This consumes-- more resources than timeOut, but is still quite fast.withSafeTimeOut::Int->IOa->IOawithSafeTimeOuttoutop=maybeToEx=<<withSafeTimeOutMaybetoutop-- | Like withTimeOutMaybe, but handles the operation blocking exceptions like withSafeTimeOut-- does.withSafeTimeOutMaybe::Int->IOa->IO(Maybea)withSafeTimeOutMaybetoutop=mdomv<-newEmptyMVarwt<-fork$dot<-try'opcasetofLefte->tryPutMVarmv(Lefte)Rightr->tryPutMVarmv(Right(Justr))killThreadktkt<-fork$dothreadDelaytoute<-tryPutMVarmv(RightNothing)whene$killThreadwteitherToEx=<<takeMVarmvwhereeitherToEx(Lefte)=throw'eeitherToEx(Rightr)=returnr-- | Constant representing one second.second::Intsecond=1000000