#lang racket/base

(require gregor
         racket/file
         racket/format
         racket/list
         racket/path
         racket/port
         racket/set
         racket/string
         racket/system
         "env-support.rkt"
         "path-output.rkt")

(provide coreutils-head
         coreutils-tail
         coreutils-wc
         coreutils-sort
         coreutils-uniq
         coreutils-cut
         coreutils-tee
         coreutils-tr
         coreutils-basename
         coreutils-dirname
         coreutils-realpath
         coreutils-readlink
         coreutils-stat
         coreutils-du
         coreutils-df
         coreutils-mktemp
         coreutils-printenv
         coreutils-env
         coreutils-date)

(define (arg->string arg)
  (cond
    [(path? arg) (path->string arg)]
    [(symbol? arg) (symbol->string arg)]
    [(string? arg) arg]
    [else (~a arg)]))

(define (arg->path arg)
  (string->path (arg->string arg)))

(define (read-lines-from-arguments args)
  (if (null? args)
      (port->lines (current-input-port))
      (append-map
       (λ (arg)
         (call-with-input-file* (arg->path arg) port->lines))
       args)))

(define (parse-n-option who args default)
  (cond
    [(and (pair? args)
          (member (arg->string (car args)) '("-n" "--lines")))
     (unless (pair? (cdr args))
       (raise-arguments-error who "missing line count" "arguments" args))
     (define n (string->number (arg->string (cadr args))))
     (unless (and (exact-integer? n) (>= n 0))
       (raise-arguments-error who "line count must be a non-negative integer"
                              "count" (cadr args)))
     (values n (cddr args))]
    [else
     (values default args)]))

(define (coreutils-head . args)
  (define-values (n files) (parse-n-option 'head args 10))
  (define lines (read-lines-from-arguments files))
  (for ([line (in-list (take lines (min n (length lines))))])
    (displayln line)))

(define (coreutils-tail . args)
  (define-values (n files) (parse-n-option 'tail args 10))
  (define lines (read-lines-from-arguments files))
  (define count (length lines))
  (for ([line (in-list (drop lines (max 0 (- count n))))])
    (displayln line)))

(define (bytes-for-arguments args)
  (if (null? args)
      (port->bytes (current-input-port))
      (apply bytes-append
             (for/list ([arg (in-list args)])
               (file->bytes (arg->path arg))))))

(define (coreutils-wc . args)
  (define lines? #f)
  (define words? #f)
  (define bytes? #f)
  (define files '())
  (for ([arg (in-list args)])
    (define text (arg->string arg))
    (cond
      [(string=? text "-l") (set! lines? #t)]
      [(string=? text "-w") (set! words? #t)]
      [(or (string=? text "-c") (string=? text "--bytes")) (set! bytes? #t)]
      [(string-prefix? text "-")
       (raise-arguments-error 'wc "unsupported option" "option" text)]
      [else (set! files (append files (list arg)))]))
  (when (not (or lines? words? bytes?))
    (set! lines? #t)
    (set! words? #t)
    (set! bytes? #t))
  (define bs (bytes-for-arguments files))
  (define text (bytes->string/utf-8 bs #\?))
  (define results
    (filter (λ (x) x)
            (list (if lines? (number->string (length (regexp-match* #rx"\n" text))) #f)
                  (if words? (number->string (length (regexp-match* #px"\\S+" text))) #f)
                  (if bytes? (number->string (bytes-length bs)) #f))))
  (displayln (string-join results " ")))

(define (coreutils-sort . args)
  (define reverse? #f)
  (define numeric? #f)
  (define files '())
  (for ([arg (in-list args)])
    (define text (arg->string arg))
    (cond
      [(or (string=? text "-r") (string=? text "--reverse")) (set! reverse? #t)]
      [(or (string=? text "-n") (string=? text "--numeric-sort")) (set! numeric? #t)]
      [(string-prefix? text "-")
       (raise-arguments-error 'sort "unsupported option" "option" text)]
      [else (set! files (append files (list arg)))]))
  (define (less? a b)
    (if numeric?
        (< (or (string->number a) +inf.0)
           (or (string->number b) +inf.0))
        (string<? a b)))
  (define sorted (sort (read-lines-from-arguments files) less?))
  (for ([line (in-list (if reverse? (reverse sorted) sorted))])
    (displayln line)))

(define (run-lengths lines)
  (let loop ([rest lines] [current #f] [count 0] [result '()])
    (cond
      [(null? rest)
       (reverse (if current (cons (cons current count) result) result))]
      [(and current (string=? current (car rest)))
       (loop (cdr rest) current (add1 count) result)]
      [else
       (loop (cdr rest)
             (car rest)
             1
             (if current (cons (cons current count) result) result))])))

(define (coreutils-uniq . args)
  (define count? #f)
  (define files '())
  (for ([arg (in-list args)])
    (define text (arg->string arg))
    (cond
      [(or (string=? text "-c") (string=? text "--count")) (set! count? #t)]
      [(string-prefix? text "-")
       (raise-arguments-error 'uniq "unsupported option" "option" text)]
      [else (set! files (append files (list arg)))]))
  (for ([entry (in-list (run-lengths (read-lines-from-arguments files)))])
    (if count?
        (printf "~a ~a\n" (~a (cdr entry) #:min-width 7 #:align 'right) (car entry))
        (displayln (car entry)))))

(define (parse-field-spec text)
  (define n (string->number text))
  (unless (and (exact-positive-integer? n))
    (raise-arguments-error 'cut "only one positive field number is supported"
                           "field" text))
  n)

(define (coreutils-cut . args)
  (define delimiter "\t")
  (define field #f)
  (define files '())
  (let loop ([rest args])
    (cond
      [(null? rest) (void)]
      [(member (arg->string (car rest)) '("-d" "--delimiter"))
       (unless (pair? (cdr rest))
         (raise-arguments-error 'cut "missing delimiter" "arguments" args))
       (set! delimiter (arg->string (cadr rest)))
       (loop (cddr rest))]
      [(member (arg->string (car rest)) '("-f" "--fields"))
       (unless (pair? (cdr rest))
         (raise-arguments-error 'cut "missing field" "arguments" args))
       (set! field (parse-field-spec (arg->string (cadr rest))))
       (loop (cddr rest))]
      [(string-prefix? (arg->string (car rest)) "-")
       (raise-arguments-error 'cut "unsupported option" "option" (car rest))]
      [else
       (set! files (append files (list (car rest))))
       (loop (cdr rest))]))
  (unless field
    (raise-arguments-error 'cut "expected -f FIELD" "arguments" args))
  (for ([line (in-list (read-lines-from-arguments files))])
    (define parts (string-split line delimiter #:trim? #f #:repeat? #f))
    (when (<= field (length parts))
      (displayln (list-ref parts (sub1 field))))))

(define (coreutils-tee . args)
  (define append? #f)
  (define files '())
  (for ([arg (in-list args)])
    (define text (arg->string arg))
    (cond
      [(or (string=? text "-a") (string=? text "--append")) (set! append? #t)]
      [(string-prefix? text "-")
       (raise-arguments-error 'tee "unsupported option" "option" text)]
      [else (set! files (append files (list (arg->path arg))))]))
  (define outputs
    (for/list ([path (in-list files)])
      (open-output-file path #:exists (if append? 'append 'truncate/replace))))
  (dynamic-wind
    void
    (λ ()
      (let loop ()
        (define bs (read-bytes 4096 (current-input-port)))
        (unless (eof-object? bs)
          (write-bytes bs (current-output-port))
          (for ([out (in-list outputs)]) (write-bytes bs out))
          (loop))))
    (λ ()
      (for ([out (in-list outputs)]) (close-output-port out)))))

(define (expand-character-set text)
  (define chars (string->list text))
  (let loop ([rest chars] [result '()])
    (cond
      [(null? rest)
       (reverse result)]
      [(and (pair? (cdr rest))
            (pair? (cddr rest))
            (char=? (cadr rest) #\-)
            (char<=? (car rest) (caddr rest)))
       (define start (char->integer (car rest)))
       (define end (char->integer (caddr rest)))
       (define expanded
         (for/list ([code (in-range start (add1 end))])
           (integer->char code)))
       (loop (cdddr rest) (append (reverse expanded) result))]
      [else
       (loop (cdr rest) (cons (car rest) result))])))

(define (squeeze-characters text chars)
  (define squeeze? (list->seteq chars))
  (list->string
   (let loop ([rest (string->list text)] [previous #f] [result '()])
     (cond
       [(null? rest) (reverse result)]
       [else
        (define ch (car rest))
        (if (and previous
                 (char=? ch previous)
                 (set-member? squeeze? ch))
            (loop (cdr rest) previous result)
            (loop (cdr rest) ch (cons ch result)))]))))

(define (translate-characters text from to)
  (when (null? to)
    (raise-arguments-error 'tr "SET2 must not be empty" "SET2" to))
  (define last-to (last to))
  (define mapping
    (for/hash ([ch (in-list from)] [i (in-naturals)])
      (values ch (if (< i (length to)) (list-ref to i) last-to))))
  (list->string
   (for/list ([ch (in-string text)])
     (hash-ref mapping ch ch))))

(define (delete-characters text chars)
  (define delete-set (list->seteq chars))
  (list->string
   (for/list ([ch (in-string text)]
              #:unless (set-member? delete-set ch))
     ch)))

(define (coreutils-tr . args)
  (define delete? #f)
  (define squeeze? #f)
  (define sets '())
  (for ([arg (in-list args)])
    (define text (arg->string arg))
    (cond
      [(or (string=? text "-d") (string=? text "--delete"))
       (set! delete? #t)]
      [(or (string=? text "-s") (string=? text "--squeeze-repeats"))
       (set! squeeze? #t)]
      [(or (string=? text "-ds") (string=? text "-sd"))
       (set! delete? #t)
       (set! squeeze? #t)]
      [(string-prefix? text "-")
       (raise-arguments-error 'tr "unsupported option" "option" text)]
      [else
       (set! sets (append sets (list text)))]))
  (define text (port->string (current-input-port)))
  (cond
    [(and delete? squeeze?)
     (unless (= (length sets) 2)
       (raise-arguments-error 'tr "expected SET1 SET2 with -ds" "arguments" args))
     (define deleted
       (delete-characters text (expand-character-set (first sets))))
     (display
      (squeeze-characters deleted (expand-character-set (second sets))))]
    [delete?
     (unless (= (length sets) 1)
       (raise-arguments-error 'tr "expected one character set with -d" "arguments" args))
     (display
      (delete-characters text (expand-character-set (first sets))))]
    [(and squeeze? (= (length sets) 1))
     (display
      (squeeze-characters text (expand-character-set (first sets))))]
    [else
     (unless (= (length sets) 2)
       (raise-arguments-error 'tr "expected SET1 SET2" "arguments" args))
     (define to (expand-character-set (second sets)))
     (define translated
       (translate-characters text
                             (expand-character-set (first sets))
                             to))
     (display
      (if squeeze?
          (squeeze-characters translated to)
          translated))]))

(define (coreutils-basename . args)
  (unless (= (length args) 1)
    (raise-arguments-error 'basename "expected one path" "arguments" args))
  (define name (file-name-from-path (arg->path (car args))))
  (displayln (if name (path->string name) "")))

(define (coreutils-dirname . args)
  (unless (= (length args) 1)
    (raise-arguments-error 'dirname "expected one path" "arguments" args))
  (define-values (base name dir?) (split-path (arg->path (car args))))
  (displayln
   (cond
     [(path? base) (path->rash-string base)]
     [(eq? base 'relative) "."]
     [else (path->rash-string (arg->path (car args)))])))

(define (coreutils-realpath . args)
  (unless (= (length args) 1)
    (raise-arguments-error 'realpath "expected one path" "arguments" args))
  (displayln (path->rash-string (simplify-path (path->complete-path (arg->path (car args))) #t))))

(define (coreutils-readlink . args)
  (unless (= (length args) 1)
    (raise-arguments-error 'readlink "expected one path" "arguments" args))
  (define path (arg->path (car args)))
  (unless (link-exists? path)
    (raise-arguments-error 'readlink "path is not a symbolic link" "path" path))
  (displayln (path->rash-string (resolve-path path))))

(define (coreutils-stat . args)
  (when (null? args)
    (raise-arguments-error 'stat "expected at least one path" "arguments" args))
  (for ([arg (in-list args)])
    (define path (arg->path arg))
    (unless (or (file-exists? path) (directory-exists? path) (link-exists? path))
      (raise-arguments-error 'stat "path does not exist" "path" path))
    (printf "Path: ~a\n" (path->rash-string (path->complete-path path)))
    (printf "Type: ~a\n"
            (cond [(link-exists? path) "link"]
                  [(directory-exists? path) "directory"]
                  [else "file"]))
    (when (file-exists? path) (printf "Size: ~a\n" (file-size path)))
    (printf "Modified: ~a\n" (file-or-directory-modify-seconds path))))

(define (path-size path)
  (cond
    [(file-exists? path) (file-size path)]
    [(directory-exists? path)
     (for/sum ([entry (in-list (directory-list path #:build? #t))])
       (path-size entry))]
    [else 0]))

(define (human-size n)
  (cond
    [(>= n (* 1024 1024 1024)) (format "~aG" (~r (/ n (* 1024.0 1024 1024)) #:precision '(= 1)))]
    [(>= n (* 1024 1024)) (format "~aM" (~r (/ n (* 1024.0 1024)) #:precision '(= 1)))]
    [(>= n 1024) (format "~aK" (~r (/ n 1024.0) #:precision '(= 1)))]
    [else (format "~aB" n)]))

(define (coreutils-du . args)
  (define human? #f)
  (define paths '())
  (for ([arg (in-list args)])
    (define text (arg->string arg))
    (cond
      [(or (string=? text "-h") (string=? text "--human-readable")) (set! human? #t)]
      [(string-prefix? text "-")
       (raise-arguments-error 'du "unsupported option" "option" text)]
      [else (set! paths (append paths (list (arg->path arg))))]))
  (when (null? paths) (set! paths (list (current-directory))))
  (for ([path (in-list paths)])
    (define size (path-size path))
    (printf "~a\t~a\n" (if human? (human-size size) size) (path->rash-string path))))

(define (coreutils-df . args)
  (unless (null? args)
    (raise-arguments-error 'df "this portable implementation does not accept arguments yet"
                           "arguments" args))
  (displayln "Filesystem")
  (for ([root (in-list (filesystem-root-list))])
    (displayln (path->rash-string root))))

(define (coreutils-mktemp . args)
  (define directory? #f)
  (define template "tmp~a")
  (for ([arg (in-list args)])
    (define text (arg->string arg))
    (cond
      [(or (string=? text "-d") (string=? text "--directory")) (set! directory? #t)]
      [(string-prefix? text "-")
       (raise-arguments-error 'mktemp "unsupported option" "option" text)]
      [else (set! template text)]))
  (define result (make-temporary-file template (if directory? 'directory #f)))
  (displayln (path->rash-string result)))

(define (environment-name->string name)
  (bytes->string/locale name))

(define (environment-value->string value)
  (bytes->string/locale value))

(define (write-environment env)
  (define names
    (sort (environment-variables-names env)
          string<?
          #:key environment-name->string))
  (for ([name (in-list names)])
    (define value (environment-variables-ref env name))
    (when value
      (printf "~a=~a\n" (environment-name->string name) (environment-value->string value)))))

(define (coreutils-printenv . args)
  (define env (current-environment-variables))
  (if (null? args)
      (write-environment env)
      (for ([arg (in-list args)])
        (define name (string->bytes/locale (arg->string arg)))
        (define value (environment-variables-ref env name))
        (when value (displayln (environment-value->string value))))))

(define assignment-rx #px"^([^=]+)=(.*)$")

(define (value->environment-string value)
  (cond
    [(string? value) value]
    [(path? value) (path->string value)]
    [(symbol? value) (symbol->string value)]
    [(bytes? value) (bytes->string/locale value)]
    [else (~a value)]))

(define (split-environment-arguments args)
  (let loop ([rest args] [assignments '()])
    (cond
      [(null? rest)
       (values (reverse assignments) '())]
      [(environment-assignment? (car rest))
       (define assignment (car rest))
       (loop (cdr rest)
             (cons (cons (environment-assignment-name assignment)
                         (environment-assignment-value assignment))
                   assignments))]
      [else
       (define text (arg->string (car rest)))
       (define match (regexp-match assignment-rx text))
       (if match
           (loop (cdr rest)
                 (cons (cons (list-ref match 1)
                             (list-ref match 2))
                       assignments))
           (values (reverse assignments) rest))])))

(define (run-external-environment-command command)
  (define executable
    (find-executable-path (arg->string (car command))))
  (unless executable
    (raise-arguments-error 'env "command was not found on PATH"
                           "command" (car command)))
  (define ok?
    (apply system* executable (map arg->string (cdr command))))
  (unless ok?
    (raise-arguments-error 'env "command returned a non-zero exit status"
                           "command" (car command))))

(define (coreutils-env . args)
  (define-values (assignments command)
    (split-environment-arguments args))
  (define env
    (environment-variables-copy (current-environment-variables)))
  (for ([assignment (in-list assignments)])
    (environment-variables-set!
     env
     (string->bytes/locale (car assignment))
     (string->bytes/locale
      (value->environment-string (cdr assignment)))))
  (if (null? command)
      (write-environment env)
      (parameterize ([current-environment-variables env])
        (define runner (current-coreutils-command-runner))
        (define handled?
          (and runner (runner command)))
        (unless handled?
          (run-external-environment-command command)))))

(define (coreutils-date . args)
  (define utc? #f)
  (define iso? #f)
  (define timezone #f)
  (define pattern #f)
  (let loop ([rest args])
    (cond
      [(null? rest) (void)]
      [(member (arg->string (car rest)) '("-u" "--utc"))
       (set! utc? #t)
       (loop (cdr rest))]
      [(member (arg->string (car rest)) '("-I" "--iso" "--iso-8601"))
       (set! iso? #t)
       (loop (cdr rest))]
      [(string=? (arg->string (car rest)) "--tz")
       (unless (pair? (cdr rest))
         (raise-arguments-error 'date "missing time zone" "arguments" args))
       (set! timezone (arg->string (cadr rest)))
       (loop (cddr rest))]
      [(string=? (arg->string (car rest)) "--format")
       (unless (pair? (cdr rest))
         (raise-arguments-error 'date "missing CLDR format" "arguments" args))
       (set! pattern (arg->string (cadr rest)))
       (loop (cddr rest))]
      [else
       (raise-arguments-error 'date "unsupported argument" "argument" (car rest))]))
  (define m
    (cond
      [utc? (now/moment/utc)]
      [timezone (now/moment #:tz timezone)]
      [else (now/moment)]))
  (displayln
   (cond
     [pattern (~t m pattern)]
     [iso? (moment->iso8601 m)]
     [else (~t m "EEE MMM dd HH:mm:ss xxx yyyy")])))