make _hfun retry automatically

Extend `_hfun` to allow specified exceptions through, and
use it consistently for anything that returns an HRESULT
and might need a retry.

pkgs/racket-doc/scribblings/foreign/com-intf.scrbl

@@ -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
+@racket[_HRESULT]. The result is bound to @racket[result-id] if
-using @racket[windows-error] and using @racket[id] as the name of the
+@racket[#:allow] is specified, otherwise the result is not directly
-failed function. Otherwise, @racket[output-expr] (as in a
+accessible.
-@racket[_maybe-racket] for @racket[_fun]) determines the result.}
+
+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?]

racket/collects/ffi/unsafe/com.rkt

@@ -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))
+(define-ole ProgIDFromCLSID (_hfun _GUID-pointer (p : (_ptr o _pointer))
-                                  -> (r : _HRESULT)
+                                   -> ProgIDFromCLSID
-                                  -> (cond
+                                   #:allow [r (= REGDB_E_CLASSNOTREG r)]
-                                      [(zero? r)
+                                   (cond
-                                       (begin0
+                                    [(= REGDB_E_CLASSNOTREG r) #f]
-                                        (cast p _pointer _string/utf-16)
+                                    [else
-                                        (CoTaskMemFree p))]
+                                     (begin0
-                                      [(= REGDB_E_CLASSNOTREG r) #f]
+                                      (cast p _pointer _string/utf-16)
-                                      [else (windows-error "ProgIDFromCLSID: failed" r)])))
+                                      (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))
+  ([QueryInterface (_hmfun _REFIID (p : (_ptr o _pointer))
-                          -> (r : _HRESULT)
+                           -> QueryInterface
-                          -> (cond
+                           #:allow [r (= r E_NOINTERFACE)]
-                              [(= r E_NOINTERFACE) #f]
+                           (cond
-                              [(positive? r) (windows-error "QueryInterface: failed" r)]
+                            [(= r E_NOINTERFACE) #f]
-                              [else p]))]
+                            [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)
+   [GetIDsOfNames (_hmfun _REFIID (_ptr i _string/utf-16)
-                         (_UINT = 1) _LCID
+                          (_UINT = 1) _LCID
-                         (p : (_ptr o _DISPID))
+                          (p : (_ptr o _DISPID))
-                         -> (r : _HRESULT)
+                          -> GetIDsOfNames
-                         -> (values r p))]
+                          #:allow [r (not (HRESULT-retry? r))]
-   [Invoke (_mfun _DISPID _REFIID _LCID _WORD
+                          (values r p))]
-                  _DISPPARAMS-pointer/null
+   [Invoke (_hmfun _DISPID _REFIID _LCID _WORD
-                  _VARIANT-pointer/null
+                   _DISPPARAMS-pointer/null
-                  _pointer ; to _EXCEPINFO
+                   _VARIANT-pointer/null
-                  _pointer ; to _UINT
+                   _pointer ; to _EXCEPINFO
-                  -> _HRESULT)]))
+                   _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)
+  ([Next (_hmfun (_ulong = 1)
-		(els : (_ptr o _VARIANT))
+                 (els : (_ptr o _VARIANT))
-		(got : (_ptr o _ulong))
+                 (got : (_ptr o _ulong))
-		 -> (r : _HRESULT)
+		 -> Next
-		 -> (if (= got 1)
+                 #:allow [r (= r 1)] ; 1 => no more elements
-			els
+                 (if (and (= r 0) (= got 1))
-			#f))]
+                     els
+                     #f))]
    ;; ... more methods ...
    ))
 
@@ -2316,11 +2323,10 @@
 ;; ----------------------------------------
 ;; Initialize
 
-(define-ole CoInitialize (_wfun (_pointer = #f) -> (r : _HRESULT)
+(define-ole CoInitialize (_hfun (_pointer = #f)
-                                -> (cond
+                                -> CoInitialize
-                                    [(= r 0) (void)] ; ok
+                                #:allow [r (= r 1)] ; 1 => already initialized
-                                    [(= r 1) (void)] ; already initialized
+                                (void)))
-                                    [else (windows-error (format "~a: failed" 'CoInitialize) r)])))
 
 (define inited? #f)
 (define (init!)

racket/collects/ffi/unsafe/private/win32.rkt

@@ -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)
+    [(_ type ... -> who #:allow [r r-ok?] res)
-     (_wfun type ...
+     (_wfun #:retry (retry [count 0])
+            type ...
             -> (r : _HRESULT)
-            -> (if (positive? r)
+            -> (if (or (zero? r) r-ok?)
-                   (windows-error (format "~a: failed" 'who) r)
+                   res
-                   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