;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (jakob dynamic util)
  #:use-module (ice-9 match)
  #:use-module (jakob dynamic config)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (web request)
  #:use-module (web uri)
  #:export (assoc-value
            acons-normalize
            base64-length
            decode-form
            date<?
            hash-append!
            emoji?
            from-tor?
            from-i2p?
            from-darknet?))

(define (assoc-value alist key)
  "Return the `car' of `(assoc alist key)' if truthy"
  (let ((result (assoc-ref alist key)))
    (if result (car result) result)))

(define (acons-list k v alist)
  "Add V to K to alist as list"
  (let ((value (assoc-ref alist k)))
    (if value
        (let ((alist (alist-delete k alist)))
          (acons k (cons v value) alist))
        (acons k (list v) alist))))

(define (acons-normalize key value alist)
  "Add KEY -> VALUE to ALIST such that no entries for KEY are duplicates"
  (cons (cons key value)
        (filter (lambda (pair) (not (equal? (car pair) key))) alist)))

(define (list->alist lst)
  "Build a alist of list based on a list of key and values.

   Multiple values can be associated with the same key"
  (let next ((lst lst)
             (out '()))
    (if (null? lst)
        out
        (next (cdr lst) (acons-list (caar lst) (cdar lst) out)))))

(define (decode-form bv)
  "Convert BV querystring or form data to an alist"
  (define string (if (string? bv) bv (utf8->string bv)))
  (define pairs (map (cut string-split <> #\=)
                     ;; semi-colon and amp can be used as pair separator
                     (append-map (cut string-split <> #\;)
                                 (string-split string #\&))))
  (list->alist (map (match-lambda
                      ((key value)
                       (cons (uri-decode key) (uri-decode value)))) pairs)))

(define (base64-length n)
  "The length of the base64 string encoding `n' bytes."
  (inexact->exact (* 4 (ceiling (/ n 3.0)))))

(define (date<? d1 d2)
  "Return #t if D2 specifies a later date than D1"
  (time<? (date->time-utc d1) (date->time-utc d2)))

(define (hash-append! table key item)
  "Append ITEM to the list specified by KEY in TABLE

If KEY does not exist in TABLE, initialize kEY to (list ITEM)"
  (if (hash-ref table key)
      (hash-set! table key (cons item (hash-ref table key)))
      (hash-set! table key (list item))))

(define (emoji? str)
  "Determine if `str' is an 'acceptable' emoji character

Acceptable is the following subset:

- The 'Emoticons' block
- The 'Supplemental Symbols and Pictographs' block, excluding U+1F900
  through U+1F90B
- The hand symbols from the 'Miscellaneous Symbols and Pictographs'
  block
- The hand symbols from the 'Dingbats' block
- U+1F37B and U+1F440

Notably, U+1F946 isn't normally treated an emoji, but it is here. I
think it should be! As an American, I should be able to use pictographs
to express my God-given constitutional rights!"
  (and (string? str)
       (= 1 (string-length str))
       (let ((codepoint (char->integer
                         (first (string->list str)))))
         (or (<= #x1F600 codepoint #x1F64F)
             (<= #x1F90C codepoint #x1F9FF)
             (<= #x1F446 codepoint #x1F450)
             (<= #x270A codepoint #x270D)
             (= codepoint #x1F37B)
             (= codepoint #x1F440)))))

(define (from-tor? request)
  "Return whether or not REQUEST was sent by the Tor daemon"
  (if (%debug-enabled)
      #f
      (let ((originating-ip (assoc-ref (request-headers request) 'x-forwarded-for)))
        (or (string=? "127.0.0.1" originating-ip)
            (string=? "::1" originating-ip)))))

(define (from-i2p? request)
  "Return whether or not REQUEST was sent by i2pd"
  (if (%debug-enabled)
      #f
      (let ((originating-ip (assoc-ref (request-headers request) 'x-forwarded-for)))
        (and (or (string-prefix? "127." originating-ip)
                 (string-suffix? ":1" originating-ip))
             (not (from-tor? request))))))

(define (from-darknet? request)
  "Return whether or not REQUEST was sent by a darknet tunnel"
  (or (from-tor? request) (from-i2p? request)))