; vim:syntax=scheme filetype=scheme expandtab
;;; This module contains general purpose functions.

(define-module (junkie defs))

(use-modules (srfi srfi-1)
             (ice-9 regex)
             (ice-9 optargs)
             (ice-9 format)
             (ice-9 threads)
             (junkie runtime)
             (junkie tools))

;; Some definitions the user likely want to use

(define-public log-emerg   0) (define-public log-alert  1) (define-public log-crit 2) (define-public log-err   3) (define-public log-error 3)
(define-public log-warning 4) (define-public log-notice 5) (define-public log-info 6) (define-public log-debug 7)

(define-syntax slog
  (syntax-rules ()
    ((_ lvl fmt ...) (let* ((loc   (current-source-location))
                            (stack (make-stack #t))
                            (msg   ((@ (ice-9 format) format) #f fmt ...))
                            (file  (or (and=> (assq-ref loc 'filename) basename) "<some file>"))
                            (func  (or (and=> (procedure-name (frame-procedure (stack-ref stack 1))) symbol->string) "")))
                       (primitive-log lvl file func msg)))))
(export-syntax slog)

; This one might be usefull to display all help available
(define-public (help . args)
  (for-each (lambda (l)
              (display l)(newline)
              (display "------------------\n"))
            (apply ? args)))


(define TCP_NODELAY 1) ; unknown from GUILE

; Start a server that executes anything (from localhost only)
(define*-public (start-repl-server #:key
                                   (port 29000)
                                   (prompt (lambda () "junkie> "))
                                   (env-or-module (resolve-module '(junkie defs))))
  (letrec ((consume-white-spaces (lambda (port)
                                   (let ((c (peek-char port)))
                                     (cond ((eqv? c #\eot) (begin
                                                             (display "Bye!\r\n")
                                                             (throw 'quit)))
                                           ((char-whitespace? c) (begin
                                                                   (read-char)
                                                                   (consume-white-spaces port))))))))
    (let* ((repl (lambda ()
                   (let ((reader  (lambda (port)
                                    ; flush the prompt down to TCP segment by disabling Nagle (for cases when the client is a program)
                                    (setsockopt port IPPROTO_TCP TCP_NODELAY 1)
                                    (display (prompt))
                                    (force-output)
                                    (setsockopt port IPPROTO_TCP TCP_NODELAY 0)
                                    (consume-white-spaces port)
                                    (read port)))
                         (evaler  (lambda (expr)
                                    (catch #t
                                           (lambda () (eval expr env-or-module))
                                           (lambda (key . args)
                                             (if (eq? key 'quit) (apply throw 'quit args))
                                             `(error ,key ,args)))))
                         (printer pp))
                     (set-thread-name "J-repl-client")
                     ; Use repl defined in ice-9 boot
                     (repl reader evaler printer)))))
      (make-thread (lambda ()
                     (set-thread-name "J-repl-server")
                     (start-server (inet-aton "127.0.0.1") port repl))))))

; Cannot define this because of poor(?) handling of circular dependancy in guile compiler (http://debbugs.gnu.org/cgi/bugreport.cgi?bug=12459)
#;(define*-public (start-web-server #:key (port 8080))
  ((@ (junkie www monitor) register))
  ((@ (junkie duplicogram) register))
  ((@ (junkie writer) register))
  ((@ (junkie www server) start) port))

; An equivalent of the old fashionned display command line option
(define-public (display-parameters)
  (let ((display-one (lambda (p)
                       (simple-format #t "~a: ~a\n" p (get-parameter-value p)))))
    (for-each display-one (parameter-names))))

; Display the memory consumption due to Guile
(define-public (guile-mem-stats)
  (let* ((stats     (gc-stats))
         (use-bdwgc (assq 'heap-size stats))
         (sum-size (lambda (x s)
                     (let ((a (car x))
                           (b (cdr x)))
                       (+ s (- b a))))))
    (if use-bdwgc
        (assq-ref stats 'heap-size)
        (fold sum-size 0 (assq-ref stats 'cell-heap-segments)))))

; Display the memory consumption and allocation due to the redimentionable arrays
(define-public (array-mem-stats)
  (let* ((tot-used-bytes     0)
         (tot-malloced-bytes 0)
         (stats              (filter-map (lambda (n)
                                           (let* ((s              (array-stats n)))
                                             (if (> (assq-ref s 'nb-malloced) 0)
                                                 (let* ((used-bytes     (* (- (assq-ref s 'nb-used)
                                                                              (assq-ref s 'nb-holes))
                                                                           (assq-ref s 'entry-size)))
                                                        (malloced-bytes (* (assq-ref s 'nb-malloced)
                                                                           (assq-ref s 'entry-size)))
                                                        (compactness    (exact->inexact (/ used-bytes malloced-bytes))))
                                                   (set! tot-used-bytes     (+ tot-used-bytes     used-bytes))
                                                   (set! tot-malloced-bytes (+ tot-malloced-bytes malloced-bytes))
                                                   `(,n . (,@s
                                                            (used-bytes . ,used-bytes)
                                                            (malloced-bytes . ,malloced-bytes)
                                                            (compactness . ,compactness))))
                                                 #f)))
                                         (array-names))))
    `(,@(sort stats
              (lambda (a b)
                (< (assq-ref (cdr a) 'malloced-bytes)
                   (assq-ref (cdr b) 'malloced-bytes))))
       (total . ((used-bytes . ,tot-used-bytes)
                 (malloced-bytes . ,tot-malloced-bytes)
                 (compactness . ,(exact->inexact (if (> tot-malloced-bytes 0)
                                                     (/ tot-used-bytes tot-malloced-bytes)
                                                     1))))))))

; Display malloc statistics
(define-public (mallocer-mem-stats)
  (let* ((size     (lambda (name) (cdr (assoc 'tot-size (mallocer-stats name)))))
         (tot-size (apply + (map size (mallocer-names))))
         (stat-one (lambda (name) (cons name (size name)))))
    (append!
      (map stat-one (mallocer-names))
      (list (cons "total" tot-size)))))

; Uniquify a sorted list, for what it's worth...
(define-public (uniq l . rest)
  (let ((eq (if (null? rest)
                equal?
                (car rest))))
    (reverse
      (fold
        (lambda (i p)
          (if (or (null? p)
                  (not (eq (car p) i)))
              (cons i p)
              p))
        '() l))))

; get the percentage of duplicate frames over the total number (check out if the
; port mirroring is correctly set)
(define-public (duplicate-percentage)
  (let* ((devs (uniq (sort (map (lambda (i)
                                  (cons i (assq-ref (iface-stats i) 'id)))
                                (iface-names))
                           (lambda (p1 p2) (< (cdr p1) (cdr p2))))
                     (lambda (p1 p2) (= (cdr p1) (cdr p2)))))
         (devs (append devs (list (cons "multi-ifaces" 255))))) ; 255 is like, hum, special...
    (map (lambda (dev)
           (let* ((name   (car dev))
                  (dev-id (cdr dev))
                  (stats  (deduplication-stats dev-id))
                  (dups   (assq-ref stats 'dup-found))
                  (nodups (assq-ref stats 'nodup-found))
                  (pkts   (+ dups nodups)))
             (list name
                   (if (> pkts 0)
                       (exact->inexact (* 100 (/ dups pkts)))
                       0))))
         devs)))

; get the percentage of dropped packets
(define-public (dropped-percentage)
  (let* ((tot-drop (fold (lambda (iface prevs)
                           (let* ((stats     (iface-stats iface))
                                  (dropped   (assq-ref stats 'new-dropped))
                                  (received  (+ dropped (assq-ref stats 'new-received))) ; on our Linux received does not include dropped
                                  (prev-recv (car prevs))
                                  (prev-drop (cdr prevs)))
                             (catch 'wrong-type-arg
                                    (lambda () (cons (+ prev-recv received) (+ prev-drop dropped)))
                                    (lambda (key . args) prevs))))
                         '(0 . 0) (iface-names)))
         (total    (car tot-drop))
         (dropped  (cdr tot-drop)))
    (if (> total 0)
        (exact->inexact (/ (* 100 dropped) total))
        0)))

; backward compatible function set-ifaces
(define-public (ifaces-matching pattern)
  (let ((ifaces (list-ifaces)))
    (if (list? ifaces)
        (filter
          (lambda (ifname) (string-match pattern ifname))
          (list-ifaces)))))

(define-public (closed-ifaces-matching pattern)
  (let* ((matching (ifaces-matching pattern))
         (opened   (iface-names)))
    (lset-difference equal? matching opened)))

(define*-public (set-ifaces pattern #:key (capfilter "") (bufsize 0) (caplen 0))
  (for-each
    (lambda (ifname) (open-iface ifname #t capfilter caplen bufsize))
    (closed-ifaces-matching pattern)))

(define (unpartitionable-filter capfilter partition-type)
  (letrec ((main-filter (if (eq? partition-type 'port)
                          "(tcp or udp)"
                          "ip"))
           (with-user   (if (string-null? capfilter)
                          main-filter
                          (format #f "((~a) and (~a))" capfilter main-filter))))
    ; **BEWARE**: Due to a bug in libpcap 'test or (vlan and test)' works as expected
    ;             while '(vlan and test) or test' DO NOT!
    ;             Also, 'not vlan' does not work as expected.
    (format #f "not ~a and not (vlan and ~a)" with-user with-user)))

(define (partitionable-filter mask i capfilter partition-type)
  (let* ((main-filter  (if (eq? 'port partition-type)
                         (format #f "((tcp[0:2] + tcp[2:2]) & 0x~x = ~d) or ((udp[0:2] + udp[2:2]) & 0x~x = ~d)" mask i mask i)
                         (format #f "((ip[14:2] + ip[18:2]) & 0x~x = ~d)" mask i)))
         (with-user   (if (string-null? capfilter)
                        main-filter
                        (format #f "((~a) and (~a))" capfilter main-filter))))
    (format #f "(~a) or (vlan and (~a))" with-user with-user)))

; build a list of pcap filter suitable to split traffic through 2^n+1 processes
; n must be >= 1
; partition-type must be 'port or 'ip
(define* (pcap-filters-for-split n #:key (capfilter "") (partition-type 'port))
  (letrec ((mask        (- (ash 1 n) 1))
           (next-filter (lambda (prevs i)
                          (if (> i mask)
                            prevs
                            (next-filter (cons (partitionable-filter mask i capfilter partition-type) prevs) (1+ i)))))
           (unpartitionable (unpartitionable-filter capfilter partition-type)))
    (next-filter (list unpartitionable) 0)))

; Equivalent of set-ifaces for multiple CPUs
(define*-public (open-iface-multiple n ifname #:key (capfilter "") (bufsize 0) (caplen 0) (promisc #t) (partition-type 'port))
  (let* ((filters     (pcap-filters-for-split n #:capfilter capfilter #:partition-type partition-type))
         (open-single (lambda (flt) (open-iface ifname promisc flt caplen bufsize))))
    (for-each open-single filters)))

(define*-public (open-pcap-multiple n fname #:key (capfilter "") (realtime #f) (localtime #f) (loop #f) (partition-type 'port))
  (let* ((filters     (pcap-filters-for-split n #:capfilter capfilter #:partition-type partition-type))
         (open-single (lambda (flt) (open-pcap fname realtime flt localtime loop))))
    (for-each open-single filters)))

(define*-public (set-ifaces-multiple n pattern #:rest r)
  (make-thread (lambda ()
    (set-thread-name "J-set-ifaces")
    (let loop ()
      (for-each
        (lambda (ifname) (apply open-iface-multiple `(,n ,ifname ,@r)))
        (closed-ifaces-matching pattern))
      (sleep 30)
      (loop)))))

; A simple function to check wether the agentx module is available or not
(define-public have-snmp (false-if-exception (resolve-interface '(agentx tools))))

; Helper function handy for answering SNMP queries : cache a result of some expensive function for some time
(define-public (cached timeout)
  (let* ((hash      (make-hash-table 50)) ; hash from (func . args) into (timestamp . value)
         (ts-of     car)
         (value-of  cdr)
         (mutex     (make-mutex)))
    (lambda func-args
      (with-mutex mutex
                  (let* ((hash-v (hash-ref hash func-args))
                         (now    (current-time)))
                    (if (and hash-v (<= now (+ timeout (ts-of hash-v))))
                        (value-of hash-v)
                        (let ((v (primitive-eval func-args)))
                          (hash-set! hash func-args (cons now v))
                          v)))))))

; Helper functions that comes handy when configuring muxer hashes

(define-public (make-mux-hash-controller coll-avg-min coll-avg-max h-size-min h-size-max)
  (lambda (proto)
    (let* ((stats    (mux-stats proto))
           (h-size   (assq-ref stats 'hash-size))
           (colls    (assq-ref stats 'nb-collisions))
           (lookups  (assq-ref stats 'nb-lookups))
           (coll-avg (if (> lookups 0) (/ colls lookups) 0))
           (resize   (lambda (coll-avg new-h-size)
                       (let ((new-max-children (* new-h-size coll-avg-max 10)))
                         (slog log-info "Collision avg of ~a is ~a. Setting hash size to ~a (and max children to ~a)"
                               proto (exact->inexact coll-avg) new-h-size new-max-children)
                         (set-mux-hash-size proto new-h-size)
                         (set-max-children proto new-max-children)))))
      (if (< coll-avg coll-avg-min) ; then make future hashes smaller
          (if (> h-size h-size-min)
              (resize coll-avg (max h-size-min (round (/ h-size 2))))))
      (if (> coll-avg coll-avg-max) ; then make future hashes bigger
          (if (< h-size h-size-max)
              (resize coll-avg (min h-size-max (* h-size 2))))))))

;; A thread that will limit UDP/TCP muxers to some hash size and collision rates

(define*-public (start-resizer-thread  #:key
                                (min-collision-avg 4)   ; collision average under which we will make hash tables bigger
                                (max-collision-avg 16)  ; collision average above which we will make hash tables smaller
                                (min-hash-size     11)  ; minimal hash table size under which we won't venture
                                (max-hash-size     353) ; maximal etc
                                ; So by default we can happily store 353*16*2=11k different sockets between two given hosts
                                (period            60)) ; how many seconds we wait between two measurments (it's important to wait for the stats to settle)
  (let* ((limiter (make-mux-hash-controller
                    min-collision-avg max-collision-avg min-hash-size max-hash-size))
         (thread  (lambda ()
                    (set-thread-name "J-hash-resizer")
                    (let loop ()
                      (sleep period)
                      (limiter "TCP")
                      (limiter "UDP")
                      ;; Achtung!
                      ;; We use the statistics of the running multiplexers to change the settings of the future multiplexers.
                      ;; So in a situation where the multiplexers are not often recycled we will keep changing settings for
                      ;; multiplexers that are actually unafected by these changes. So we'd better reserve this for short
                      ;; lived multiplexers such as TCP and UDP, and not long lived ones such as IP.
                      ;(limiter "IPv4")
                      ;(limiter "IPv6")
                      (loop)))))
    (make-thread thread)))

; A thread that will periodically report on stdout the number of TCP/UDP simultaneous streams

(define-public (report-cnx period)
  (let ((thread (lambda (period)
                  (set-thread-name "J-report-cnx")
                  (let ((max-tcp 0)
                        (max-udp 0))
                    (let loop ()
                      (let ((cur-tcp (assq-ref (proto-stats "TCP") 'nb-parsers))
                            (cur-udp (assq-ref (proto-stats "UDP") 'nb-parsers)))
                        (if (> cur-tcp max-tcp) (set! max-tcp cur-tcp))
                        (if (> cur-udp max-udp) (set! max-udp cur-udp))
                        (simple-format #t "Current TCP:~a UDP:~a total:~a / Max TCP:~a UDP:~a total:~a~%"
                              cur-tcp cur-udp (+ cur-tcp cur-udp)
                              max-tcp max-udp (+ max-tcp max-udp))
                        (sleep period)
                        (loop)))))))
    (make-thread thread period)))

