Skip to content

Instantly share code, notes, and snippets.

@Metaxal

Metaxal/url2script.rkt

Last active Mar 27, 2021
Embed
What would you like to do?
Fetches a quickscript at a given url and adds it to the library
#lang racket/base
;;; License: [Apache License, Version 2.0](http://www.apache.org/licenses/LICENSE-2.0) or
;;; [MIT license](http://opensource.org/licenses/MIT) at your option.
(require quickscript
quickscript/base
racket/class
racket/file
racket/match
racket/port
racket/path
racket/gui/base
net/url)
(script-help-string "Fetches a quickscript at a given url and adds it to the library.")
(define dir user-script-dir)
(define url2script-submod-name 'url2script-info)
;; Will be in quickscript/utils at some point
(define (smart-open-file drfr f)
(cond
[(not (file-exists? f))
(message-box "Error"
(format "File not found: ~a" f)
drfr
'(ok stop))
#f]
[(send drfr still-untouched?)
(send drfr change-to-file f)
#t]
[(send drfr find-matching-tab f)
=>
(λ (tab)
(send drfr change-to-tab tab)
#t)]
[else
(send drfr open-in-new-tab f)
#t]))
(define (parse-url str)
; Do not keep trailing anchors
(set! str (regexp-replace #px"[#?].*" str ""))
(match str
; We can extract the filename
; "https://gist.githubusercontent.com/Metaxal/4449e/raw/342e26/letterfall.rkt"
[(regexp #px"^https://gist\\.github(?:usercontent|)\\.com/[^/]+/[0-9a-f]+/raw/[0-9a-f]+/([^/]+)$"
(list _ filename))
(values str filename)]
; "https://gist.githubusercontent.com/Metaxal/4449e059959da9f344f83c7e628ad9af/raw"
; "https://pastebin.com/raw/EMfcc5zs"
[(or (regexp #px"^https://gist\\.github(?:usercontent|).com/[^/]+/[0-9a-f]+/raw$")
(regexp #px"^https://gitlab\\.com/snippets/[0-9]+/raw$")
(regexp #px"^http://pasterack\\.org/pastes/[0-9]+/raw$")
(regexp #px"^https://pastebin.com/raw/[0-9a-zA-Z]+$"))
(values str #f)]
; "https://gist.githubusercontent.com/Metaxal/4449e059959da9f344f83c7e628ad9af"
; "https://gitlab.com/snippets/1997854"
; "http://pasterack.org/pastes/8953"
[(or (regexp #px"^https://gist\\.github(?:usercontent|)\\.com/[^/]+/[0-9a-f]+$")
(regexp #px"^https://gitlab\\.com/snippets/[0-9]+$")
(regexp #px"^http://pasterack\\.org/pastes/[0-9]+$"))
(values (string-append str "/raw") #f)]
; "https://pastebin.com/EMfcc5zs"
[(regexp #px"^https://pastebin.com/([0-9a-zA-Z]+)$" (list _ name))
(values (string-append "https://pastebin.com/raw/" name) #f)]
; Any other kind of url, we assume a link to a raw file
[else (values str #f)]))
;; TODO: check it is indeed a (valid?) quickscript
;; TODO: get-pure-port also handles files. This could be useful.
;; To prevent CDN caching, add "?cachebust=<some-random-number>" at the end of the url
;; (or "&cachebust=..."), just to make sure the url is different.
(define (get-text-at-url aurl)
(port->string (get-pure-port (string->url aurl)
#:redirections 10)
#:close? #t))
;; Notice: Does not ask to replace (should be done prior).
;; Doesn't add a submodule if one already exists.
;; Allows the designer to give the default file name to save the script.
(define (write-script fout text aurl #:filename [filename (file-name-from-path fout)])
;; First, write the script to a temp file so as to check if it has some good module properties.
(define ftmp (make-temporary-file))
(display-to-file text ftmp #:exists 'replace) ; replace because `make-temporary-file` creates the file
(define submod-first-line
(string-append "(module " (symbol->string url2script-submod-name) " racket/base"))
(define add-submod?
(not (has-submod? ftmp))
#;(not (string-contains? text submod-first-line)))
(display-to-file
#:exists 'replace
(string-append
text
(if add-submod?
(string-append
"\n"
submod-first-line
"
(provide filename url)
(define filename " (format "~s" (and filename (path->string filename))) ")
(define url " (format "~s" aurl) "))
")
""))
fout)
(delete-file ftmp))
;; Don't allow file or network access in the url2script submodule,
;; in particular because this module is `require`d right after downloading,
;; before the user has a chance to look at the file.
(define dynreq-security-guard
(make-security-guard (current-security-guard)
(λ (sym pth access)
(unless (or (equal? access '(exists))
(equal? access '(read)))
(error (format "File access disabled ~a" (list sym pth access)))))
(λ _ (error "Network access disabled"))))
;; Get information from the url2script submodule.
(define (get-submod f sym [fail-thunk (λ () #f)])
(parameterize ([current-security-guard dynreq-security-guard]
[current-namespace (make-base-empty-namespace)])
(dynamic-require `(submod (file ,(path->string f)) ,url2script-submod-name)
sym
fail-thunk)))
;; Does the file contain a url2script submodule?
(define (has-submod? f)
(with-handlers ([exn:fail? (λ (e) #f)])
(get-submod f #f)
#t))
(define-script url2script
#:label "Fetch script…"
#:help-string "Asks for a URL and fetches the script"
#:menu-path ("url2script")
(λ (selection #:frame frame)
(define str (get-text-from-user
"url2script"
"Enter a URL to gist, gitlab snippet or pasterack, or to a raw racket file:"))
(when str
; At a special commit, with the name at the end, which we could extract.
(define-values (aurl maybe-filename) (parse-url str))
(define text (get-text-at-url aurl))
(define ftmp (make-temporary-file))
; Write a first time to maybe-write and read the submod infos
(write-script ftmp text aurl #:filename maybe-filename)
(define filename (get-submod ftmp 'filename))
; Ask the user for a filename and directory.
; Notice: If the directory is not in the Library's paths, Quickscript may not find the script.
; TODO: Check that it's in the Library's path and display a warning if not?
(define fout (put-file "url2script: Save script as…"
frame
dir
(or filename ".rkt")
".rkt"
'()
'(("Racket source" "*.rkt")
("Any" "*.*"))))
(when fout
(write-script fout text str)
(smart-open-file frame fout))
#f)))
(define-script update-script
#:label "Update current script"
#:help-string "Updates a script that was downloaded with url2script"
#:menu-path ("url2script")
(λ (selection #:file f #:frame drfr)
(when f
(define submod-url (get-submod f 'url))
(cond
[submod-url
(define-values (aurl _name) (parse-url submod-url))
(define text (get-text-at-url aurl))
(define ok?
(message-box "Attention"
"This will rewrite the current file. Continue?"
#f
'(ok-cancel caution)))
(when ok?
(write-script f text aurl)
(when drfr (send drfr revert)))]
[else
(message-box
"Error"
"Unable to find original url. Script may not have been downloaded with url2script."
#f
'(ok stop))]))
#f))
;=============;
;=== Tests ===;
;=============;
(module+ test
(require rackunit)
(let ()
(define f (make-temporary-file))
(define aurl "https://this.is.your/home/now")
(write-script f "#lang racket/base\n" aurl)
(check-equal? (get-submod f 'url)
aurl))
(define (test-parse-url url)
(call-with-values (λ () (parse-url url)) list))
(check-equal?
(test-parse-url "https://gist.github.com/Metaxal/f5ea8e94b802eac947fe9ea72870624b")
'("https://gist.github.com/Metaxal/f5ea8e94b802eac947fe9ea72870624b/raw"
#f))
(check-equal?
(test-parse-url "https://gist.github.com/Metaxal/f5ea8e94b802eac947fe9ea72870624b/raw")
'("https://gist.github.com/Metaxal/f5ea8e94b802eac947fe9ea72870624b/raw"
#f))
(check-equal?
(test-parse-url "https://gist.githubusercontent.com/Metaxal/4449e/raw/342e/letterfall.rkt")
(list "https://gist.githubusercontent.com/Metaxal/4449e/raw/342e/letterfall.rkt"
"letterfall.rkt"))
(check-equal?
(test-parse-url "https://gist.github.com/Metaxal/b2f6c446bded83962d3341bb79199734#file-upcase-rkt")
; Filename is a little annoying to parse
(list "https://gist.github.com/Metaxal/b2f6c446bded83962d3341bb79199734/raw"
#f))
(check-equal?
(test-parse-url "https://gist.github.com/Metaxal/b2f6c446bded83962d3341bb79199734?path=something")
(list "https://gist.github.com/Metaxal/b2f6c446bded83962d3341bb79199734/raw"
#f))
(check-equal?
(test-parse-url "https://pastebin.com/EMfcc5zs")
(list "https://pastebin.com/raw/EMfcc5zs" #f))
(check-equal?
(test-parse-url "https://pastebin.com/raw/EMfcc5zs")
(list "https://pastebin.com/raw/EMfcc5zs" #f))
(check-equal?
(test-parse-url "http://pasterack.org/pastes/8953")
(list "http://pasterack.org/pastes/8953/raw" #f))
(check-equal?
(test-parse-url "http://pasterack.org/pastes/8953/raw")
(list "http://pasterack.org/pastes/8953/raw" #f))
(check-equal?
(test-parse-url "https://gitlab.com/snippets/1997854")
(list "https://gitlab.com/snippets/1997854/raw" #f))
(check-equal?
(test-parse-url "https://gitlab.com/snippets/1997854/raw")
(list "https://gitlab.com/snippets/1997854/raw" #f))
;; TODO: Check that updating a script where the source does not have a url2script-info
;; submodule produces a script that still has the submodule
)
;=================================;
;=== url2script-info submodule ===;
;=================================;
(module url2script-info racket/base
(provide url filename)
(define filename "url2script.rkt")
(define url "https://gist.githubusercontent.com/Metaxal/77391e388303af5513d09bcd640f116c"))
@Metaxal

This comment has been minimized.

Copy link
Owner Author

@Metaxal Metaxal commented Jan 29, 2021

First install this script: Scripts|Manage scripts|New…, type url2script, then paste the content of the script at the url above in place of the default template, save, and finally Scripts|Manage scripts|Reload menu

Then to install a new script from (say) gist, just click on Scripts|url2script, paste in the url of the target script, type a script name (save it in the default directory if you don't know what you're doing) and reload the menu. Sometimes it can figure out a good default name.

@Metaxal

This comment has been minimized.

Copy link
Owner Author

@Metaxal Metaxal commented Feb 1, 2021

The new version can update a script that was downloaded with url2script. This is possible because the url is stored in and read from the file (in a submodule).

url2script can even update itself!

@Metaxal

This comment has been minimized.

Copy link
Owner Author

@Metaxal Metaxal commented Mar 27, 2021

You can find quickscripts to download with url2script here.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment