~dieggsy/dieggsy.com

7209edaf5833243eae60b358c22ef9abe9a84adb — dieggsy 2 months ago 65453ce master
Latest changes
M cgitrc => cgitrc +4 -3
@@ 7,16 7,15 @@ root-desc=You can browse my self-hosted repos here. Neat. See also: https://gith
favicon=/
snapshots=tar.gz
branch-sort=age
repository-sort=age
clone-prefix=https://code.dieggsy.com
enable-index-owner=0

# source-filter=/srv/http/dieggsy.com/js/syntax.py
# source-filter=/usr/lib/cgit/filters/syntax-highlighting.sh
source-filter=/srv/http/dieggsy.com/syntax-highlighting.py

section-from-path=1
head-include=/etc/viewport.html
css=/css/cgit.css
# css=/css/cgit.css
logo=
header=/srv/http/dieggsy.com/preamble.html



@@ 24,3 23,5 @@ about-filter=/srv/http/dieggsy.com/about-formatting.sh
readme=:README.org

scan-path=/srv/git

virtual-root=/
\ No newline at end of file

M css/fonts.css => css/fonts.css +8 -0
@@ 48,6 48,14 @@

@font-face{
    font-family: 'Fira Sans';
    src: url('/static/font/woff2/FiraSans-Light.woff2') format('woff2'),
         url('/static/font/ttf/FiraSans-Light.ttf') format('truetype');
    font-weight: 300;
    font-style: normal;
}

@font-face{
    font-family: 'Fira Sans';
    src: url('/static/font/woff2/FiraSans-Italic.woff2') format('woff2'),
         url('/static/font/ttf/FiraSans-Italic.ttf') format('truetype');
    font-weight: 400;

M css/org.css => css/org.css +10 -0
@@ 174,4 174,14 @@ ol.org-ol {
#preamble {
    font-family: 'Fira Sans';
}

details.code summary {
    background: #32302F;
    border-radius: 5px;
    box-shadow: none;
    border: none;
    margin: unset;
    padding: 5px;
    font:'Iosevka Term Web';
    cursor: pointer;
}

M server.scm => server.scm +40 -37
@@ 1,4 1,4 @@
#!/usr/bin/chicken-scheme
#!/usr/bin/csi -s
;; AUTOCOMPILE: -O3
(import spiffy
        cgi-handler


@@ 29,19 29,19 @@

(error-log (make-pathname (root-path) "debug/error.log"))

(define debug #f)
(define debug #t)

(when debug
  (access-log (make-pathname (root-path) "debug/access.log"))
  (debug-log (make-pathname (root-path) "debug/debug.log")))

(define cgit (cgi-handler* "/usr/lib/cgit/cgit.cgi"))
;; (define cgit (cgi-handler* "/var/www/cgi-bin/cgit"))

(define ssl-listener
  (ssl-listen* port: 443
               certificate:  "/etc/letsencrypt/live/dieggsy.com/fullchain.pem"
               private-key:  "/etc/letsencrypt/live/dieggsy.com/privkey.pem"))
(define http-listener (tcp-listen 80))
; (define ssl-listener
;   (ssl-listen* port: 443
;                certificate:  "/etc/letsencrypt/live/dieggsy.com/fullchain.pem"
;                private-key:  "/etc/letsencrypt/live/dieggsy.com/privkey.pem"))
(define http-listener (tcp-listen 3000))

(switch-user/group (spiffy-user) (spiffy-group))



@@ 103,20 103,22 @@
           (uri (request-uri req))
           (path (uri-path uri))
           (scheme (uri-scheme uri)))
      (if (eqv? scheme 'http)
          (let ((new-u (update-uri uri scheme: 'https)))
            (with-headers `((location ,new-u))
              (lambda () (send-status 'moved-permanently))))
          ;; HTTPS
          (match path
            (('/ (and subdir (or "css")) filename)
             (continue))
            (('/ "static" (and subdir (or "font" "video" "image" "js")) filename . rest)
             (with-headers '((Access-Control-Allow-Origin  "https://paste.dieggsy.com"))
               (lambda () (continue))))
            (else
             (parameterize ((root-path root))
               (fn continue root uri))))))))
(match path
       (('/ (and subdir (or "css")) filename)
        (continue))
       (('/ "static" (and subdir (or "font" "video" "image" "js")) filename . rest)
        (with-headers '((Access-Control-Allow-Origin  "https://paste.dieggsy.com"))
                      (lambda () (continue))))
       (else
         (parameterize ((root-path root))
           (fn continue root uri))))
      ; (if (eqv? scheme 'http)
      ;     (let ((new-u (update-uri uri scheme: 'https)))
      ;       (with-headers `((location ,new-u))
      ;         (lambda () (send-status 'moved-permanently))))
      ;     ;; HTTPS
      ;     )
      )))

(define (blog-fn continue root uri)
  (match (uri-path uri)


@@ 141,11 143,11 @@
                       (update-request (current-request) uri: new-uri)))
         (continue))))))

(define (code-fn continue root uri)
  (match (uri-path uri)
    (('/ . rest)
     (parameterize ((current-pathinfo rest))
       (cgit "")))))
;; (define (code-fn continue root uri)
;;   (match (uri-path uri)
;;     (('/ . rest)
;;      (parameterize ((current-pathinfo rest))
;;        (cgit "")))))

;; Theis is just a placeholder for now.
(define (wiki-fn continue root uri) (continue))


@@ 219,14 221,14 @@
(define handle-paste (make-generic-handler (make-pathname (root-path) "paste") paste-fn))
(define handle-wiki (make-generic-handler (make-pathname (root-path) "wiki") wiki-fn))
(define handle-pkg (make-generic-handler (make-pathname (root-path) "pkg") pkg-fn))
(define handle-code (make-generic-handler "/usr/share/webapps/cgit" code-fn))
;; (define handle-code (make-generic-handler "/usr/share/cgit" code-fn))

;; Map subdomains to handling functions
(vhost-map `(("dieggsy.com" . ,(lambda (c) (handle-blog c)))
             ("paste.dieggsy.com" . ,(lambda (c) (handle-paste c)))
             ("wiki.dieggsy.com" . ,(lambda (c) (handle-wiki c)))
             ("code.dieggsy.com" . ,(lambda (c) (handle-code c)))
             ("pkg.dieggsy.com" . ,(lambda (c) (handle-pkg c)))
             ;; ("code.dieggsy.com" . ,(lambda (c) (handle-code c)))
             ;; ("pkg.dieggsy.com" . ,(lambda (c) (handle-pkg c)))
             ("sadboinews.com" . ,(lambda (continue)
                                    (let* ((req (current-request))
                                           (uri (request-uri (current-request)))


@@ 264,7 266,7 @@
        (for-each
         (lambda (f)
           (let ((f (pathname-file f)))
             (display (serialize-sxml  `(p (@ (style "font-family:monospace;"))
             (display (serialize-sxml  `(p (@ (style "font-family:Iosevka Term Web;"))
                                           (a (@ (href ,f)) ,f))) p)
             (newline p)))
         (sort (directory (make-pathname (root-path) "paste/plain")) string>?))))


@@ 275,11 277,12 @@
;; (include "repl.scm")

;; Start on HTTP
(thread-start!
 (lambda ()
   (parameterize ((server-port 80))
     (accept-loop http-listener tcp-accept))))
; (thread-start!
;  (lambda ()
;    ))
(parameterize ((server-port 80))
     (accept-loop http-listener tcp-accept))

;; Start on SSL
(parameterize ((server-port 443))
  (accept-loop ssl-listener ssl-accept))
; (parameterize ((server-port 443))
;   (accept-loop ssl-listener ssl-accept))

A short.scm => short.scm +115 -0
@@ 0,0 1,115 @@
(import (prefix sql-de-lite sql:))
;; (define 0i (char->integer #\0))
;; (define ai (char->integer #\a))
;; (define Ai (char->integer #\A))
;; (define bri (char->integer #\[))
;; make database readonly by server, have separate program accessed through ssh
;; do the shortening
(import (only srfi-13 string-fold))

(define (integer->62string number)
  (let ((base 62)
        (0i (char->integer #\0))
        (Ai (char->integer #\A))
        (Bri (char->integer #\[)))
   (if (zero? number)
      "0"
      (list->string
       (map integer->char
            (let loop ((u number)
                       (lst '()))
              (let ((d (remainder u base)))
                (cond ((= u 0)
                       lst)
                      ((< d 10)
                       (loop (quotient u base)
                             (cons (+ 0i d) lst)))
                      (else
                       (let* ((chr (+ Ai (- d 10)))
                              (chr* (if (>= chr Bri) (+ 6 chr) chr)))
                         (loop (quotient u base)
                               (cons chr* lst))))))))))))

(define (62string->integer str)
  (let ((0i (char->integer #\0))
        (ai (char->integer #\a))
        (Ai (char->integer #\A))
        (len (string-length str)))
    (let loop ((index 0)
               (pow (sub1 len))
               (sum 0))
      (if (= index len)
          sum
          (loop
           (add1 index)
           (sub1 pow)
           (+ sum
              (*
               (let* ((int (char->integer (string-ref str index))))
                 (cond ((>= int ai)
                        (+ (- int ai) 36))
                       ((>= int Ai)
                        (+ (- int Ai) 10))
                       (else
                        (- int 0i))))
               (expt 62 pow))))))))

;; (let loop ((i 0))
;;   (if (= i 62)
;;       (void)
;;       (begin
;;         (printf "~a ~a\n" i (number->62string i))
;;         (loop (add1 i)))))
(define (short-fn continue root uri)
  (let* ((path (uri-path uri))
         (query (uri-query uri)))
    ;; (print short-list)
    (cond ((and (null? query)
                (equal? path '(/))))
          ((null? query)
           (with-headers `((location
                            ,(car (sql:query sql:fetch db-geturl
                                             (string->number (cadr path) 16)))))
             (lambda () (send-status 'moved-permanently))))
          ((and (assoc 'url query)
                (assoc 'token query)
                (string=? token short-token))
           (let ((long-u (uri-decode-string (alist-ref 'url query)))
                 (short-count (car (sql:exec db-countrows))))
             ;; (print long-u)
             (let* ((hex-count (number->string short-count 16))
                    (new-u (update-uri uri query: '() path: `(/ ,hex-count))))
               ;; (print hex-count)
               (sql:exec db-inserturl short-count long-u)
               (send-response body: (uri->string new-u))))))))

(define short-db-path (make-pathname (root-path) "short.db"))
(define short-db (sql:open-database short-db-path))
(sql:exec (sql:sql short-db "CREATE TABLE IF NOT EXISTS url(short integer, long text)"))
(define db-inserturl (sql:sql short-db "INSERT INTO url(short, long) VALUES(?,?)"))
(define db-geturl (sql:sql short-db "SELECT long FROM url WHERE short=?"))
(define db-countrows (sql:sql short-db "SELECT COUNT(*) FROM url"))
;; (define short-list '())

;; vhost-map
#;("s.dieggsy.com" .
 ,(lambda (c)
    (let* ((uri (request-uri (current-request)))
           (path (uri-path uri))
           (query (uri-query uri)))
      ;; (print short-list)
      (if (null? query)
          ;; This will error with no path
          (with-headers `((location
                           ,(car (sql:query sql:fetch db-geturl
                                            (string->number (cadr path) 16)))))
                        (lambda () (send-status 'moved-permanently)))
          ;; This will error with the wrong query
          (let ((long-u (uri-decode-string (alist-ref 'url query)))
                (short-count (car (sql:exec db-countrows))))
            ;; (print long-u)
            (let* ((hex-count (number->string short-count 16))
                   (new-u (update-uri uri query: '() path: `(/ ,hex-count))))
              ;; (print hex-count)
              (sql:exec db-inserturl short-count long-u)
              (send-response body: (uri->string new-u))))))))

A static/font/ttf/FiraSans-Bold.ttf => static/font/ttf/FiraSans-Bold.ttf +0 -0
A static/font/ttf/FiraSans-BoldItalic.ttf => static/font/ttf/FiraSans-BoldItalic.ttf +0 -0
A static/font/ttf/FiraSans-Italic.ttf => static/font/ttf/FiraSans-Italic.ttf +0 -0
A static/font/ttf/FiraSans-Light.ttf => static/font/ttf/FiraSans-Light.ttf +0 -0
A static/font/ttf/FiraSans-Regular.ttf => static/font/ttf/FiraSans-Regular.ttf +0 -0
A static/font/ttf/iosevka-custom-bold.ttf => static/font/ttf/iosevka-custom-bold.ttf +0 -0
A static/font/ttf/iosevka-custom-bolditalic.ttf => static/font/ttf/iosevka-custom-bolditalic.ttf +0 -0
A static/font/ttf/iosevka-custom-italic.ttf => static/font/ttf/iosevka-custom-italic.ttf +0 -0
A static/font/ttf/iosevka-custom-regular.ttf => static/font/ttf/iosevka-custom-regular.ttf +0 -0
A static/font/woff2/FiraSans-Light.woff2 => static/font/woff2/FiraSans-Light.woff2 +0 -0