#!/usr/bin/env ol

;;
;; This is the simple HTTP server
;; 
;; Requirements:
;;  ls
;;
;; Usage:
;;  $ echo ,load http/server| ol
;;   or
;;  $ echo ,load http/server| ol - --port 80
;;

(import (lib http))
(import (owl parse))
(import (otus ffi))
(import (lib system))

(define (yield) (syscall 1022 0))
(define (time format seconds) (syscall 201 format seconds))
(define uname (syscall 63))

(define OK "\e[0;32mOK\e[0;0m")
(define FAIL "\e[0;31mFAIL\e[0;0m")

; some constants for uptime
(define M 60)
(define H (* M 60))
(define D (* H 24))

; show footer
(define (send-uptime send)
   (send "<hr>")
   (send "<pre><small>")
   (let*((sysinfo (syscall 99))
         (rusage  (syscall 98))
         (utime (ref rusage 1))
         (stime (ref rusage 2))
         (uptime (ref sysinfo 1))
         (allocated (* (size nullptr) (ref (syscall 1117) 3))))
      (send
            "<div style='float:left'>"
            (time "%c" #false) "<br>"
            "rusage: "
                     (div      (car utime) D   ) " days, "
                     (div (rem (car utime) D) H) " hr, "
                     (div (rem (car utime) H) M) " min, "
                     (     rem (car utime) M   ) " sec."
                  " / "
                     (div      (car stime) D   ) " days, "
                     (div (rem (car stime) D) H) " hr, "
                     (div (rem (car stime) H) M) " min, "
                     (     rem (car stime) M   ) " sec." )
      (if uptime (send
            "<br>"
            "uptime: "
                     (div      uptime D   ) " days, "
                     (div (rem uptime D) H) " hr, "
                     (div (rem uptime H) M) " min, "
                     (     rem uptime M   ) " sec."))
      (send "</div>")
      (send "<div style='float:right'>"
            (car *version*) "/" (cdr *version*)
            ", "
            (ref uname 1) " " (ref uname 5)
            "<br>"
            "Bytes allocated: " allocated
            "</div>")
      (send "<div style='clear: both'></div></small></pre>")))


(define (starts-with string sub)
   (if (> (string-length sub) (string-length string))
      #false
      (string-eq? (substring string 0 (string-length sub)) sub)))

(define (str-find str char)
   (let loop ((string (str-iter str)) (n 0))
      (if (null? string)
         -1
         (if (char=? (car string) char)
            n
            (loop (force (cdr string)) (+ n 1))))))

(define port
   (if (and (> (length *command-line*) 1)
            (string-eq? (car *command-line*) "--port"))
      (string->number (cadr *command-line*) 10)
   else
      4000))

(define-library (parser)
   (import
      (otus lisp)
      (owl parse))
   (export ls split
      line-skips get-line
   )
(begin
   (define \d (fold (lambda (ff x) (put ff x #t)) {} (iota 10 #\0)))
   (define (\d? x) (\d x #f))
   (define \d: (put \d #\: #t))
   (define (\d:? x) (\d: x #f))
   (define \d- (put \d #\- #t))
   (define (\d-? x) (\d- x #f))
   (define \d/ (put \d #\/ #t))
   (define (\d/? x) (\d/ x #f))

   (define (space? x) (eq? x #\space))
   (define (non-space? x) (not (eq? x #\space)))
   (define S\D? (lambda (x) (not (or (space? x) (\d x #f)))))
   (define spaces (greedy+ (rune-if space?))) )
(cond-expand
   ; -=( Windows )=----------------------------
   (Windows
      (begin
         (define (ls folder)
            (list "cmd.exe" "/c" (string-append
               "dir " (s/\//\\/g folder))))

         (define line-skips 5)
         (define get-line (let-parse* (
               (bytes (greedy* (byte-if (lambda (x) (not (eq? x #\return))))))
               (| | (imm #\return))
               (endl (imm #\newline)))
            bytes))
         
         (define split (let-parse* (
               ; '10/07/2024  08:26 PM'
               (date (let-parse* (
                           (day           (greedy+ (rune-if \d/?)))
                           (*1 spaces)
                           (time          (greedy+ (rune-if \d:?)))
                           (*2 spaces)
                           (ampm          (greedy+ (rune-if non-space?))) )
                        (append day *1 time *2 ampm)))
               (|date | spaces)
               ; '<DIR>' or '35,821'
               (info (greedy+ (rune-if non-space?)))
               (|info | spaces)
               ; file name - the rest of line
               (filename (greedy+ rune)))
            (cons
               (runes->string
                  (append
                     date         |date |
                     info         |info |))
               (runes->string (s/\\/\// filename)))))

         (define parser #f)))
   ; -=( Unix )=-------------------------------
   (else
      (begin
         (define (ls folder)
            (list "/bin/sh" "-c" (string-append
               "ls -lah " folder)))

         (define line-skips 1)
         (define get-line (let-parse* (
               (bytes (greedy+ (byte-if (lambda (x) (not (eq? x #\newline))))))
               (endl (imm #\newline)))
            bytes))

         (define split (let-parse* (
               (permissions         (greedy+ (rune-if non-space?)))
               (sp1 (greedy+ (rune-if space?)))
               (number-of-hardlinks (greedy+ (rune-if non-space?)))
               (sp2 (greedy+ (rune-if space?)))
               (file-owner          (greedy+ (rune-if non-space?)))
               (sp3 (greedy+ (rune-if space?)))
               (file-group          (greedy+ (rune-if non-space?)))
               (sp4 (greedy+ (rune-if space?)))
               (file-size           (greedy+ (rune-if non-space?)))
               (sp5 (greedy+ (rune-if space?)))
               (date (any-of
                        (let-parse* (
                              (month         (greedy+ (rune-if S\D?)))
                              (sp1 (greedy+ (rune-if space?)))
                              (day           (greedy+ (rune-if \d?)))
                              (sp2 (greedy+ (rune-if space?)))
                              (time          (greedy+ (rune-if \d:?))) )
                           (append month sp1 day sp2 time))
                        (let-parse* (
                              (date          (greedy+ (rune-if \d-?)))
                              (sp1 (greedy+ (rune-if space?)))
                              (time          (greedy+ (rune-if \d:?))) )
                           (append date sp1 time))
                     ))
               (sp6 (greedy+ (rune-if space?)))
               ; file name - the rest of line
               (filename            (greedy+ rune)))
            (cons
               (runes->string
                  (append
                     permissions         sp1
                     number-of-hardlinks sp2
                     file-owner          sp3
                     file-group          sp4
                     file-size           sp5
                     date                sp6))
               (runes->string filename))))

         (define parser #f)))))
(import (parser))

(http:run port (lambda (fd request headers body close)
   (define (send . args)
      (for-each (lambda (arg)
         (display-to fd arg)) args))

   ; send file to output stream
   ; todo: list zip files content
   ; todo: add "download arrow" to download full folder or zip at the right of filename
   (define (sendfile filename)
      (define realname
         (s/%20/ /g
         (s/[?].*$// filename)))

      (for-each display (list "Sending '\e[0;33m" realname "\e[0;0m'... "))
      (define stat (syscall 4 (if (string? realname) (c-string realname))))

      (if stat
      (cond
         ; folder?
         ((not (zero? (band (ref stat 3) #o0040000)))
            (display "<folder> ")
            (define folder realname)
            ; list folder:
            (define Out (pipe))
            (define Pid (execvp (ls folder) #f Out))

            (send "HTTP/1.0 200 OK\r\n"
               "Connection: close\r\n"
               "Content-Type: " "text/html" "\r\n"
               "Server: " (car *version*) "/" (cdr *version*) "\r\n"
               "\r\n")
            (send "<meta charset='UTF-8'>")
            (send "<pre>")
            (send "<h3>" folder "</h3>")
            ; skip first dummy lines
            (define stream (let loop ((n line-skips) (stream (port->bytestream (car Out))))
                              ;; (print "n = " n)
                              (if (= n 0) stream
                              else
                                 (define parsed (try-parse get-line stream))
                                 (if parsed
                                    (let* ((line stream parsed))
                                       (loop (- n 1) stream))))))

            ; ls -la
            (let loop ((stream stream))
               (define parsed (try-parse get-line stream))
               (if parsed
                  (let* ((line stream parsed))
                     (unless (null? line)
                        (define columns (parse split line realname "not a file record" #f))
                        (if columns
                        then
                           ;; (print "columns: " columns)
                           (send (s/</&lt;/ (s/>/&gt;/ (car columns))))
                           (send
                              "<a href='"
                                 (cond
                                    ((string-eq? (cdr columns) ".")
                                       (string-append "/" realname))
                                    ((string-eq? (cdr columns) "..")
                                       ; don't show ".." for top folder
                                       ;; (unless (string-eq? realname ".")
                                          (print "filename: " (cdr columns))
                                          (print "realname: " realname)
                                          (print "    name: " (s/[\/\\]?[^\/]+$// realname))
                                          (string-append "/" (s/[\/\\]?[^\/]+$// realname)))
                                    (else
                                       (string-append "/" realname "/" (cdr columns))))
                              "'>"
                              (cdr columns)
                              "</a>")
                           ;(for-each send (cddr columns))
                           (send "<br/>")

                           (loop stream) )))))
            (send "</pre>\n")
            (send-uptime send)
            (close-pipe Out)

            (print OK)
            (close #t))
         ; regular file?
         ((not (zero? (band (ref stat 3) #o0100000)))
            (display "<file> ") ; TODO: get mimetypes
            (define file (open-binary-input-file realname))
            (if file
            then
               (send "HTTP/1.0 200 OK\r\n"
                  "Connection: close\r\n"
                  "Content-Type: "
                     (cond
                        ((m/.*\.html?$/ realname) "text/html")
                        ((m/.*\.js$/ realname) "text/javascript")
                        ((m/.*\.md$/ realname) "text/markdown")
                        ; other texts
                        ((m/.*\.css$/ realname) "text/css")
                        ((m/.*\.csv$/ realname) "text/csv")
                        ((m/.*\.txt$/ realname) "text/plain")
                        ; image
                        ((m/.*\.bmp$/ realname) "image/bmp")
                        ((m/.*\.gif$/ realname) "image/gif")
                        ((m/.*\.jpe?g$/ realname) "image/jpeg")
                        ((m/.*\.png$/ realname) "image/png")
                        ((m/.*\.svg$/ realname) "image/svg+xml")
                        ; audio/video
                        ((m/.*\.mp3$/ realname) "audio/mpeg")
                        ((m/.*\.opus$/ realname) "audio/opus")
                        ((m/.*\.mp4$/ realname) "video/mp4")
                        ((m/.*\.mpeg$/ realname) "video/mpeg")
                        ; others
                        ((m/.*\.pdf$/ realname) "application/pdf")
                        ((m/.*\.json$/ realname) "application/json")
                        ((m/.*\.xml$/ realname) "application/xml")
                        (else
                           "application/octet-stream"))
                     "\r\n"
                  "Content-Length: " (ref stat 8) "\r\n"
                  "Server: " (car *version*) "/" (cdr *version*) "\r\n"
                  "\r\n")
               (syscall 40 fd file 0 (ref stat 8)) ; sendfile
               (close-port file)
               (print OK)
               (close #t)
            else
               (send "HTTP/1.0 500 Internal Server Error\r\n"
                     "Connection: close\r\n"
                     "\r\n")
               (print FAIL)
               (close #t)))
         (else
            (send "HTTP/1.0 500 Internal Server Error\r\n"
                  "Connection: close\r\n"
                  "\r\n")
            (close #t))))
      (send "HTTP/1.0 404 Not Found\r\n"
            "Connection: close\r\n"
            "\r\n")
      (close #t))

   (print "fd: " fd ", request: " request)

   (when (port? fd)
      (define peer (syscall 51 fd))
      (print "Peer: " peer)
      (cond
         ((and (eq? (size request) 3)
               (string-eq? (ref request 1) "GET"))
            (define filename (ref request 2))
            (sendfile (if (string-eq? filename "/") "."
               (s/^\/+// filename)))) ; remove all leading "/"
         (else
            (sendfile 404))))
   (send "HTTP/1.0 404 Not Found\r\n"
         "\r\n")
   (close #t)))
