<commit_before>;; To do:
;;   Handle HTTP/file errors.
;;   Not throw away MIME headers.
;;     Determine file type.

;; ----------------------------------------------------------------------

;; Input ports have two statuses:
;;   "impure" = they have text waiting
;;   "pure" = the MIME headers have been read

(module url-unit mzscheme
  (require (lib "file.ss")
           (lib "unitsig.ss")
           (lib "port.ss")
           (lib "string.ss")
           (lib "list.ss")
           "url-structs.ss"
           "uri-codec.ss"
           "url-sig.ss"
           "tcp-sig.ss")
  (provide url@)

  ;; undocumented hook to allow testing
  (provide set-url:os-type!)
  (define url:os-type (system-type))
  (define (set-url:os-type! new) (set! url:os-type new))

  (define url@
    (unit/sig net:url^
      (import net:tcp^)

      (define-struct (url-exception exn:fail) ())

      (define current-proxy-servers
        (make-parameter null (lambda (v)
                               (unless (and (list? v)
                                            (andmap
                                             (lambda (v)
                                               (and (list? v)
                                                    (= 3 (length v))
                                                    (equal? (car v) "http")
                                                    (string? (car v))
                                                    (number? (caddr v))
                                                    (exact? (caddr v))
                                                    (integer? (caddr v))
                                                    (<= 1 (caddr v) 65535)))
                                             v))
                                 (raise-type-error
                                  'current-proxy-servers
                                  "list of list of scheme, string, and exact integer in [1,65535]"
                                  v))
                               (apply
                                list-immutable
                                (map (lambda (v)
                                       (list-immutable (string->immutable-string (car v))
                                                       (string->immutable-string (cadr v))
                                                       (caddr v)))
                                     v)))))
      
      (define url-error
        (lambda (fmt . args)
          (let ((s (string->immutable-string
                    (apply format fmt (map (lambda (arg)
                                             (if (url? arg)
                                                 (url->string arg)
                                                 arg))
                                           args)))))
            (raise (make-url-exception s (current-continuation-marks))))))
      
      (define url->string
        (lambda (url)
          (let ((scheme (url-scheme url))
                (user (url-user url))
                (host (url-host url))
                (port (url-port url))
                (path (url-path url))
                (query (url-query url))
                (fragment (url-fragment url)))
            (let ((sa string-append))
              (sa (if scheme (sa scheme ":") "")
                  (if (or user host port)
                      (sa
                       "//"
                       (if user (sa (uri-encode user) "@") "")
                       (if host host "")
                       (if port (sa ":" (number->string port)) "")
                       ; There used to be a "/" here, but that causes an
                       ; extra leading slash -- wonder why it ever worked!
                       )
                      "")
                  (combine-path-strings (url-path-absolute? url) path)
                  ;(if query (sa "?" (uri-encode query)) "")
                  (if (null? query) "" (sa "?"  (alist->form-urlencoded query)))
                  (if fragment (sa "#" (uri-encode fragment)) ""))))))

      ;; url->default-port : url -> num
      (define url->default-port
        (lambda (url)
          (let ((scheme (url-scheme url)))
            (cond
             ((not scheme) 80)
             ((string=? scheme "http") 80)
             (else
              (url-error "Scheme ~a not supported" (url-scheme url)))))))

      ;; make-ports : url -> in-port x out-port
      (define make-ports
        (lambda (url proxy)
          (let ((port-number (if proxy
                                 (caddr proxy)
                                 (or (url-port url)
                                     (url->default-port url))))
                (host (if proxy
                          (cadr proxy)
                          (url-host url))))
            (tcp-connect host port-number))))

      ;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port
      (define http://getpost-impure-port
        (lambda (get? url post-data strings)
          (let*-values (((proxy) (assoc (url-scheme url) (current-proxy-servers)))
                        ((server->client client->server)
                         (make-ports url proxy)))
            (let ((access-string
                   (url->string
                    (if proxy
                        url
                        (make-url #f #f #f #f 
                                  (url-path-absolute? url)
                                  (url-path url)
                                  (url-query url)
                                  (url-fragment url))))))
              (for-each (lambda (s)
                          (display (string-append s "\r\n") client->server))
                        (cons (format "~a ~a HTTP/1.0" (if get? "GET" "POST") access-string)
                              (cons (format "Host: ~a" (url-host url))
                                    (if post-data
                                        (cons
                                         (format "Content-Length: ~a" (bytes-length post-data))
                                         strings)
                                        strings)))))
            (display "\r\n" client->server)
            (when post-data
              (display post-data client->server))
	    (tcp-abandon-port client->server) ; flushes
            server->client)))

      (define (file://->path url)
        ;; remove all ""s
        (let ([elts (remove* '("") (map path/param-path (url-path url)))]
              [abs? (url-path-absolute? url)])
          ;; See the discussion in PR8060 for an explanation
          (if (eq? 'windows url:os-type)
            (let ([host (or (url-host url) "")])
              (unless (equal? "" host) (set! elts (cons host elts)))
              (if (null? elts)
                (build-path) ; make it throw the error
                (let* ([fst (car elts)] [len (string-length fst)])
                  (if (or (not abs?) (eq? #\: (string-ref fst (sub1 len))))
                    (apply build-path elts)
                    (if (null? (cdr elts))
                      (build-path (string-append "\\\\" (car elts)))
                      (apply build-path
                             (string-append "\\\\" (car elts) "\\" (cadr elts))
                             (cddr elts)))))))
            (apply build-path (if abs? (cons "/" elts) elts)))))

      ;; file://get-pure-port : url -> in-port
      (define (file://get-pure-port url)<commit_msg>Fixed (and improved) `http://getpost-impure-port' to show the port in the Host header if it's not the default.<commit_after>;; To do:
;;   Handle HTTP/file errors.
;;   Not throw away MIME headers.
;;     Determine file type.

;; ----------------------------------------------------------------------

;; Input ports have two statuses:
;;   "impure" = they have text waiting
;;   "pure" = the MIME headers have been read

(module url-unit mzscheme
  (require (lib "file.ss")
           (lib "unitsig.ss")
           (lib "port.ss")
           (lib "string.ss")
           (lib "list.ss")
           "url-structs.ss"
           "uri-codec.ss"
           "url-sig.ss"
           "tcp-sig.ss")
  (provide url@)

  ;; undocumented hook to allow testing
  (provide set-url:os-type!)
  (define url:os-type (system-type))
  (define (set-url:os-type! new) (set! url:os-type new))

  (define url@
    (unit/sig net:url^
      (import net:tcp^)

      (define-struct (url-exception exn:fail) ())

      (define current-proxy-servers
        (make-parameter null (lambda (v)
                               (unless (and (list? v)
                                            (andmap
                                             (lambda (v)
                                               (and (list? v)
                                                    (= 3 (length v))
                                                    (equal? (car v) "http")
                                                    (string? (car v))
                                                    (number? (caddr v))
                                                    (exact? (caddr v))
                                                    (integer? (caddr v))
                                                    (<= 1 (caddr v) 65535)))
                                             v))
                                 (raise-type-error
                                  'current-proxy-servers
                                  "list of list of scheme, string, and exact integer in [1,65535]"
                                  v))
                               (apply
                                list-immutable
                                (map (lambda (v)
                                       (list-immutable (string->immutable-string (car v))
                                                       (string->immutable-string (cadr v))
                                                       (caddr v)))
                                     v)))))
      
      (define url-error
        (lambda (fmt . args)
          (let ((s (string->immutable-string
                    (apply format fmt (map (lambda (arg)
                                             (if (url? arg)
                                                 (url->string arg)
                                                 arg))
                                           args)))))
            (raise (make-url-exception s (current-continuation-marks))))))
      
      (define url->string
        (lambda (url)
          (let ((scheme (url-scheme url))
                (user (url-user url))
                (host (url-host url))
                (port (url-port url))
                (path (url-path url))
                (query (url-query url))
                (fragment (url-fragment url)))
            (let ((sa string-append))
              (sa (if scheme (sa scheme ":") "")
                  (if (or user host port)
                      (sa
                       "//"
                       (if user (sa (uri-encode user) "@") "")
                       (if host host "")
                       (if port (sa ":" (number->string port)) "")
                       ; There used to be a "/" here, but that causes an
                       ; extra leading slash -- wonder why it ever worked!
                       )
                      "")
                  (combine-path-strings (url-path-absolute? url) path)
                  ;(if query (sa "?" (uri-encode query)) "")
                  (if (null? query) "" (sa "?"  (alist->form-urlencoded query)))
                  (if fragment (sa "#" (uri-encode fragment)) ""))))))

      ;; url->default-port : url -> num
      (define (url->default-port url)
        (let ([scheme (url-scheme url)])
          (cond [(not scheme) 80]
                [(string=? scheme "http") 80]
                [else (url-error "Scheme ~a not supported" (url-scheme url))])))

      ;; make-ports : url -> in-port x out-port
      (define (make-ports url proxy)
        (let ([port-number (if proxy
                             (caddr proxy)
                             (or (url-port url) (url->default-port url)))]
              [host (if proxy
                      (cadr proxy)
                      (url-host url))])
          (tcp-connect host port-number)))

      ;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port
      (define (http://getpost-impure-port get? url post-data strings)
        (let*-values
            ([(proxy) (assoc (url-scheme url) (current-proxy-servers))]
             [(server->client client->server) (make-ports url proxy)]
             [(access-string) (url->string
                               (if proxy
                                 url
                                 (make-url #f #f #f #f
                                           (url-path-absolute? url)
                                           (url-path url)
                                           (url-query url)
                                           (url-fragment url))))])
          (define (println . xs)
            (for-each (lambda (x) (display x client->server)) xs)
            (display "\r\n" client->server))
          (println (if get? "GET " "POST ") access-string " HTTP/1.0")
          (println "Host: " (url-host url)
                   (let ([p (url-port url)])
                     (if (equal? p (url->default-port url))
                       "" (format ":~a" p))))
          (when post-data (println "Content-Length: " (bytes-length post-data)))
          (for-each println strings)
          (println)
          (when post-data (display post-data client->server))
          (flush-output client->server)
          (tcp-abandon-port client->server)
          server->client))

      (define (file://->path url)
        ;; remove all ""s
        (let ([elts (remove* '("") (map path/param-path (url-path url)))]
              [abs? (url-path-absolute? url)])
          ;; See the discussion in PR8060 for an explanation
          (if (eq? 'windows url:os-type)
            (let ([host (or (url-host url) "")])
              (unless (equal? "" host) (set! elts (cons host elts)))
              (if (null? elts)
                (build-path) ; make it throw the error
                (let* ([fst (car elts)] [len (string-length fst)])
                  (if (or (not abs?) (eq? #\: (string-ref fst (sub1 len))))
                    (apply build-path elts)
                    (if (null? (cdr elts))
                      (build-path (string-append "\\\\" (car elts)))
                      (apply build-path
                             (string-append "\\\\" (car elts) "\\" (cadr elts))
                             (cddr elts)))))))
            (apply build-path (if abs? (cons "/" elts) elts)))))

      ;; file://get-pure-port : url -> in-port
      (define (file://get-pure-port url)
{'fraction_non_alphanumeric': 0.13510973890865158, 'fraction_numerical': 0.0032216927310557758, 'mean_word_length': 0.9360706860706861, 'pattern_counts': {'":': 5, '<': 5, '<?xml version=': 0, '>': 51, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 106, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4086423', 'n_tokens_mistral': 3759, 'n_tokens_neox': 3567, 'n_words': 1047}