suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

make _hfun retry automatically

Browse Source 
Extend `_hfun` to allow specified exceptions through, and
use it consistently for anything that returns an HRESULT
and might need a retry.
This commit is contained in:
Matthew Flatt 2015-03-27 14:02:06 -06:00
parent 3a75630ea4
commit cae162685f
3 changed files with 123 additions and 49 deletions
pkgs/racket-doc/scribblings/foreign
com-intf.scrbl
racket/collects/ffi/unsafe
com.rkt
private
win32.rkt

52
pkgs/racket-doc/scribblings/foreign/com-intf.scrbl
View File

@ -135,13 +135,38 @@ Like @racket[_wfun], but adds a @racket[_pointer] type (for the
``self'' argument of a method) as the first argument @racket[type-spec].}
@defform[(_hfun fun-option ... type-spec ... -> id output-expr)]{
@defform[(_hfun fun-option ... type-spec ... -> id maybe-allow output-expr)
#:grammar
([maybe-allow code:blank
(code:line #:allow [result-id allow?-expr])])]{
Like @racket[_wfun], but for a function that returns an
@racket[_HRESULT]. If the result is not zero, then an error is raised
using @racket[windows-error] and using @racket[id] as the name of the
failed function. Otherwise, @racket[output-expr] (as in a
@racket[_maybe-racket] for @racket[_fun]) determines the result.}
@racket[_HRESULT]. The result is bound to @racket[result-id] if
@racket[#:allow] is specified, otherwise the result is not directly
accessible.
The @racket[_hfun] form handles the @racket[_HRESULT] value of the
foreign call as follows:
@itemlist[
@item{If the result is zero or if @racket[#:allow] is specified and
@racket[allow?-expr] produces @racket[#t], then
@racket[output-expr] (as in a @racket[_maybe-wrapper] for
@racket[_fun]) determines the result.}
@item{If the result is @cpp{RPC_E_CALL_REJECTED} or
@cpp{RPC_E_SERVERCALL_RETRYLATER}, the call is autmatically
retried up to @racket[(current-hfun-retry-count)] times with a
delay of @racket[(current-hfun-retry-delay)] seconds between
each attempt.}
@item{Otherwise, an error is raised using @racket[windows-error] and
using @racket[id] as the name of the failed function.}
]
@history[#:changed "6.2.0.2" @elem{Added @racket[#:allow] and automatic retries.}]}
@defform[(_hmfun fun-option ... type-spec ... -> id output-expr)]{
@ -149,6 +174,23 @@ failed function. Otherwise, @racket[output-expr] (as in a
Like @racket[_hfun], but lke @racket[_mfun] in that @racket[_pointer]
is added for the first argument.}
@deftogether[(
@defparam[current-hfun-retry-count exact-nonnegative-integer? count]
@defparam[current-hfun-retry-delay secs (>=/c 0.0)]
)]{
Parameters that determine the behavior of automatic retries for @racket[_hfun].
@history[#:added "6.2.0.2"]}
@defproc[(HRESULT-retry? [r exact-nonnegative-integer?]) boolean?]{
Returns @racket[#t] if @racket[r] is @cpp{RPC_E_CALL_REJECTED}
or @cpp{RPC_E_SERVERCALL_RETRYLATER}, @racket[#f] otherwise.
@history[#:added "6.2.0.2"]}
@deftogether[(
@defthing[_GUID ctype?]

82
racket/collects/ffi/unsafe/com.rkt
View File

@ -30,6 +30,9 @@
_HRESULT _LCID
windows-error
current-hfun-retry-count
current-hfun-retry-delay
HRESULT-retry?
IID_NULL IID_IUnknown
_IUnknown _IUnknown-pointer _IUnknown_vt
@ -101,15 +104,15 @@
(define-ole CLSIDFromProgID (_hfun _string/utf-16 _pointer
-> CLSIDFromProgID (void)))
(define-ole ProgIDFromCLSID (_fun _GUID-pointer (p : (_ptr o _pointer))
-> (r : _HRESULT)
-> (cond
[(zero? r)
(begin0
(cast p _pointer _string/utf-16)
(CoTaskMemFree p))]
[(= REGDB_E_CLASSNOTREG r) #f]
[else (windows-error "ProgIDFromCLSID: failed" r)])))
(define-ole ProgIDFromCLSID (_hfun _GUID-pointer (p : (_ptr o _pointer))
-> ProgIDFromCLSID
#:allow [r (= REGDB_E_CLASSNOTREG r)]
(cond
[(= REGDB_E_CLASSNOTREG r) #f]
[else
(begin0
(cast p _pointer _string/utf-16)
(CoTaskMemFree p))])))
(define (progid->clsid progid)
(unless (string? progid) (raise-type-error 'progid->clsid "string" progid))
@ -281,12 +284,12 @@
(define-cstruct _IUnknown ([vt _pointer]))
(define-cstruct _IUnknown_vt
([QueryInterface (_mfun _REFIID (p : (_ptr o _pointer))
-> (r : _HRESULT)
-> (cond
[(= r E_NOINTERFACE) #f]
[(positive? r) (windows-error "QueryInterface: failed" r)]
[else p]))]
([QueryInterface (_hmfun _REFIID (p : (_ptr o _pointer))
-> QueryInterface
#:allow [r (= r E_NOINTERFACE)]
(cond
[(= r E_NOINTERFACE) #f]
[else p]))]
[AddRef (_mfun -> _ULONG)]
[Release (_mfun -> _ULONG)]))
@ -329,17 +332,20 @@
[GetTypeInfo (_hmfun _UINT _LCID (p : (_ptr o _pointer))
-> GetTypeInfo (cast p _pointer _ITypeInfo-pointer))
#:release-with-function Release]
[GetIDsOfNames (_mfun _REFIID (_ptr i _string/utf-16)
(_UINT = 1) _LCID
(p : (_ptr o _DISPID))
-> (r : _HRESULT)
-> (values r p))]
[Invoke (_mfun _DISPID _REFIID _LCID _WORD
_DISPPARAMS-pointer/null
_VARIANT-pointer/null
_pointer ; to _EXCEPINFO
_pointer ; to _UINT
-> _HRESULT)]))
[GetIDsOfNames (_hmfun _REFIID (_ptr i _string/utf-16)
(_UINT = 1) _LCID
(p : (_ptr o _DISPID))
-> GetIDsOfNames
#:allow [r (not (HRESULT-retry? r))]
(values r p))]
[Invoke (_hmfun _DISPID _REFIID _LCID _WORD
_DISPPARAMS-pointer/null
_VARIANT-pointer/null
_pointer ; to _EXCEPINFO
_pointer ; to _UINT
-> Invoke
#:allow [r (not (HRESULT-retry? r))]
r)]))
(define error-index-ptr (malloc 'atomic-interior _UINT))
@ -2286,13 +2292,14 @@
(string->guid "{00020404-0000-0000-c000-000000000046}"))
(define-com-interface (_IEnumVARIANT _IUnknown)
([Next (_mfun (_ulong = 1)
(els : (_ptr o _VARIANT))
(got : (_ptr o _ulong))
-> (r : _HRESULT)
-> (if (= got 1)
els
#f))]
([Next (_hmfun (_ulong = 1)
(els : (_ptr o _VARIANT))
(got : (_ptr o _ulong))
-> Next
#:allow [r (= r 1)] ; 1 => no more elements
(if (and (= r 0) (= got 1))
els
#f))]
;; ... more methods ...
))
@ -2316,11 +2323,10 @@
;; ----------------------------------------
;; Initialize
(define-ole CoInitialize (_wfun (_pointer = #f) -> (r : _HRESULT)
-> (cond
[(= r 0) (void)] ; ok
[(= r 1) (void)] ; already initialized
[else (windows-error (format "~a: failed" 'CoInitialize) r)])))
(define-ole CoInitialize (_hfun (_pointer = #f)
-> CoInitialize
#:allow [r (= r 1)] ; 1 => already initialized
(void)))
(define inited? #f)
(define (init!)

38
racket/collects/ffi/unsafe/private/win32.rkt
View File

@ -28,15 +28,39 @@
(define-syntax-rule (_wfun type ...)
(_fun #:abi winapi type ...))
;; for functions that return HRESULTs
;; for functions that return HRESULTs with
;; automatic retires on RPC_E_CALL_REJECTED
;; and RPC_E_SERVERCALL_RETRYLATER errors
(define-syntax _hfun
(syntax-rules (->)
[(_ type ... -> who res)
(_wfun type ...
[(_ type ... -> who #:allow [r r-ok?] res)
(_wfun #:retry (retry [count 0])
type ...
-> (r : _HRESULT)
-> (if (positive? r)
(windows-error (format "~a: failed" 'who) r)
res))]))
-> (if (or (zero? r) r-ok?)
res
(hfun-result r 'who retry count)))]
[(_ type ... -> who res)
(_hfun type ... -> who #:allow [r #f] res)]))
(define (hfun-result r who retry count)
(cond
[(HRESULT-retry? r)
(cond
[(count . < . (current-hfun-retry-count))
(sleep (current-hfun-retry-delay))
(retry (add1 count))]
[else
(windows-error (format "~a: failed after ~a retries" who count) r)])]
[else
(windows-error (format "~a: failed" who) r)]))
(define (HRESULT-retry? r)
(or (= r RPC_E_CALL_REJECTED)
(= r RPC_E_SERVERCALL_RETRYLATER)))
(define current-hfun-retry-count (make-parameter 10))
(define current-hfun-retry-delay (make-parameter 0.5))
(define (bit-and? a b)(not (zero? (bitwise-and a b))))
@ -185,6 +209,8 @@
(error (format "~a (~x)" str scode))))))
(define E_NOINTERFACE #x80004002)
(define RPC_E_CALL_REJECTED #x80010001)
(define RPC_E_SERVERCALL_RETRYLATER #x8001010A)
(define-kernel FormatMessageW (_wfun _DWORD _pointer
_HRESULT _DWORD