[racket-dev] Feature request: allow 2htdp/image bitmap function to load from URL

[Nadeem Abdul Hamid]

Below is a quick hack I did to allow loading a 2htdp/image bitmap from a url 
like this:

    (bitmap (url "http://docs.racket-lang.org/teachpack/4e85791a5.png";))

There's no error checking, and I was too lazy to do a diff, but I've marked the 
three pieces that I added with "; .nah." comments. Would it be possible to add 
this feature to the library? This would have been a little easier maybe if 
bitmap% provided load from ports, but I see that's an open PR (9335). 

Thanks,
--- nadeem


(define-syntax (bitmap stx)
  (syntax-case stx ()
    [(_ arg)
     (let* ([arg (syntax->datum #'arg)]
            [url? (and (pair? arg) (eq? (car arg) 'url))]   ; .nah.
            [path
             (cond
               [(and (pair? arg)
                     (eq? (car arg) 'planet))
                (raise-syntax-error 'bitmap "planet paths not yet supported" 
stx)]
               ; .nah. ...
               [url?
                (let ([temp-path (make-temporary-file)])
                  (call-with-output-file temp-path
                    (lambda (outp) 
                      (call/input-url 
                       (string->url (cadr arg)) get-pure-port
                       (lambda (inp) 
                         (copy-port inp outp)
                            )))
                    #:exists 'replace
                    )
                  (display temp-path)
                  temp-path
                  )]
               ; ... .nah.
               [(symbol? arg)
                (let ([pieces (regexp-split #rx"/" (symbol->string arg))])
                  (cond
                    [(null? pieces)
                     (raise-syntax-error 'bitmap "expected a path with a / in 
it" stx)]
                    [else
                     (let loop ([cps (current-library-collection-paths)])
                       (cond
                         [(null? cps)
                          (raise-syntax-error 'bitmap
                                              (format "could not find the ~a 
collection" (car pieces))
                                              stx)]
                         [else
                          (if (and (directory-exists? (car cps))
                                   (member (build-path (car pieces))
                                           (directory-list (car cps))))
                              (let ([candidate (apply build-path (car cps) 
pieces)])
                                (if (file-exists? candidate)
                                    candidate
                                    (raise-syntax-error 'bitmap 
                                                        (format "could not find 
~a in the ~a collection"
                                                                (apply 
string-append (add-between (cdr pieces) "/"))
                                                                (car pieces))
                                                        stx)))
                              (loop (cdr cps)))]))]))]
               [(string? arg)
                (path->complete-path 
                 arg
                 (or (current-load-relative-directory)
                     (current-directory)))])]
            )
       ; .nah. ...
       #`(let ([result (make-object image-snip% (make-object bitmap% #,path 
'unknown/mask))])
           (when #,url? (delete-file #,path))
           result)
       ; ... .nah.
       )]))