std-pregexp.rkt

std-pregexp.rkt

#lang racket


(require net/url)

(define ipv6-hex "[0-9a-fA-F:]*:[0-9a-fA-F:]*")

(define url-regexp
 (pregexp (string-append
           "^"
           "(?:"              ; / scheme-colon-opt
           "([^:/?#]*)"       ; | #1 = scheme-opt
           ":)?"              ; \
           "(?://"            ; / slash-slash-authority-opt
           "(?:"              ; | / user-at-opt
           "([^/?#@]*)"       ; | | #2 = user-opt
           "@)?"              ; | \
           "(?:"              ;
           "(?:\\["           ; | / #3 = ipv6-host-opt
           "(" ipv6-hex ")"   ; | | hex-addresses
           "\\])|"            ; | \
           "([^/?#:]*)"       ; | #4 = host-opt
           ")?"               ;
           "(?::"             ; | / colon-port-opt
           "([0-9]*)"         ; | | #5 = port-opt
           ")?"               ; | \
           ")?"               ; \
           "([^?#]*)"         ; #6 = path
           "(?:\\?"           ; / question-query-opt
           "([^#]*)"          ; | #7 = query-opt
           ")?"               ; \
           "(?:#"             ; / hash-fragment-opt
           "(.*)"             ; | #8 = fragment-opt
           ")?"               ; \
           "$")))

(define urls (list
           "https://github.com/foo/bar.git"
           "https://github.com/foo/bar.git?ref=master&foo=bar"
           "ssh://git@github.com:22/foo/bar.git"
           "ssh://git@github.com:22/foo/bar.git?ref=master&foo=bar"
           ))
(map (curry regexp-match url-regexp) urls)


=> '(("https://github.com/foo/bar.git" "https" #f #f "github.com" #f "/foo/bar.git" #f #f) ("https://github.com/foo/bar.git?ref=master&foo=bar" "https" #f #f "github.com" #f "/foo/bar.git" "ref=master&foo=bar" #f) ("ssh://git@github.com:22/foo/bar.git" "ssh" "git" #f "github.com" "22" "/foo/bar.git" #f #f) ("ssh://git@github.com:22/foo/bar.git?ref=master&foo=bar" "ssh" "git" #f "github.com" "22" "/foo/bar.git" "ref=master&foo=bar" #f))
                                               --
                                               good match

std-pregexp.ss

(import :std/pregexp)

(define ipv6-hex "[0-9a-fA-F:]*:[0-9a-fA-F:]*")

(define url-regexp
 (pregexp (string-append
           "^"
           "(?:"              ; / scheme-colon-opt
           "([^:/?#]*)"       ; | #1 = scheme-opt
           ":)?"              ; \
           "(?://"            ; / slash-slash-authority-opt
           "(?:"              ; | / user-at-opt
           "([^/?#@]*)"       ; | | #2 = user-opt
           "@)?"              ; | \
           "(?:"              ;
           "(?:\\["           ; | / #3 = ipv6-host-opt
           "(" ipv6-hex ")"   ; | | hex-addresses
           "\\])|"            ; | \
           "([^/?#:]*)"       ; | #4 = host-opt
           ")?"               ;
           "(?::"             ; | / colon-port-opt
           "([0-9]*)"         ; | | #5 = port-opt
           ")?"               ; | \
           ")?"               ; \
           "([^?#]*)"         ; #6 = path
           "(?:\\?"           ; / question-query-opt
           "([^#]*)"          ; | #7 = query-opt
           ")?"               ; \
           "(?:#"             ; / hash-fragment-opt
           "(.*)"             ; | #8 = fragment-opt
           ")?"               ; \
           "$")))

(define urls (list
           "https://github.com/foo/bar.git"
           "https://github.com/foo/bar.git?ref=master&foo=bar"
           "ssh://git@github.com:22/foo/bar.git"
           "ssh://git@github.com:22/foo/bar.git?ref=master&foo=bar"
           ))

(displayln (map (lambda (url) (pregexp-match url-regexp url)) urls))


=> ((https://github.com/foo/bar.git https github.com #f github.com #f /foo/bar.git #f #f) (https://github.com/foo/bar.git?ref=master&foo=bar https github.com #f github.com #f /foo/bar.git ref=master&foo=bar #f) (ssh://git@github.com:22/foo/bar.git ssh git #f github.com 22 /foo/bar.git #f #f) (ssh://git@github.com:22/foo/bar.git?ref=master&foo=bar ssh git #f github.com 22 /foo/bar.git ref=master&foo=bar #f))
=>                                        -----------
=>                                        wrong match