15 files changed, 177 insertions(+), 40 deletions(-)

M cgitrc
M css/fonts.css
M css/org.css
M server.scm
A short.scm
A static/font/ttf/FiraSans-Bold.ttf
A static/font/ttf/FiraSans-BoldItalic.ttf
A static/font/ttf/FiraSans-Italic.ttf
A static/font/ttf/FiraSans-Light.ttf
A static/font/ttf/FiraSans-Regular.ttf
A static/font/ttf/iosevka-custom-bold.ttf
A static/font/ttf/iosevka-custom-bolditalic.ttf
A static/font/ttf/iosevka-custom-italic.ttf
A static/font/ttf/iosevka-custom-regular.ttf
A static/font/woff2/FiraSans-Light.woff2

@@ 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

@@ 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;

@@ 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;
 }

@@ 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))

@@ 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))))))))