parse-url.ss

parse-url.ss

(import :std/misc/string)

(def IANA-registered-schemes
     ["aaa://"
      "aaas://"
      "about://"
      "acap://"
      "acct://"
      "acr://"
      "adiumxtra://"
      "afp://"
      "afs://"
      "aim://"
      "apt://"
      "attachment://"
      "aw://"
      "amss://"
      "barion://"
      "beshare://"
      "bitcoin://"
      "blob://"
      "bolo://"
      "callto://"
      "cap://"
      "chrome://"
      "chrome-extension://"
      "com-eventbrite-attendee://"
      "cid://"
      "coap://"
      "coaps://"
      "content://"
      "crid://"
      "cvs://"
      "dab://"
      "data://"
      "dav://"
      "dict://"
      "dlna-playsingle://"
      "dlna-playcontainer://"
      "dns://"
      "dntp://"
      "drm://"
      "dtn://"
      "dvb://"
      "ed2k://"
      "example://"
      "facetime://"
      "fax://"
      "feed://"
      "file://"
      "filesystem://"
      "finger://"
      "fish://"
      "fm://"
      "ftp://"
      "gemini://"
      "geo://"
      "gg://"
      "git://"
      "gizmoproject://"
      "go://"
      "gopher://"
      "gtalk://"
      "h323://"
      "hcp://"
      "http://"
      "https://"
      "iax://"
      "icap://"
      "icon://"
      "im://"
      "imap://"
      "info://"
      "iotdisco://"
      "ipn://"
      "ipp://"
      "ipps://"
      "irc://"
      "irc6://"
      "ircs://"
      "iris://"
      "iris.beep://"
      "iris.xpc://"
      "iris.xpcs://"
      "iris.lws://"
      "itms://"
      "jabber://"
      "jar://"
      "jms://"
      "keyparc://"
      "lastfm://"
      "ldap://"
      "ldaps://"
      "magnet://"
      "mailserver://"
      "mailto://"
      "maps://"
      "market://"
      "message://"
      "mid://"
      "mms://"
      "modem://"
      "ms-help://"
      "ms-settings://"
      "ms-settings-airplanemode://"
      "ms-settings-bluetooth://"
      "ms-settings-camera://"
      "ms-settings-cellular://"
      "ms-settings-cloudstorage://"
      "ms-settings-emailandaccounts://"
      "ms-settings-language://"
      "ms-settings-location://"
      "ms-settings-lock://"
      "ms-settings-nfctransactions://"
      "ms-settings-notifications://"
      "ms-settings-power://"
      "ms-settings-privacy://"
      "ms-settings-proximity://"
      "ms-settings-screenrotation://"
      "ms-settings-wifi://"
      "ms-settings-workplace://"
      "msnim://"
      "msrp://"
      "msrps://"
      "mtqp://"
      "mumble://"
      "mupdate://"
      "mvn://"
      "news://"
      "nfs://"
      "ni://"
      "nih://"
      "nntp://"
      "notes://"
      "oid://"
      "opaquelocktoken://"
      "openpgp4fpr://"
      "pack://"
      "palm://"
      "paparazzi://"
      "payto://"
      "pkcs11://"
      "platform://"
      "pop://"
      "pres://"
      "prospero://"
      "proxy://"
      "psyc://"
      "query://"
      "redis://"
      "rediss://"
      "reload://"
      "res://"
      "resource://"
      "rmi://"
      "rsync://"
      "rtmfp://"
      "rtmp://"
      "rtsp://"
      "s3://"
      "secondlife://"
      "service://"
      "session://"
      "sftp://"
      "sgn://"
      "shttp://"
      "sieve://"
      "sip://"
      "sips://"
      "skype://"
      "smb://"
      "sms://"
      "snews://"
      "snmp://"
      "soap.beep://"
      "soap.beeps://"
      "soldat://"
      "spotify://"
      "ssh://"
      "steam://"
      "stun://"
      "stuns://"
      "svn://"
      "tag://"
      "teamspeak://"
      "tel://"
      "telnet://"
      "tftp://"
      "things://"
      "thismessage://"
      "tn3270://"
      "tip://"
      "turn://"
      "turns://"
      "tv://"
      "udp://"
      "unreal://"
      "urn://"
      "ut2004://"
      "vemmi://"
      "ventrilo://"
      "videotex://"
      "view-source://"
      "vnc://"
      "wais://"
      "webcal://"
      "ws://"
      "wss://"
      "wtai://"
      "wyciwyg://"
      "xcon://"
      "xcon-userid://"
      "xfire://"
      "xmlrpc.beep://"
      "xmlrpc.beeps://"
      "xmpp://"
      "xri://"
      "ymsgr://"
      "z39.50r://"
      "z39.50s://"])

(def (parse-url url (all #f))
     (let lp ((schemes (if all IANA-registered-schemes ["http://" "https://"])))
       (if (pair? schemes)
           (if (string-prefix? (car schemes) url)
               (cons (car schemes) (string-trim-prefix (car schemes) url))
               (lp (cdr schemes)))
           #f)))

(def urls ["http://example.com/a/b" "https://example.com/a/b/c" "ftp://example.com/a/b/c/d"])

;; > (map parse-url urls)
;; (("http://" . "example.com/a/b") ("https://" . "example.com/a/b/c") #f)

;; > (map (cut parse-url <> #t) urls)
;; (("http://" . "example.com/a/b")
;;  ("https://" . "example.com/a/b/c")
;;  ("ftp://" . "example.com/a/b/c/d"))