From f4b8c0df041b063c0b47d2ec6c818a9c202fd833 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Wed, 15 Apr 2020 09:54:10 -0700 Subject: Re-namespacing Moving away from the DNS-driven namespacing toward more condensed names, mostly because I don't like typing so much. --- Alpha/Core.scm | 158 +++++++ Alpha/Logic.scm | 238 ++++++++++ Alpha/Repl.scm | 23 + Alpha/Shell.scm | 34 ++ Alpha/String.scm | 24 + Alpha/Test.scm | 16 + Biz/Bild.scm | 158 +++++++ Biz/Cloud/chat.nix | 100 +++++ Biz/Cloud/git.nix | 17 + Biz/Cloud/hardware.nix | 6 + Biz/Cloud/mail.nix | 43 ++ Biz/Cloud/networking.nix | 36 ++ Biz/Cloud/web.nix | 41 ++ Biz/Cloud/znc.nix | 66 +++ Biz/Dev/configuration.nix | 205 +++++++++ Biz/Dev/hardware.nix | 34 ++ Biz/Ibb/Client.hs | 38 ++ Biz/Ibb/Core.hs | 143 ++++++ Biz/Ibb/Influencers.hs | 407 +++++++++++++++++ Biz/Ibb/Keep.hs | 123 ++++++ Biz/Ibb/Look.hs | 40 ++ Biz/Ibb/Move.hs | 48 ++ Biz/Ibb/Server.hs | 152 +++++++ Biz/Ibb/service.nix | 42 ++ Biz/Language/Bs.hs | 12 + Biz/Language/Bs/Cli.hs | 52 +++ Biz/Language/Bs/Eval.hs | 241 ++++++++++ Biz/Language/Bs/Expr.hs | 154 +++++++ Biz/Language/Bs/Parser.hs | 121 ++++++ Biz/Language/Bs/Primitives.hs | 183 ++++++++ Biz/Language/Bs/Repl.hs | 33 ++ Biz/Language/Bs/Test.hs | 2 + Biz/Serval.scm | 194 +++++++++ Biz/buildOS.nix | 56 +++ Biz/fathom.nix | 109 +++++ Biz/firefox.nix | 12 + Biz/idea/duree-pitch.org | 80 ++++ Biz/idea/flash.org | 36 ++ Biz/keys/ben.pub | 1 + Biz/keys/deploy.pub | 1 + Biz/keys/nick.pub | 1 + Biz/packages.nix | 18 + Biz/users.nix | 39 ++ Biz/vpnHosts.nix | 37 ++ Com/InfluencedByBooks/Client.hs | 38 -- Com/InfluencedByBooks/Core.hs | 143 ------ Com/InfluencedByBooks/Influencers.hs | 407 ----------------- Com/InfluencedByBooks/Keep.hs | 123 ------ Com/InfluencedByBooks/Look.hs | 40 -- Com/InfluencedByBooks/Move.hs | 48 -- Com/InfluencedByBooks/Server.hs | 152 ------- Com/InfluencedByBooks/service.nix | 42 -- Com/MusicMeetsComics/App.hs | 748 -------------------------------- Com/MusicMeetsComics/Assets.hs | 15 - Com/MusicMeetsComics/Client.hs | 188 -------- Com/MusicMeetsComics/Database.hs | 41 -- Com/MusicMeetsComics/Look.hs | 567 ------------------------ Com/MusicMeetsComics/Look/Typography.hs | 79 ---- Com/MusicMeetsComics/Prod.nix | 43 -- Com/MusicMeetsComics/Server.hs | 302 ------------- Com/MusicMeetsComics/Service.nix | 76 ---- Com/Simatime/Bild.scm | 158 ------- Com/Simatime/Cloud/chat.nix | 100 ----- Com/Simatime/Cloud/git.nix | 17 - Com/Simatime/Cloud/hardware.nix | 6 - Com/Simatime/Cloud/mail.nix | 43 -- Com/Simatime/Cloud/networking.nix | 36 -- Com/Simatime/Cloud/web.nix | 41 -- Com/Simatime/Cloud/znc.nix | 66 --- Com/Simatime/Core.scm | 158 ------- Com/Simatime/Dev/configuration.nix | 205 --------- Com/Simatime/Dev/hardware.nix | 34 -- Com/Simatime/Language/Bs.hs | 12 - Com/Simatime/Language/Bs/Cli.hs | 52 --- Com/Simatime/Language/Bs/Eval.hs | 241 ---------- Com/Simatime/Language/Bs/Expr.hs | 154 ------- Com/Simatime/Language/Bs/Parser.hs | 121 ------ Com/Simatime/Language/Bs/Primitives.hs | 183 -------- Com/Simatime/Language/Bs/Repl.hs | 33 -- Com/Simatime/Language/Bs/Test.hs | 2 - Com/Simatime/Logic.scm | 238 ---------- Com/Simatime/Network.hs | 31 -- Com/Simatime/Repl.scm | 23 - Com/Simatime/Sema.hs | 12 - Com/Simatime/Serval.scm | 194 --------- Com/Simatime/Shell.scm | 34 -- Com/Simatime/Shuffle.hs | 122 ------ Com/Simatime/String.scm | 24 - Com/Simatime/Test.scm | 16 - Com/Simatime/buildOS.nix | 56 --- Com/Simatime/fathom.nix | 109 ----- Com/Simatime/firefox.nix | 12 - Com/Simatime/idea/duree-pitch.org | 80 ---- Com/Simatime/idea/flash.org | 36 -- Com/Simatime/keys/ben.pub | 1 - Com/Simatime/keys/deploy.pub | 1 - Com/Simatime/keys/nick.pub | 1 - Com/Simatime/packages.nix | 18 - Com/Simatime/users.nix | 39 -- Com/Simatime/vpnHosts.nix | 37 -- Control/Concurrent/Sema.hs | 12 + Hero/App.hs | 748 ++++++++++++++++++++++++++++++++ Hero/Assets.hs | 15 + Hero/Client.hs | 188 ++++++++ Hero/Database.hs | 41 ++ Hero/Look.hs | 567 ++++++++++++++++++++++++ Hero/Look/Typography.hs | 79 ++++ Hero/Prod.nix | 43 ++ Hero/Server.hs | 302 +++++++++++++ Hero/Service.nix | 76 ++++ Network/RemoteData.hs | 31 ++ Que/Prod.nix | 44 ++ Que/Server.hs | 240 ++++++++++ Que/Server.nix | 46 ++ Que/Website.hs | 126 ++++++ Que/Website.nix | 59 +++ Que/apidocs.md | 3 + Que/client.py | 149 +++++++ Que/index.md | 73 ++++ Que/quescripts.md | 50 +++ Que/style.css | 136 ++++++ Que/tutorial.md | 53 +++ README.md | 8 +- Run/Que/Prod.nix | 44 -- Run/Que/Server.hs | 240 ---------- Run/Que/Server.nix | 46 -- Run/Que/Website.hs | 126 ------ Run/Que/Website.nix | 59 --- Run/Que/apidocs.md | 3 - Run/Que/client.py | 149 ------- Run/Que/index.md | 73 ---- Run/Que/quescripts.md | 50 --- Run/Que/style.css | 136 ------ Run/Que/tutorial.md | 53 --- System/Random/Shuffle.hs | 122 ++++++ default.nix | 74 ++-- push-all | 12 +- 137 files changed, 6824 insertions(+), 6824 deletions(-) create mode 100644 Alpha/Core.scm create mode 100644 Alpha/Logic.scm create mode 100644 Alpha/Repl.scm create mode 100644 Alpha/Shell.scm create mode 100644 Alpha/String.scm create mode 100644 Alpha/Test.scm create mode 100755 Biz/Bild.scm create mode 100644 Biz/Cloud/chat.nix create mode 100644 Biz/Cloud/git.nix create mode 100644 Biz/Cloud/hardware.nix create mode 100644 Biz/Cloud/mail.nix create mode 100644 Biz/Cloud/networking.nix create mode 100644 Biz/Cloud/web.nix create mode 100644 Biz/Cloud/znc.nix create mode 100644 Biz/Dev/configuration.nix create mode 100644 Biz/Dev/hardware.nix create mode 100644 Biz/Ibb/Client.hs create mode 100644 Biz/Ibb/Core.hs create mode 100644 Biz/Ibb/Influencers.hs create mode 100644 Biz/Ibb/Keep.hs create mode 100644 Biz/Ibb/Look.hs create mode 100644 Biz/Ibb/Move.hs create mode 100644 Biz/Ibb/Server.hs create mode 100644 Biz/Ibb/service.nix create mode 100644 Biz/Language/Bs.hs create mode 100644 Biz/Language/Bs/Cli.hs create mode 100644 Biz/Language/Bs/Eval.hs create mode 100644 Biz/Language/Bs/Expr.hs create mode 100644 Biz/Language/Bs/Parser.hs create mode 100644 Biz/Language/Bs/Primitives.hs create mode 100644 Biz/Language/Bs/Repl.hs create mode 100644 Biz/Language/Bs/Test.hs create mode 100644 Biz/Serval.scm create mode 100644 Biz/buildOS.nix create mode 100644 Biz/fathom.nix create mode 100644 Biz/firefox.nix create mode 100644 Biz/idea/duree-pitch.org create mode 100644 Biz/idea/flash.org create mode 100644 Biz/keys/ben.pub create mode 100644 Biz/keys/deploy.pub create mode 100644 Biz/keys/nick.pub create mode 100644 Biz/packages.nix create mode 100644 Biz/users.nix create mode 100644 Biz/vpnHosts.nix delete mode 100644 Com/InfluencedByBooks/Client.hs delete mode 100644 Com/InfluencedByBooks/Core.hs delete mode 100644 Com/InfluencedByBooks/Influencers.hs delete mode 100644 Com/InfluencedByBooks/Keep.hs delete mode 100644 Com/InfluencedByBooks/Look.hs delete mode 100644 Com/InfluencedByBooks/Move.hs delete mode 100644 Com/InfluencedByBooks/Server.hs delete mode 100644 Com/InfluencedByBooks/service.nix delete mode 100644 Com/MusicMeetsComics/App.hs delete mode 100644 Com/MusicMeetsComics/Assets.hs delete mode 100644 Com/MusicMeetsComics/Client.hs delete mode 100644 Com/MusicMeetsComics/Database.hs delete mode 100644 Com/MusicMeetsComics/Look.hs delete mode 100644 Com/MusicMeetsComics/Look/Typography.hs delete mode 100644 Com/MusicMeetsComics/Prod.nix delete mode 100644 Com/MusicMeetsComics/Server.hs delete mode 100644 Com/MusicMeetsComics/Service.nix delete mode 100755 Com/Simatime/Bild.scm delete mode 100644 Com/Simatime/Cloud/chat.nix delete mode 100644 Com/Simatime/Cloud/git.nix delete mode 100644 Com/Simatime/Cloud/hardware.nix delete mode 100644 Com/Simatime/Cloud/mail.nix delete mode 100644 Com/Simatime/Cloud/networking.nix delete mode 100644 Com/Simatime/Cloud/web.nix delete mode 100644 Com/Simatime/Cloud/znc.nix delete mode 100644 Com/Simatime/Core.scm delete mode 100644 Com/Simatime/Dev/configuration.nix delete mode 100644 Com/Simatime/Dev/hardware.nix delete mode 100644 Com/Simatime/Language/Bs.hs delete mode 100644 Com/Simatime/Language/Bs/Cli.hs delete mode 100644 Com/Simatime/Language/Bs/Eval.hs delete mode 100644 Com/Simatime/Language/Bs/Expr.hs delete mode 100644 Com/Simatime/Language/Bs/Parser.hs delete mode 100644 Com/Simatime/Language/Bs/Primitives.hs delete mode 100644 Com/Simatime/Language/Bs/Repl.hs delete mode 100644 Com/Simatime/Language/Bs/Test.hs delete mode 100644 Com/Simatime/Logic.scm delete mode 100644 Com/Simatime/Network.hs delete mode 100644 Com/Simatime/Repl.scm delete mode 100644 Com/Simatime/Sema.hs delete mode 100644 Com/Simatime/Serval.scm delete mode 100644 Com/Simatime/Shell.scm delete mode 100644 Com/Simatime/Shuffle.hs delete mode 100644 Com/Simatime/String.scm delete mode 100644 Com/Simatime/Test.scm delete mode 100644 Com/Simatime/buildOS.nix delete mode 100644 Com/Simatime/fathom.nix delete mode 100644 Com/Simatime/firefox.nix delete mode 100644 Com/Simatime/idea/duree-pitch.org delete mode 100644 Com/Simatime/idea/flash.org delete mode 100644 Com/Simatime/keys/ben.pub delete mode 100644 Com/Simatime/keys/deploy.pub delete mode 100644 Com/Simatime/keys/nick.pub delete mode 100644 Com/Simatime/packages.nix delete mode 100644 Com/Simatime/users.nix delete mode 100644 Com/Simatime/vpnHosts.nix create mode 100644 Control/Concurrent/Sema.hs create mode 100644 Hero/App.hs create mode 100644 Hero/Assets.hs create mode 100644 Hero/Client.hs create mode 100644 Hero/Database.hs create mode 100644 Hero/Look.hs create mode 100644 Hero/Look/Typography.hs create mode 100644 Hero/Prod.nix create mode 100644 Hero/Server.hs create mode 100644 Hero/Service.nix create mode 100644 Network/RemoteData.hs create mode 100644 Que/Prod.nix create mode 100644 Que/Server.hs create mode 100644 Que/Server.nix create mode 100644 Que/Website.hs create mode 100644 Que/Website.nix create mode 100644 Que/apidocs.md create mode 100755 Que/client.py create mode 100644 Que/index.md create mode 100644 Que/quescripts.md create mode 100644 Que/style.css create mode 100644 Que/tutorial.md delete mode 100644 Run/Que/Prod.nix delete mode 100644 Run/Que/Server.hs delete mode 100644 Run/Que/Server.nix delete mode 100644 Run/Que/Website.hs delete mode 100644 Run/Que/Website.nix delete mode 100644 Run/Que/apidocs.md delete mode 100755 Run/Que/client.py delete mode 100644 Run/Que/index.md delete mode 100644 Run/Que/quescripts.md delete mode 100644 Run/Que/style.css delete mode 100644 Run/Que/tutorial.md create mode 100644 System/Random/Shuffle.hs diff --git a/Alpha/Core.scm b/Alpha/Core.scm new file mode 100644 index 0000000..3a5ac6e --- /dev/null +++ b/Alpha/Core.scm @@ -0,0 +1,158 @@ +(define-module (Alpha Core) + #:use-module ((ice-9 format)) + #:export ( + ;; simple printing + fmt printf pr prn + + ;; navigating data + first next second rest + + ;; booleans + true? false? nil nil? + + ;; dev helpers + comment + )) + +(define (flip f) (lambda (x y) (f y x))) +(define (curry f a) (lambda (b) (apply f (cons a (list b))))) +(define pos? + (curry < 0)) + +(define neg? + (curry > 0)) + +(define (foldr f end lst) + (if (null? lst) + end + (f (car lst) (foldr f end (cdr lst))))) + +(define (foldl f acc lst) + (if (null? lst) + acc + (foldl f (f acc (car lst)) (cdr lst)))) + +(define fold foldl) + +(define (unfold f init pred) + (if (pred init) + (cons init '()) + (cons init (unfold f (f init) pred)))) + +(define (sum lst) (fold + 0 lst)) +(define (produce lst) (fold * 1 lst)) + +(define count length) + + +;; +;; clojure-like stuff +;; + +(define (pr . a) + (for-each display a)) + +(define (prn . a) (apply pr a) (newline)) + +(define (first a) + "Return the first item in the collection." + (car a)) + +(define (rest a) + "Returns a list of the items after the first." + (cdr a)) + +(define (next a) + "Returns the next item after the first." + (cadr a)) + +;; same thing, easier to remember/read +(define second next) + +(define (ffirst a) + (first (first a))) + +(define (nnext a) + (next (next a))) + +(define (last coll) + "Return the last time in coll, in linear time." + (if (next coll) + (last coll) + (first coll))) + +(define (butlast ls) + "Return everthing execpt the last element in ls." + (let ((len (length ls))) + (list-head ls (- len 1)))) + +(define (false? x) + (eq? #f x)) + +(define (true? x) + (eq? #t x)) + +(define nil #nil) + +(define (nil? x) + (eq? nil x)) + +;; Ignores body, returns nil. +(define-syntax comment + (syntax-rules () + ((_ ...) nil))) + +(comment + ;; nil is different from null. nil is supposed to be more like + ;; 'Nothing' in Haskell, it is the absence of any value or type; + ;; whereas null is specifically the empty list, which still has a type + ;; of 'list'. + (null? '()) ;; => #t + (nil? '()) ;; => #f + ) + +(define (some pred coll) + (or (pred (first coll)) + (some pred (next coll)))) + +(define comp compose) + +(define (not-any? pred coll) + (comp not some)) + +(define (printf . args) + (display (apply format args))) + +(define-syntax fmt + (syntax-rules () + ((_ s args ...) + (format #f s args ...)))) + +;; If I implement ML-like interface abstractions in scheme, what would it look like? + +;; +;; ;; seq + +;; (define-class () (_first)) + +;; +;; ;; Functor + +;; (define-class ()) + +;; (define-method (fmap (f ) (coll ))) + +;; +;; ;; Applicative + +;; ;; a -> f a +;; (define-method (pure (a ))) + +;; ;; f (a -> b) -> f a -> f b +;; (define-method (<*> (f ) (a ) (b ))) + +;; ;; f a -> f b -> f b +;; (define-method (*> (a ) (b ))) + +;; ;; f a -> f b -> f a +;; (define-method (<* (a ) (b ))) diff --git a/Alpha/Logic.scm b/Alpha/Logic.scm new file mode 100644 index 0000000..e438a03 --- /dev/null +++ b/Alpha/Logic.scm @@ -0,0 +1,238 @@ +;; my mini kanren impl - basically untested so far + +(define-module (Alpha Logic)) + +(define-syntax λg + (syntax-rules () + ((_ (s) e) (lambda (s) e)))) + +(define-syntax λf + (syntax-rules () + ((_ () e) (lambda () e)))) + +(define (unify u v s) + (let ([u (walk u s)] + [v (walk v s)]) + (cond + [(eq? u u) s] + + [(var? u) + (cond + [(var? v) (ext-s-check u v s)] + [else (ext-s-check u v s)])] + + [(and (pair? u) (pair? v)) + (let ([s (unify (car u) (car v) s)]) + (and s (unify (cdr u) (cdr v) s)))] + + [(equal? u v) s] + + [else #f]))) + +(define-syntax if-not + (syntax-rules () + ((_ pred then else) + (if (not pred) then else)))) + +(define (walk v s) + (if-not (var? v) + v + (let ([a (assq v s)]) + (if a + (walk (cdr a) s) + v)))) + +(define (ext-s-check x v s) + (if-not (occurs-check x v s) + (ext-s x v s) + #f)) + +(define (occurs-check x v s) + (let ([v (walk v s)]) + (cond + [(var? v) (eq? v x)] + [(pair? v) + (or (occurs-check x (car v) s) + (occurs-check x (cdr v) s))] + [else #f]))) + +(define (ext-s x v s) + (cons `(,x . ,v) s)) + +(define empty-s '()) + +(define var vector) +(define var? vector?) + +(define reify + (letrec ([reify-s (lambda [v s] + (let ([v (walk v s)]) + (cond + [(var? v) (ext-s v (reify-name (length s)) s)] + [(pair? v) (reify-s (cdr v) (reify-s (car v) s))] + [else s])))]) + (lambda [v s] + (let ([v (walk* v s)]) + (walk* v (reify-s v empty-s)))))) + +(define walk* + (lambda [w s] + (let ([v (walk w s)]) + (cond + [(var? v) v] + [(pair? v) (cons (walk* (car v) s) + (walk* (cdr v) s))] + [else v])))) + +(define reify-name + (lambda [n] + (string->symbol + (string-append "_" "." (number->string n))))) + +(define-syntax mzero + (syntax-rules () + ((_) #f))) + +(define-syntax unit + (syntax-rules () + ((_ a) a))) + +(define-syntax choice + (syntax-rules () + ((_ a f) (cons a f)))) + +(define-syntax inc + (syntax-rules () + ((_ e) (λf () e)))) + +(define-syntax case-inf + (syntax-rules () + ((_ e on-zero + [(a^) on-one] + [(a f) on-choice] + [(f^) on-inc]) + (let ([a-inf e]) + (cond + ;; a-inf = #f + [(not a-inf) on-zero] + ;; a-inf = lambda + [(procedure? a-inf) (let ((f^ a-inf)) on-inc)] + ;; a-inf = (x . lambda) + [(and (pair? a-inf) (procedure? (cdr a-inf))) + (let ([a (car a-inf)] + [f (cdr a-inf)]) + on-choice)] + [else (let ((a^ a-inf)) on-one)]))))) + +(define-syntax == + (syntax-rules () + ((_ u v) + (λg (s) (unify u v s))))) + +(define-syntax conde + (syntax-rules () + ((_ (g0 g ...) (g1 g^ ...) ...) + (λg (s) + (inc (mplus* + (bind* (g0 s) g ...) + (bind* (g1 s) g^ ...) ...)))))) + +(define-syntax mplus* + (syntax-rules () + ((_ e) e) + ((_ e0 e ...) (mplus e0 (λf () (mplus* e ...)))))) + +(define mplus + (lambda (a-inf f) + (case-inf a-inf (f) + ((a) (choice a f)) + ((a f^) (choice a (λf () (mplus (f) f^)))) + ((f^) (inc (mplus (f) f^)))))) + +(define-syntax fresh + (syntax-rules () + ((_ (x ...) g0 g ...) + (λg (s) + (let ((x (var 'x)) ...) + (bind* (g0 s) g ...)))))) + +(define-syntax bind* + (syntax-rules () + ((_ e) e) + ((_ e g0 g ...) + (let ((a-inf e)) + (and a-inf (bind* (bind a-inf g0) g ...)))))) + +(define bind + (lambda (a-inf g) + (case-inf a-inf (mzero) + ((a) (g a)) + ((a f) (mplus (g a) (λf () (bind (f) g)))) + ((f) (inc (bind (f) g)))))) + +(define-syntax run + (syntax-rules () + ((_ n (x) g0 g^ ...) + (take n + (λf + () + (let ((g (fresh + (x) + (λg + (s) + (bind* (g0 s) g^ ... + (λg (s) + (list (reify x s)))))))) + (g empty-s))))))) + +(define-syntax run* + (syntax-rules () + ((_ (x) g ...) (run #f (x) g ...)))) + +(define take + (lambda (n f) + (if (and n (zero? n)) + '() + (case-inf (f) '() + [(a) a] + [(a f) (cons (car a) (take (and n (- n 1)) f))] + [(f) (take n f)])))) + +(define-syntax conda + (syntax-rules () + ((_ (g0 g ...) (g1 g^ ...) ...) + (λg (s) + (if* (picka (g0 s) g ...) (picka (g1 s) g^ ...) ...))))) + +(define-syntax condu + (syntax-rules () + ((_ (g0 g ...) (g1 g^ ...) ...) + (λg (s) + (if* (picku (g0 s) g ...) + (picku (g1 s) g^ ...) + ...))))) + +(define-syntax if* + (syntax-rules () + ((_) (mzero)) + ((_ (pick e g ...) b ...) + (let loop ((a-inf e)) + (case-inf a-inf (if* b ...) + [(a) (bind* a-inf g ...)] + [(a f) (bind* (pick a a-inf) g ...)] + [(f) (inc (loop (f)))]))))) + +(define-syntax picka + (syntax-rules () + ((_ a a-inf) a-inf))) + +(define-syntax picku + (syntax-rules () + ((_ a a-inf) (unit a)))) + +(define-syntax project + (syntax-rules () + ((_ (x ...) g0 g ...) + (λg (s) + (let ((x (walk* x s)) ...) + (bind* (g0 s) g ...)))))) diff --git a/Alpha/Repl.scm b/Alpha/Repl.scm new file mode 100644 index 0000000..f2d9160 --- /dev/null +++ b/Alpha/Repl.scm @@ -0,0 +1,23 @@ +(define-module (Alpha Repl) + #:export ()) + + +;; +;; repl customization +;; + +;; (use-modules (system repl common)) +;; (repl-default-option-set! +;; 'prompt +;; (lambda (repl) +;; (format #f "\n[~a@~a:~a]\nλ> " +;; (getenv "USER") +;; (vector-ref (uname) 1) +;; (pwd)))) + +;; TODO(bsima): (doc x) +;; TODO(bsima): (src x) +;; TODO(bsima): ,src command +;; TODO(bsima): ,shell command +;; TODO(bsima): how to load this file on startup? +;; for ,src and ,shell https://github.com/NalaGinrut/nala-repl diff --git a/Alpha/Shell.scm b/Alpha/Shell.scm new file mode 100644 index 0000000..3f52fd2 --- /dev/null +++ b/Alpha/Shell.scm @@ -0,0 +1,34 @@ +(define-module (Alpha Shell) + #:use-module ((ice-9 popen) #:prefix popen/) + #:use-module ((ice-9 rdelim) #:prefix rdelim/) + #:use-module ((ice-9 ftw) #:prefix ftw/) + #:export (exec + stream + pwd + ls + cd)) + +(define (exec cmd) + (let* ((port (popen/open-input-pipe cmd)) + (ret (read port))) + (popen/close-pipe port) + ret)) + +(define (stream cmd) + (let* ((port (popen/open-input-pipe cmd)) + (_ (setvbuf port 'none)) + (ret (rdelim/read-string port))) + (flush-all-ports) + (popen/close-pipe port) + ret)) + +(define (pwd) + (regexp-substitute/global + #f "/home/ben" (getcwd) 'pre "~" 'post)) + +(define (ls) + (ftw/scandir (getcwd))) + +(define (cd path) + (chdir path) + (ls)) diff --git a/Alpha/String.scm b/Alpha/String.scm new file mode 100644 index 0000000..779c2fb --- /dev/null +++ b/Alpha/String.scm @@ -0,0 +1,24 @@ +(define-module (Alpha String) + #:export (replace to-string str capitalize)) + +(define (replace s match repl) + (let ((f (lambda (a b) + (let ((next-char (if (eq? a match) repl a))) + (string-concatenate (list b (string next-char))))))) + (string-fold f "" s))) + +(define (to-string x) + (format #f "~a" x)) + +(define str + (case-lambda + (() "") + ((x) (to-string x)) + ((x . rest) (string-concatenate (map str (cons x rest)))))) + +(define (capitalize s) + (let ((s (to-string s))) + (if (< (string-length s) 2) + (string-upcase s) + (str (string-upcase (substring s 0 1)) + (substring s 1 ))))) diff --git a/Alpha/Test.scm b/Alpha/Test.scm new file mode 100644 index 0000000..8c0916d --- /dev/null +++ b/Alpha/Test.scm @@ -0,0 +1,16 @@ +;; a testing framework for scheme +;; inspired by clojure.test and srfi-64 + +(define-module (Alpha Test) + #:use-module ((Alpha Core) + #:select (prn)) + #:export (testing)) + +;; TODO: learn srfi-64 +;; TODO: port over `deftest' et al from clojure +;; TODO: someday a quickcheck-like would be best + +;; simple analog to clojure's `testing' +(define-syntax testing + ((_ description ...) + ((begin (prn description) ...)))) diff --git a/Biz/Bild.scm b/Biz/Bild.scm new file mode 100755 index 0000000..4e1d490 --- /dev/null +++ b/Biz/Bild.scm @@ -0,0 +1,158 @@ +;; +;; bild - a simple build tool +;; +;;; Notice: +;; +;; This is under active development. For now this is just a convenience wrapper +;; around `nix build`. The below commentary describes how this tool *should* +;; work. +;; +;;; Commentary: +;; +;; Design constraints +;; +;; - only input is a namespace, no subcommands, no packages +;; - no need to write specific build rules +;; - one rule for hs, one for rs, one for scm, and so on +;; - no need to distinguish between exe and lib, just have a single output +;; - never concerned with deployment/packaging - leave that to another tool (scp? tar?)) +;; +;; Features +;; +;; - namespace maps to filesystem +;; - no need for `bild -l` for listing available targets. Use `ls` or `tree` +;; - you build namespaces, not files/modules/packages/etc +;; - namespace maps to language modules +;; - build settings can be set in the file comments +;; - pwd is always considered the the source directory, no `src` vs `doc` etc. +;; - build methods automaticatly detected with file extensions +;; - flags modify the way to interact with the build +;; - -s = jump into a shell and/or repl +;; - -p = turn on profiling +;; - -t = limit build by type +;; - -e = exclude some regex in the ns tree +;; - -o = optimize level +;; +;; Example Commands +;; +;; bild [-rpt] +;; +;; The general scheme is to build the things described by the targets. A target +;; is a namespace. You can list as many as you want, but you must list at least +;; one. It could just be `.` for the current directory. Build outputs will go +;; into the _bild directory in the root of the project. +;; +;; bild biz.web +;; +;; Or `bild biz/web`. This shows building a file at ./biz/web.hs, this will +;; translate to something like `ghc --make Biz.Web`. +;; +;; bild -r +;; +;; Starts a repl/shell for target. +;; - if target.hs, load ghci +;; - if target.scm, load scheme repl +;; - if target.clj, load a clojure repl +;; - if target.nix, load nix-shell +;; - and so on. +;; +;; bild -p +;; +;; build target with profiling (if available) +;; +;; bild -t nix target +;; +;; only build target.nix, not target.hs and so on (in the case of multiple +;; targets with the same name but different extension). +;; +;; Here is an example integration with GHC. Given the following command-line +;; invocation to compile the namespace 'com.simatime.bild' which depends on +;; 'com.simatime.lib': +;; +;; ghc com/simatime/bild.hs -i com/simatime/lib.hs -o _bild/bild -v \ +;; -main-is Biz.Bild.main +;; +;; The general template of which is: +;; +;; ghc -i -o -main-is .main +;; +;; Some definitions: +;; +;; - is some source file +;; - is the stack of dependencies +;; - is the target namespace, indicated by 'bild ' +;; +;; To fill out the build template, we can parse the file for known +;; namespaces. The general recipe is: +;; +;; 1. Create a list of namespaces in my git repo. This can be cached, or I can +;; integrate with git somehow. +;; 2. Read the file corresponding to +;; 3. Look for 'import ', where is a namespace in the +;; aforementioned cache. +;; 4. If found, then save current build as a continuation and compile +;; . Result gets put on the dependency stack +;; 5. When finished, return to building +;; +;; Once the build command template is filled out, we can create the nix expression. +;; +;; Questions +;; +;; - how to import (third-party) dependencies? +;; 1 just don't have them...? yeah right +;; 2 the target.nix could be the build description for target.hs +;; 3 just use a default.nix for the com.whatever +;; 4 have a deps.nix file +;; 5 list them in the file with other settings. Starting with Haskell, +;; have comments like `{-: PACKAGE base <5.0.0.0 :-}' or `-- : PACKAGE base <5.0.0.0'. +;; Other languages could use `#:` for the special prefix, basically just +;; a comment plus colon. +;; - how to handle multiple output formats? +;; - e.g. that ghcjs and ghc take the same input files... +;; - say you have a .md file, you want to bild it to pdf, html, and more. What do? +;; - i guess the nix file could return a set of drvs instead of a single drv +;; +;; TODO +;; - stream output from 'nix build' subprocess +;; - get rid of guile notes during execution +;; - ns<->path macro +;; - support list (scheme namespace) in ns<->path fns +;; +;;; Code: + +(define-module (Biz Bild) + #:use-module ((ice-9 popen) #:prefix popen/) + #:use-module ((ice-9 format) #:select (format)) + #:use-module ((ice-9 rdelim) #:prefix rdelim/) + #:use-module ((Alpha Core) #:select (fmt)) + #:use-module ((Alpha Shell) #:prefix sh/) + #:use-module ((Alpha String) #:prefix string/) + #:export (ns? + ns->path + path->ns + main)) + +(define (main args) + (let* ((root (sh/exec "git rev-parse --show-toplevel")) + (target (cadr args)) + (path (ns->path target))) + (display (fmt ":: bild ~a...\r" target)) + (sh/exec (fmt "nix build -f ~a/default.nix ~a" + root target)) + (display (fmt ":: bilt ~a" target)))) + +(define ns? symbol?) + +(define (ns->path ns) + (let ((to-path (lambda (s) (string/replace s #\. #\/)))) + (cond + ((symbol? ns) (to-path (symbol->string ns))) + ((string? ns) (to-path ns)) + (else (error "ns should be a string or symbol"))))) + +(define (path->ns path) + (let ((to-ns (lambda (s) (string/replace s #\/ #\.)))) + (cond + ((symbol? path) (to-ns (symbol->string path))) + ((string? path) (to-ns path)) + (else (error "path should be a string or symbol"))))) diff --git a/Biz/Cloud/chat.nix b/Biz/Cloud/chat.nix new file mode 100644 index 0000000..e23b73e --- /dev/null +++ b/Biz/Cloud/chat.nix @@ -0,0 +1,100 @@ +{ config, pkgs, ... }: +# +# a homeserver for matrix.org. +# +# - nixos manual: https://nixos.org/nixos/manual/index.html#module-services-matrix +# +# to create new users: +# +# nix run nixpkgs.matrix-synapse +# register_new_matrix_user -k http://localhost: +# +let + fqdn = "matrix.${config.networking.domain}"; + riot = "chat.${config.networking.domain}"; + matrix_port = 8448; +in { + # matrix-synapse server. for what the settings mean, see: + # https://nixos.org/nixos/manual/index.html#module-services-matrix + # + services.matrix-synapse = { + enable = true; + server_name = config.networking.domain; + registration_shared_secret = "AkGRWSQLga3RoKRFnHhKoeCEIeZzu31y4TRzMRkMyRbBnETkVTSxilf24qySLzQn"; + listeners = [ + { + port = matrix_port; + bind_address = "::1"; + type = "http"; + tls = false; + x_forwarded = true; + resources = [ + { + names = [ "client" "federation" ]; + compress = false; + } + ]; + } + ]; + }; + # matrix needs a database + # + services.postgresql.enable = true; + # web proxy for the matrix server + # + services.nginx = { + enable = true; + recommendedTlsSettings = true; + recommendedOptimisation = true; + recommendedGzipSettings = true; + recommendedProxySettings = true; + virtualHosts = { + # route to matrix-synapse + "${config.networking.domain}" = { + locations."= /.well-known/matrix/server".extraConfig = + let + server = { "m.server" = "${fqdn}:443"; }; + in '' + add_header Content-Type application/json; + return 200 '${builtins.toJSON server}'; + ''; + locations."= /.well-known/matrix/client".extraConfig = + let + client = { + "m.homeserver" = { "base_url" = "https://${fqdn}"; } ; + "m.identity_server" = { "base_url" = "https://vector.im"; }; + }; + in '' + add_header Content-Type application/json; + add_header Access-Control-Allow-Origin *; + return 200 '${builtins.toJSON client}'; + ''; + }; + # reverse proxy for matrix client-server and server-server communication + "${fqdn}" = { + enableACME = true; + forceSSL = true; + locations."/".extraConfig = '' + return 404; + ''; + locations."/_matrix" = { + proxyPass = "http://[::1]:${toString matrix_port}"; + }; + }; + }; + }; + # riot client, available at chat.simatime.com + # + # note that riot and matrix-synapse must be on separate fqdn's to + # protect from XSS attacks: + # https://github.com/vector-im/riot-web#important-security-note + # + services.nginx.virtualHosts."${riot}" = { + enableACME = true; + forceSSL = true; + serverAliases = [ + "chat.${config.networking.domain}" + ]; + root = pkgs.riot-web; + }; +} diff --git a/Biz/Cloud/git.nix b/Biz/Cloud/git.nix new file mode 100644 index 0000000..370f52a --- /dev/null +++ b/Biz/Cloud/git.nix @@ -0,0 +1,17 @@ +{ pkgs, ... }: + +{ + services = { + gitolite = { + enable = true; + enableGitAnnex = true; + dataDir = "/srv/git"; + user = "git"; + group = "git"; + extraGitoliteRc = '' + $RC{SITE_INFO} = 'a computer is a bicycle for the mind.'; + ''; + adminPubkey = builtins.readFile ../keys/ben.pub; + }; + }; +} diff --git a/Biz/Cloud/hardware.nix b/Biz/Cloud/hardware.nix new file mode 100644 index 0000000..8c88cb7 --- /dev/null +++ b/Biz/Cloud/hardware.nix @@ -0,0 +1,6 @@ +{ ... }: +{ + imports = [ ]; + boot.loader.grub.device = "/dev/vda"; + fileSystems."/" = { device = "/dev/vda1"; fsType = "ext4"; }; +} diff --git a/Biz/Cloud/mail.nix b/Biz/Cloud/mail.nix new file mode 100644 index 0000000..81bddc2 --- /dev/null +++ b/Biz/Cloud/mail.nix @@ -0,0 +1,43 @@ +{ ... }: + +{ + mailserver = { + enable = true; + monitoring = { + enable = false; + alertAddress = "bsima@me.com"; + }; + fqdn = "simatime.com"; + domains = [ "simatime.com" "bsima.me" ]; + certificateScheme = 3; # let's encrypt + enableImap = true; + enablePop3 = true; + enableImapSsl = true; + enablePop3Ssl = true; + enableManageSieve = true; + virusScanning = false; # ur on ur own + localDnsResolver = true; + + loginAccounts = { + "ben@simatime.com" = { + hashedPassword = "$6$Xr180W0PqprtaFB0$9S/Ug1Yz11CaWO7UdVJxQLZWfRUE3/rarB0driXkXALugEeQDLIjG2STGQBLU23//JtK3Mz8Kwsvg1/Zo0vD2/"; + aliases = [ + # my default email + "ben@bsima.me" + # admin stuff + "postmaster@simatime.com" + "abuse@simatime.com" + ]; + catchAll = [ "simatime.com" "bsima.me" ]; + quota = "5G"; + }; + "nick@simatime.com" = { + hashedPassword = "$6$31P/Mg8k8Pezy1e$Fn1tDyssf.1EgxmLYFsQpSq6RP4wbEvP/UlBlXQhyKA9FnmFtJteXsbJM1naa8Kyylo8vZM9zmeoSthHS1slA1"; + aliases = [ + "nicolai@simatime.com" + ]; + quota = "1G"; + }; + }; + }; +} diff --git a/Biz/Cloud/networking.nix b/Biz/Cloud/networking.nix new file mode 100644 index 0000000..d943c13 --- /dev/null +++ b/Biz/Cloud/networking.nix @@ -0,0 +1,36 @@ +{ lib, config, ... }: + +{ + networking = { + + firewall = { + allowedTCPPorts = [ 22 80 443 ]; + }; + + # This following was populated at runtime with the networking details + # gathered from the active system. + nameservers = [ + "67.207.67.2" + "67.207.67.3" + ]; + defaultGateway = "159.89.128.1"; + defaultGateway6 = "2604:a880:2:d0::1"; + dhcpcd.enable = false; + usePredictableInterfaceNames = lib.mkForce true; + interfaces = { + eth0 = { + ipv4.addresses = [ + { address="159.89.128.69"; prefixLength=20; } + { address="10.46.0.6"; prefixLength=16; } + ]; + ipv6.addresses = [ + { address="2604:a880:2:d0::35:c001"; prefixLength = 64; } + { address="fe80::e899:c0ff:fe9c:e194"; prefixLength = 64; } + ]; + }; + }; + }; + services.udev.extraRules = '' + ATTR{address}=="ea:99:c0:9c:e1:94", NAME="eth0" + ''; +} diff --git a/Biz/Cloud/web.nix b/Biz/Cloud/web.nix new file mode 100644 index 0000000..22d7199 --- /dev/null +++ b/Biz/Cloud/web.nix @@ -0,0 +1,41 @@ +{ ... }: + +let + bensIp = "73.222.221.62"; +in +{ + services = { + nginx = { + enable = true; + recommendedGzipSettings = true; + recommendedOptimisation = true; + recommendedProxySettings = true; + recommendedTlsSettings = true; + virtualHosts = { + "bsima.me".root = "/home/ben/public_html/"; + "www.bsima.me".root = "/home/ben/public_html/"; + "simatime.com".locations."/".root = "/srv/www/"; + "firefoxsync.simatime.com".locations."/".proxyPass = "http://localhost:5001"; + "hero.simatime.com".locations."/".proxyPass = "http://${bensIp}:3001"; + "tv.simatime.com".locations."/".proxyPass = "http://${bensIp}:8096"; # emby runs on port 8096 + "deluge.simatime.com".locations."/".proxyPass = "http://${bensIp}:8112"; + + "notebook.simatime.com".locations = { + "/" = { + proxyPass = "http://${bensIp}:3099"; + proxyWebsockets = true; + extraConfig = '' + proxy_buffering off; + proxy_read_timeout 86400; + + ''; + }; + "/(api/kernels/[^/]+/channels|terminals/websocket)/" = { + proxyPass = "http://${bensIp}:3099"; + proxyWebsockets = true; + }; + }; + }; + }; + }; +} diff --git a/Biz/Cloud/znc.nix b/Biz/Cloud/znc.nix new file mode 100644 index 0000000..9b1a28d --- /dev/null +++ b/Biz/Cloud/znc.nix @@ -0,0 +1,66 @@ +/* + +N.B.: generate znc passwords with 'nix-shell -p znc --command "znc --makepass"' + +- https://wiki.znc.in/Configuration + +*/ + +{ ... }: + +{ + services = { + znc = { + enable = true; + mutable = false; + useLegacyConfig = false; + openFirewall = true; + config = { + LoadModule = [ "adminlog" ]; + User.bsima = { + Admin = true; + Nick = "bsima"; + AltNick = "bsima1"; + LoadModule = [ "chansaver" "controlpanel" "log" ]; + Network.freenode = { + Server = "chat.freenode.net +6697"; + LoadModule = [ "simple_away" "nickserv" "sasl" ]; + Chan = { + "#ai" = {}; + "#biz" = { Modes = "+Sp"; }; + "#bsima" = { Modes = "+Sp"; }; + "##categorytheory" = { Detached = true; }; + "#clojure" = { Detached = true; }; + "#coq" = { Detached = true; }; + "#emacs" = { Detached = true; }; + "#guile" = { Detached = true; }; + "#guix" = { Detached = true; }; + "#haskell" = {}; + "#haskell-miso" = { Detached = true; }; + "#hledger" = {}; + "#hnix" = { Detached = true; }; + "#home-manager" = { Detached = true; }; + "#ledger" = {}; + "#nix-darwin" = { Detached = true; }; + "#nixos" = {}; + "#org-mode" = {}; + "#scheme" = { Detached = true; }; + "#servant" = { Detached = true; }; + "#sr.ht" = { Detached = true; }; + "#xmonad" = { Detached = true; }; + }; + }; + Network.efnet = { + Server = "irc.efnet.info +6697"; + LoadModule = [ "simple_away" ]; + }; + Pass.password = { + Method = "sha256"; + Hash = "bead16d806e7bf5cbbc31d572b20f01e2b253eb60e2497ce465df56306becd02"; + Salt = "/GhmBMc+E6b7qd8muFEe"; + }; + }; + }; + }; + }; +} diff --git a/Biz/Dev/configuration.nix b/Biz/Dev/configuration.nix new file mode 100644 index 0000000..4a8839e --- /dev/null +++ b/Biz/Dev/configuration.nix @@ -0,0 +1,205 @@ +{ config, lib, pkgs, ... }: + +let + murmurPort = 64738; + torrents = { from = 6000; to = 6999; }; +in { + networking = { + hosts = { + "::1" = [ "localhost" "ipv6-localhost" "ipv6-loopback" ]; + }; + + firewall = { + allowedTCPPorts = [ + 22 8000 8443 443 8080 8081 # standard ports + 500 10000 # no idea + 8096 # emby/jellyfin + 8112 # deluge + murmurPort + ]; + allowedTCPPortRanges = [ + { from = 3000; to = 3100; } # dev stuff + torrents + ]; + allowedUDPPorts = [ murmurPort ]; + allowedUDPPortRanges = [ + torrents + ]; + checkReversePath = false; + }; + + }; + + # Use the systemd-boot EFI boot loader. + boot.loader.systemd-boot.enable = true; + boot.loader.efi.canTouchEfiVariables = true; + boot.enableContainers = true; + + boot.initrd.luks.devices = { + root = { + device = "/dev/disk/by-uuid/a0160f25-e0e3-4af0-8236-3e298eac957a"; + preLVM = true; + }; + }; + + powerManagement.enable = false; + + time.timeZone = "America/Los_Angeles"; + + fonts.fonts = with pkgs; [ + google-fonts mononoki source-code-pro fantasque-sans-mono hack-font + fira fira-code fira-code-symbols + ]; + + environment.systemPackages = [ pkgs.wemux pkgs.tmux ]; + + nixpkgs = { + config = { + allowUnfree = true; + allowBroken = true; + }; + }; + + hardware = { + opengl.enable = true; + pulseaudio = { + enable = true; + extraConfig = '' + load-module module-loopback + ''; + }; + }; + + programs = { + bash.enableCompletion = true; + command-not-found.enable = true; + gnupg.agent = { + enable = true; + enableSSHSupport = true; + }; + mosh.enable = true; + }; + + virtualisation = { + docker = { + enable = true; + liveRestore = false; + }; + libvirtd.enable = true; + virtualbox = { + host = { + enable = false; + headless = false; + addNetworkInterface = false; + }; + guest = { + enable = false; + x11 = false; + }; + }; + }; + + services = { + pcscd.enable = true; + logind = { + lidSwitch = "ignore"; + extraConfig = "IdleAction=ignore"; + }; + + deluge = { + enable = true; + openFilesLimit = 10240; + web.enable = true; + }; + + printing.enable = true; + + murmur = { + enable = true; + registerName = "simatime"; + password = "simatime"; + port = murmurPort; + }; + + xserver = { + enable = true; + layout = "us"; + xkbOptions = "caps:ctrl_modifier"; + displayManager.sddm.enable = true; + desktopManager = { + kodi.enable = true; + plasma5.enable = true; + xterm.enable = true; + }; + }; + + jupyter = { + enable = false; + port = 3099; + ip = "*"; + password = "'sha1:4b14a407cabe:fbab8e5400f3f4f3ffbdb00e996190d6a84bf51e'"; + kernels = { + python3 = let + env = (pkgs.python3.withPackages (p: with p; [ + ipykernel pandas scikitlearn numpy matplotlib sympy ipywidgets + ])); + in { + displayName = "py3"; + argv = [ + "${env.interpreter}" + "-m" + "ipykernel_launcher" + "-f" + "{connection_file}" + ]; + language = "python"; + #logo32 = "${env.sitePackages}/lib/python3.6/site-packages/ipykernel/resources/logo-32x32.png"; + #logo64 = "${env.sitePackages}/lib/python3.6/site-packages/ipykernel/resources/logo-64x64.png"; + }; + }; + }; + + jellyfin = { # previously emby + enable = true; + user = "jellyfin"; + group = "jellyfin"; + }; + + vnstat.enable = true; + + postgresql = { + enable = true; + package = pkgs.postgresql_10; + authentication = '' + local all pprjam md5 + local all pprjam_test md5 + ''; + enableTCPIP = true; + }; + redis = { + enable = true; + }; + }; + + documentation = { + enable = true; + dev.enable = true; + doc.enable = true; + info.enable = true; + man.enable = true; + nixos.enable = true; + }; + + # Since this is the dev machine, we can turn these on at the expense of extra + # disk space. + nix.extraOptions = '' + keep-outputs = true + keep-derivations = true + ''; + + # This value determines the NixOS release with which your system is to be + # compatible, in order to avoid breaking some software such as database + # servers. You should change this only after NixOS release notes say you + # should. + system.stateVersion = "17.09"; # Did you read the comment? +} diff --git a/Biz/Dev/hardware.nix b/Biz/Dev/hardware.nix new file mode 100644 index 0000000..fc0e7a0 --- /dev/null +++ b/Biz/Dev/hardware.nix @@ -0,0 +1,34 @@ +# Do not modify this file! It was generated by ‘nixos-generate-config’ +# and may be overwritten by future invocations. Please make changes +# to /etc/nixos/configuration.nix instead. +{ config, lib, pkgs, ... }: + +{ + imports = + [ + ]; + + boot.initrd.availableKernelModules = [ "xhci_pci" "ahci" "usbhid" "sd_mod" ]; + boot.kernelModules = [ "kvm-intel" ]; + boot.extraModulePackages = [ ]; + + fileSystems."/" = + { device = "/dev/disk/by-uuid/0d8b0e52-10de-4af2-bcd9-b36278352e77"; + fsType = "ext4"; + }; + + fileSystems."/boot" = + { device = "/dev/disk/by-uuid/9B89-85C7"; + fsType = "vfat"; + }; + + fileSystems."/mnt/lake" = + { device = "/dev/disk/by-uuid/037df3ae-4609-402c-ab1d-4593190d0ee7"; + fsType = "ext4"; + }; + + swapDevices = [ ]; + + nix.maxJobs = lib.mkDefault 4; + powerManagement.cpuFreqGovernor = "powersave"; +} diff --git a/Biz/Ibb/Client.hs b/Biz/Ibb/Client.hs new file mode 100644 index 0000000..e40ff36 --- /dev/null +++ b/Biz/Ibb/Client.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Front-end +-- +-- : exe ibb.js +-- +-- : dep clay +-- : dep miso +-- : dep protolude +-- : dep servant +-- : dep text +-- : dep aeson +-- : dep containers +-- : dep ghcjs-base +module Biz.Ibb.Client where + +import Alpha +import Biz.Ibb.Core ( Action(..) + , see + , init + ) +import Biz.Ibb.Move ( move ) +import Miso ( App(..) + , defaultEvents + , miso + ) + +main :: IO () +main = miso $ \u -> App { model = init u, .. } + where + initialAction = FetchPeople + update = move + view = see + events = defaultEvents + subs = [] + mountPoint = Nothing diff --git a/Biz/Ibb/Core.hs b/Biz/Ibb/Core.hs new file mode 100644 index 0000000..fb82ff0 --- /dev/null +++ b/Biz/Ibb/Core.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Main app logic +module Biz.Ibb.Core where + +import Alpha +import Network.RemoteData +import Data.Aeson hiding ( Success ) +import Data.Data ( Data + , Typeable + ) +import Data.Text ( Text ) +import GHC.Generics ( Generic ) +import Miso +import Miso.String +import Servant.API +import Servant.Links + +-- * entity data types + +data Person = Person + { _name :: Text + -- ^ Their full name. + , _pic :: Text + -- ^ A link to their picture. + , _twitter :: Text + -- ^ Their twitter handle, without the `@` prefix. + , _website :: Text + -- ^ Their main website, fully formed: `https://example.com` + , _books :: [Book] + -- ^ A short list of the books they recommend. + , _blurb :: Text + -- ^ A short "about" section, like you would see on the jacket flap of a book. + } deriving (Generic, Show, Eq, Typeable, Data, Ord) + +instance FromJSON Person +instance ToJSON Person + +data Book = Book + { _title :: Text + , _author :: Text + , _amznref :: Text + -- ^ Amazon REF number, for creating affiliate links. + } deriving (Generic, Show, Eq, Typeable, Data, Ord) + +instance FromJSON Book +instance ToJSON Book + +-- * app data types + +type AppRoutes = Home + +type Home = View Action + +data Model = Model + { uri :: URI + , people :: WebData [Person] + } deriving (Show, Eq) + +type WebData a = RemoteData MisoString a + +init :: URI -> Model +init u = Model u Loading + +data Action + = Nop + | ChangeRoute URI + | HandleRoute URI + | FetchPeople + | SetPeople (WebData [Person]) + deriving (Show, Eq) + +home :: Model -> View Action +home m = see m + +handlers :: Model -> View Action +handlers = home + +notfound :: View Action +notfound = div_ [] [text "404"] + +goHome :: URI +goHome = linkURI $ safeLink (Proxy :: Proxy AppRoutes) (Proxy :: Proxy Home) + +see :: Model -> View Action +see m = div_ + [class_ "container mt-5"] + [ div_ + [class_ "jumbotron"] + [ h1_ [class_ "display-4"] [text "Influenced by books"] + , p_ [class_ "lead"] + [text "Influential people and the books that made them."] + , p_ + [class_ "lead"] + [ a_ + [href_ "http://eepurl.com/ghBFjv"] + [ text + "Get new book recommendations from the world's influencers in your email." + ] + ] + ] + , div_ [class_ "card-columns"] $ case people m of + NotAsked -> [text "Initializing..."] + Loading -> [text "Loading..."] + Failure err -> [text err] + Success ps -> seePerson View Action +seePerson person = div_ + [class_ "card"] + [ div_ [class_ "card-img"] + [img_ [class_ "card-img img-fluid", src_ $ ms $ _pic person]] + , div_ + [class_ "card-body"] + [ h4_ [class_ "card-title"] [text $ ms $ _name person] + , h6_ + [] + [ a_ + [ class_ "fab fa-twitter" + , href_ $ "https://twitter.com/" <> (ms $ _twitter person) + ] + [] + , a_ [class_ "fas fa-globe", href_ $ ms $ _website person] [] + ] + , p_ [class_ "card-text"] + [text $ ms $ _blurb person, ul_ [] $ seeBook View Action +seeBook book = li_ + [] + [ a_ + [ class_ "text-dark" + , href_ $ "https://www.amazon.com/dp/" <> (ms $ _amznref book) + ] + [text $ ms $ _title book] + ] diff --git a/Biz/Ibb/Influencers.hs b/Biz/Ibb/Influencers.hs new file mode 100644 index 0000000..c31e962 --- /dev/null +++ b/Biz/Ibb/Influencers.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Biz.Ibb.Influencers where + +import Biz.Ibb.Core + +allPeople :: [Person] +allPeople = + [ Person { _name = "Joe Rogan" + , _pic = "https://pbs.twimg.com/profile_images/552307347851210752/vrXDcTFC_400x400.jpeg" + , _twitter = "joerogan" + , _blurb = "Stand up comic/mixed martial arts fanatic/psychedelic adventurer Host of The Joe Rogan Experience" + , _website = "http://joerogan.com" + , _books = [ Book {_title = "Food of the Gods" + , _author = "Terence McKenna" + , _amznref = "0553371304" + } + , Book { _title = "The War of Art" + , _author ="Steven Pressfield" + , _amznref ="B007A4SDCG" + } + ] + } + , Person { _name = "Beyoncé" + , _pic = "https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcTxT84sF19lxdnSiblIXAp-Y4wAigpQn8sZ2GtAerIR_ApiiEJfFQ" + , _twitter = "Beyonce" + , _blurb = "American singer, songwriter, actress, record producer and dancer" + , _website = "http://beyonce.com" + , _books = [ Book { _title = "What Will It Take To Make A Woman President?" + , _author = "Marianne Schnall" + , _amznref = "B00E257Y7G"} + ] + } + , Person { _name = "Barrack Obama" + , _pic = "https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcQeLzftR36p0hYI-EKNa5fm7CYDuN-vyz23_R48ocqa8X1nPr6C" + , _twitter = "BarackObama" + , _blurb = "Dad, husband, President, citizen. 44th POTUS" + , _website = "http://barackobama.com" + , _books = [ Book { _title = "An American Marriage" + , _author = "Tayari Jones" + , _amznref = "B01NCUXEFR"} + , Book { _title = "Americanah" + , _author = "Chimamanda Ngozi Adichie" + , _amznref = "B00A9ET4MC"} + ] + } + , Person { _name = "Warren Buffet" + , _pic = "https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcQQbmnUykS6zqgzaf44tsq1RAsnHe6H7fapEoSqUwAoJGSFKbAPSw" + , _twitter = "WarrenBuffett" + , _blurb = "Chairman and CEO of Berkshire Hathaway" + , _website = "http://berkshirehathaway.com" + , _books = [ Book { _title = "The Intelligent Investor" + , _author = "Benjamin Graham" + , _amznref = "B000FC12C8"} + , Book { _title = "Security Analysis" + , _author = "Benjamin Graham" + , _amznref = "B0037JO5J8"} + ] + } + , Person { _name = "Bill Gates" + , _pic = "https://pbs.twimg.com/profile_images/988775660163252226/XpgonN0X_400x400.jpg" + , _twitter = "BillGates" + , _blurb = "Sharing things I'm learning through my foundation work and other interests. Founder of Microsoft and Bill & Melinda Gates Foundation" + , _website = "https://www.gatesnotes.com" + , _books = [ Book { _title = "Leonardo da Vinci" + , _author = "Walter Isaacson" + , _amznref = "1501139169" + } + , Book { _title = "Educated" + , _author = "Tara Wetsover" + , _amznref = "B072BLVM83" + } + ] + } + , Person { _name = "Stephen King" + , _pic = "https://pbs.twimg.com/profile_images/378800000836981162/b683f7509ec792c3e481ead332940cdc_400x400.jpeg" + , _twitter = "StephenKing" + , _blurb = "World renowned Author" + , _website = "https://stephenking.com/" + , _books = [ Book { _title = "Red Moon" + , _author = "Benjamin Percy" + , _amznref = "B008TU2592" + } + , Book { _title = "The Marauders" + , _author = "Tom Cooper" + , _amznref = "B00MKZBVTM" + } + ] + } + , Person { _name = "Tobi Lütke" + , _pic = "https://pbs.twimg.com/profile_images/551403375141457920/28EOlhnM_400x400.jpeg" + , _twitter = "tobi" + , _blurb = "Shopify CEO by day, Dad in the evening, hacker at night. - Rails Core alumni; Author of ActiveMerchant, Liquid. Comprehensivist" + , _website = "https://www.shopify.com" + , _books = [ Book { _title = "Influence" + , _author ="Robert B. Cialdini" + , _amznref = "006124189X" + } + , Book { _title = "High Output Management" + , _author ="Andrew S. Grove" + , _amznref = "B015VACHOK" + } + ] + } + , Person { _name = "Susan Cain" + , _pic = "https://pbs.twimg.com/profile_images/1474290079/SusanCain5smaller-1_400x400.jpg" + , _twitter = "susancain" + , _blurb = "Bestselling author, award-winning speaker, http://Quietrev.com curator. Lover of bittersweet music & bittersweet chocolate, in equal measure." + , _website = "https://www.quietrev.com" + , _books = [ Book { _title = "Bird by Bird" + , _author ="Anne Lamott" + , _amznref = "0385480016" + } + , Book { _title = "Waking Up" + , _author ="Sam Harris" + , _amznref = "1451636024" + } + ] + } + , Person { _name = "Oprah Winfrey" + , _pic = "https://pbs.twimg.com/profile_images/1013835283698049025/q5ZN4yv3_400x400.jpg" + , _twitter = "Oprah" + , _blurb = "Oprah Winfrey is an American media executive, actress, talk show host, television producer and philanthropis" + , _website = "http://www.oprah.com/index.html" + , _books = [ Book { _title = "A New Earth" + , _author ="Eckhart Tolle" + , _amznref = "B000PC0S5K" + } + , Book { _title = "The Poisonwood Bible" + , _author ="Barbara Kingsolver" + , _amznref = "B000QTE9WU" + } + ] + } + , Person { _name = "Patrick Collison" + , _pic = "https://pbs.twimg.com/profile_images/825622525342199809/_iAaSUQf_400x400.jpg" + , _twitter = "patrickc" + , _blurb = "Fallibilist, optimist. Stripe CEO" + , _website = "https://patrickcollison.com" + , _books = [ Book { _title = "How Judges Think" + , _author ="Richard A. Posner" + , _amznref = "0674048067" + } + , Book { _title = "Programmers at Work" + , _author ="Susan Lammers" + , _amznref = "1556152116" + } + ] + } + , Person { _name = "Luis Von Ahn" + , _pic = "https://pbs.twimg.com/profile_images/1020343581087678464/NIXD5MdC_400x400.jpg" + , _twitter = "LuisvonAhn" + , _blurb = "CEO & co-founder of duolingo. Invented reCAPTCHA. Computer science professor at Carnegie Mellon. Proud Guatemalan" + , _website = "https://www.duolingo.com/" + , _books = [ Book { _title = "Zero to One" + , _author ="Peter Thiel" + , _amznref = "B00J6YBOFQ" + } + , Book { _title = "The Hard Thing About Hard Things" + , _author ="Ben Horowitz" + , _amznref = "B00DQ845EA" + } + ] + } + , Person { _name = "Bryan Johnson" + , _pic = "https://pbs.twimg.com/profile_images/1055165076372475904/vNp60sSl_400x400.jpg" + , _twitter = "bryan_johnson" + , _blurb = "Founder of Kernel, OS Fund and Braintree. Trying to go where there is no destination" + , _website = "https://bryanjohnson.co" + , _books = [ Book { _title = "A Good Man" + , _author ="Mark Shriver" + , _amznref = "B007CLBH0M" + } + , Book { _title = "Shackleton" + , _author ="Nick Bertozzi" + , _amznref = "1596434511" + } + ] + } + , Person { _name = "Peter Thiel" + , _pic = "https://pbs.twimg.com/profile_images/1121220551/Peter_Thiel_400x400.jpg" + , _twitter = "peterthiel" + , _blurb = "Technology entrepreneur, investor, philanthropist." + , _website = "http://zerotoonebook.com" + , _books = [ Book { _title = "Deceit, Desire, and the Novel" + , _author ="René Girard" + , _amznref = "0801818303" + } + , Book { _title = "Violence and the Sacred" + , _author ="René Girard" + , _amznref = "0801822181" + } + ] + } + , Person { _name = "Tim Ferris" + , _pic = "https://pbs.twimg.com/profile_images/49918572/half-face-ice_400x400.jpg" + , _twitter = "tferriss" + , _blurb = "Author of 5 #1 NYT/WSJ bestsellers, investor (FB, Uber, Twitter, 50+ more: http://angel.co/tim ), host of The Tim Ferriss Show podcast (300M+ downloads)" + , _website = "http://tim.blog" + , _books = [ Book { _title = "10% Happier" + , _author ="Dan Harris" + , _amznref = "0062265431" + } + , Book { _title = "A Guide to the Good Life" + , _author ="William Irvine" + , _amznref = "B0040JHNQG" + } + ] + } + , Person { _name = "Allen Walton" + , _pic = "https://pbs.twimg.com/profile_images/1038905908678545409/yUbF9Ruc_400x400.jpg" + , _twitter = "allenthird" + , _blurb = "Created http://SpyGuy.com and blogs about stuff at http://AllenWalton.com . All things ecommerce, personal dev, and Simpsons." + , _website = "https://www.allenwalton.com" + , _books = [ Book { _title = "4 Hour Work Week" + , _author ="Tim Ferris" + , _amznref = "B002WE46UW" + } + , Book { _title = "Choose Yourself" + , _author ="James Altucher" + , _amznref = "B00CO8D3G4" + } + ] + } + , Person { _name = "Peter Mallouk" + , _pic = "https://pbs.twimg.com/profile_images/713172266968715264/KsyDYghf_400x400.jpg" + , _twitter = "PeterMallouk" + , _blurb = "President of Creative Planning. Author “5 Mistakes Every Investor Makes & How to Avoid Them”. Radically moderate." + , _website = "https://creativeplanning.com" + , _books = [ Book { _title = "Awareness" + , _author ="Anthony de Mello SJ" + , _amznref = "B005GFBP6W" + } + , Book { _title = "The Prophet" + , _author ="Kahlil Gibran" + , _amznref = "B07NDJ3LMW" + } + ] + } + , Person { _name = "Adam Robinson" + , _pic = "https://pbs.twimg.com/profile_images/822708907051077632/y5KyboMV_400x400.jpg" + , _twitter = "IAmAdamRobinson" + , _blurb = "Entrepreneur. Systems builder. Wizard. Shaman of global financial markets. Manifester. Didact. Do-gooder. Alchemist. Aphorist. Seeker. Embracer of possibility." + , _website = "http://robinsonglobalstrategies.com" + , _books = [ Book { _title = "Wishcraft" + , _author ="Barbara Sher" + , _amznref = "0345465180" + } + , Book { _title = "You Can Be a Stock Market Genius" + , _author ="Joel Greenblatt" + , _amznref = "0684832135" + } + ] + } + , Person { _name = "Andrew Weil" + , _pic = "https://pbs.twimg.com/profile_images/987461787422359553/mpoZAmPH_400x400.jpg" + , _twitter = "DrWeil" + , _blurb = "A world-renowned leader and pioneer in the field of integrative medicine, a healing oriented approach to health care which encompasses body, mind, and spirit." + , _website = "https://www.drweil.com" + , _books = [ Book { _title = "The Way Of Life According To Lao Tzu" + , _author = "Witter Byner" + , _amznref = "0399512985" + } + , Book { _title = "The Psychology of Romantic Love" + , _author ="Nathaniel Branden" + , _amznref = "B0012RMVJI" + } + ] + } + , Person { _name = "Hubert Joly" + , _pic = "https://scontent-ort2-2.xx.fbcdn.net/v/t1.0-1/c1.0.193.193a/38444401_2156120597936470_9028564067043770368_n.jpg?_nc_cat=104&_nc_ht=scontent-ort2-2.xx&oh=162142edb167f389a5b585a329e4993a&oe=5CE1D578" + , _twitter = "BBYCEO" + , _blurb = "CEO of Best Buy" + , _website = "https://www.bestbuy.com" + , _books = [ Book { _title = "Who Says Elephants Can't Dance" + , _author = "Louis. V. Gerstner" + , _amznref = "0060523808" + } + , Book { _title = "Onward" + , _author ="Howard Schultz" + , _amznref = "1609613821" + } + ] + } + , Person { _name = "Esther Perel" + , _pic = "https://pbs.twimg.com/profile_images/1091062675151319040/MzxCcgdU_400x400.jpg" + , _twitter = "EstherPerel" + , _blurb = "Exploring modern relationships. Author of MatingInCaptivity and TheStateOfAffairsBook. Podcast: WhereShouldWeBegin. Psychotherapist in NYC." + , _website = "https://www.estherperel.com" + , _books = [ Book { _title = "Crime And Punishment" + , _author = "Fyodor Dostoyevsky" + , _amznref = "B07NL94DFD" + } + , Book { _title = "If This Is a Man and The Truce" + , _author ="Primo Levi" + , _amznref = "0349100136" + } + ] + } + , Person { _name ="Neil deGrasse Tyson" + , _pic = "https://pbs.twimg.com/profile_images/74188698/NeilTysonOriginsA-Crop_400x400.jpg" + , _twitter = "neiltyson" + , _blurb = "Astrophysicistthe. Fifth head since 1935 of the world-renowned Hayden Planetarium in New York City and the first occupant of its Frederick P. Rose Directorship. Research associate of the Department of Astrophysics at the American Museum of Natural History." + , _website = "https://www.haydenplanetarium.org/tyson/" + , _books = [ Book { _title = "The Prince" + , _author = "Machiavelli" + , _amznref = "B07ND3CM16" + } + , Book { _title = "The Art of War" + , _author ="Sun Tzu" + , _amznref = "1545211957" + } + ] + } + , Person { _name = "Mark Cuban" + , _pic = "https://pbs.twimg.com/profile_images/1422637130/mccigartrophy_400x400.jpg" + , _twitter = "mcuban" + , _blurb = "Owner of Dallas Mavericks, Shark on ABC’s Shark Tank, chairman and CEO of AXS tv, and investor in an ever-growing portfolio of businesses" + , _website = "http://markcubancompanies.com/" + , _books = [ Book { _title = "The Fountainhead" + , _author = "Ayn Rend" + , _amznref = "0452273331" + } + , Book { _title = "The Gospel of Wealth " + , _author ="Andrew Carnegie" + , _amznref = "1409942171" + } + ] + } + , Person { _name = "Robert Herjavec" + , _pic = "https://pbs.twimg.com/profile_images/608643660876423170/DgxUW3eZ_400x400.jpg" + , _twitter = "robertherjavec" + , _blurb = "Dad, Husband, Founder & CEO of global cybersecurity firm HerjavecGroup, Shark on ABC’s Shark Tank, Former Dragon, Author" + , _website = "https://www.robertherjavec.com/" + , _books = [ Book { _title = "Why I Run" + , _author = "Mark Sutcliffe" + , _amznref = "B007OC9P3A" + } + , Book { _title = "Swim with the Sharks Without Being Eaten Alive" + , _author ="Harvey B. Mackay" + , _amznref = "006074281X" + } + ] + } + , Person { _name = "Caterina Fake" + , _pic = "https://pbs.twimg.com/profile_images/378800000509318185/d968d62d1bc39f2c82d3fa44db478525_400x400.jpeg" + , _twitter = "Caterina" + , _blurb = "Host, Should this Exist? Investor, Yes VC. Cofounder: Flickr, Hunch, Sesat School. Etsy. Sundance. Homeschooling, film, literature. Dogs." + , _website = "https://caterina.net" + , _books = [ Book { _title = "Growth of the Soil" + , _author = "Knut Hamsun" + , _amznref = "0343181967" + } + , Book { _title = "The Thousand Autumns of Jacob de Zoet" + , _author ="David Mitchell" + , _amznref = "0812976363" + } + ] + } + , Person { _name = "Daymond John" + , _pic = "https://pbs.twimg.com/profile_images/1048022980863954944/eZvGANn0_400x400.jpg" + , _twitter = "TheSharkDaymond" + , _blurb = "CEO of FUBU, Shark on ABC’s Shark Tank, Author." + , _website = "https://daymondjohn.com/" + , _books = [ Book { _title = "Think and Grow Rich" + , _author = "Napoleon Hill" + , _amznref = "1585424331" + } + , Book { _title = "How to Win Friends & Influence People" + , _author ="Dale Carnegie" + , _amznref = "0671027034" + } + ] + } + , Person { _name = "Kevin O'Leary" + , _pic = "https://pbs.twimg.com/profile_images/1067383195597889536/cP6tNEt0_400x400.jpg" + , _twitter = "kevinolearytv" + , _blurb = "Chairman O'Shares ETFs, 4 time Emmy Award winning Shark Tank's Mr. Wonderful, bestselling author, CNBC contributor, wine maker, guitar dude and photographer." + , _website = "http://askmrwonderful.eone.libsynpro.com/" + , _books = [ Book { _title = "Competitive Advantage" + , _author = "Michael Porter" + , _amznref = "0684841460" + } + , Book { _title = "Secrets of Closing the Sale" + , _author ="Zig Ziglar" + , _amznref = "0425081028" + } + ] + } + , Person { _name = "Alex Rodriguez" + , _pic = "https://pbs.twimg.com/profile_images/796405335388848128/LbvsjCA3_400x400.jpg" + , _twitter = "AROD" + , _blurb = "3-time MVP • 14-time All Star • World Series Champ • CEO of @_ARodCorp• @FoxSports Commentator/Analyst • Special Advisor to the Yankees, @ABCSharkTank and ESPN" + , _website = "http://www.arodcorp.com/" + , _books = [ Book { _title = "Blitzscaling" + , _author = "Reid Hoffman" + , _amznref = "1524761419" + } + , Book { _title = "Measure What Matters" + , _author ="John Doerr" + , _amznref = "0525536221" + } + ] + } + ] diff --git a/Biz/Ibb/Keep.hs b/Biz/Ibb/Keep.hs new file mode 100644 index 0000000..ad6dc5c --- /dev/null +++ b/Biz/Ibb/Keep.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Keep is a database built on Data.Acid. +-- +-- If this proves useful, maybe we could make it a more general thing. Like +-- `Biz.Keep`. I could wrap all the safecopy stuff in my own template haskell +-- like `$(keep ''MyType)`. +-- +module Biz.Ibb.Keep where + +import Biz.Ibb.Core (Person(..), Book(..)) +import qualified Biz.Ibb.Influencers as Influencers +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) +import Data.Acid (Update, makeAcidic) +import qualified Data.Acid as Acid +import Data.Data (Data, Typeable) +import Data.IxSet (Indexable(..), IxSet, ixFun, ixSet) +import qualified Data.IxSet as IxSet +import Data.SafeCopy +import Data.Text (Text) +import qualified Data.Text as Text + +-- * Keep + +-- | Main database. Need to think of a better name for this. +data IbbKeep = IbbKeep + { _people :: IxSet Person + } + deriving (Data, Typeable) + +$(deriveSafeCopy 0 'base ''IbbKeep) + +-- * Index @Person@ + +$(deriveSafeCopy 0 'base ''Person) + +newtype PersonName = + PersonName Text deriving (Eq, Ord, Data, Typeable) + +newtype PersonBlurb = + PersonBlurb Text deriving (Eq, Ord, Data, Typeable) + +instance Indexable Person where + empty = ixSet + [ ixFun $ \p -> [ PersonName $ _name p ] + , ixFun $ \p -> [ _pic p ] + , ixFun $ \p -> [ _twitter p ] + , ixFun $ \p -> [ _website p ] + , ixFun $ \p -> [ _books p ] + , ixFun $ \p -> [ PersonBlurb $ _blurb p ] + ] + +-- | updates the `IbbKeep` with a new `Person` +newPerson :: Text -> Text -> Update IbbKeep Person +newPerson name blurb = do + k <- get + put $ k { _people = IxSet.insert p (_people k) + } + return p + where + p = Person + { _name = name + , _pic = Text.empty + , _twitter = Text.empty + , _website = Text.empty + , _books = [] + , _blurb = blurb + } + +getPeople :: Int -> Acid.Query IbbKeep [Person] +getPeople n = do + keep <- ask + return $ take n $ IxSet.toList $ _people keep + +-- * Index @Book@ + +$(deriveSafeCopy 0 'base ''Book) + +newtype BookTitle = + BookTitle Text deriving (Eq, Ord, Data, Typeable) + +newtype BookAuthor = + BookAuthor Text deriving (Eq, Ord, Data, Typeable) + +instance Indexable Book where + empty = ixSet + [ ixFun $ \b -> [ BookTitle $ _title b ] + , ixFun $ \b -> [ BookAuthor $ _author b ] + , ixFun $ \b -> [ _amznref b ] + ] + +-- | updates the `IbbKeep` with a new `Book` +--newBook :: Text -> Text -> Text -> Update IbbKeep Book +--newBook title author amznref = do +-- ibbKeep <- get +-- put $ ibbKeep { _books = IxSet.insert b (_books ibbKeep) +-- , _people = _people ibbKeep +-- } +-- return b +-- where +-- b = Book { _title = title +-- , _author = author +-- , _amznref = amznref +-- } + +-- * Opening the keep + +-- defines @NewPerson@ for us. +$(makeAcidic ''IbbKeep ['newPerson, 'getPeople]) + +initialIbbKeep :: IbbKeep +initialIbbKeep = IbbKeep + { _people = IxSet.fromList Influencers.allPeople + } + +openLocal :: String -> IO (Acid.AcidState IbbKeep) +openLocal dir = + Acid.openLocalStateFrom dir initialIbbKeep diff --git a/Biz/Ibb/Look.hs b/Biz/Ibb/Look.hs new file mode 100644 index 0000000..5f7ca6b --- /dev/null +++ b/Biz/Ibb/Look.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | The look and feel of Ibb +module Biz.Ibb.Look where + +import Alpha hiding ( Selector ) +import Clay +import qualified Clay.Flexbox as Flexbox +import qualified Clay.Media as Media +import qualified Clay.Render as Clay +import qualified Clay.Stylesheet as Stylesheet + +main :: Css +main = do + "html" <> "body" ? do + width (pct 100) + display flex + flexDirection column + alignItems center + alignContent center + justifyContent center + ".container" ? do + maxWidth (px 900) + display flex + justifyContent center + flexDirection column + fontFamily ["GillSans", "Calibri", "Trebuchet"] [sansSerif] + headings ? do + fontFamily + [ "Palatino" + , "Palatino Linotype" + , "Hoefler Text" + , "Times New Roman" + , "Times" + ] + [serif] + +headings :: Selector +headings = h1 <> h2 <> h3 <> h4 <> h5 <> h6 diff --git a/Biz/Ibb/Move.hs b/Biz/Ibb/Move.hs new file mode 100644 index 0000000..1e635ac --- /dev/null +++ b/Biz/Ibb/Move.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | App update logic +module Biz.Ibb.Move + ( move + -- * Server interactions + , fetchPeople + ) +where + +import Alpha +import Biz.Ibb.Core as Core +import Network.RemoteData +import Data.Aeson +import JavaScript.Web.XMLHttpRequest ( Request(..) + , Method(GET) + , RequestData(NoData) + , contents + , xhrByteString + ) +import Miso +import Miso.String + +move :: Action -> Model -> Effect Action Model +move Nop m = noEff m +move (HandleRoute u) m = m { uri = u } <# pure Nop +move (ChangeRoute u) m = m <# do + pushURI u >> pure Nop +move FetchPeople m = m <# (SetPeople pure $ Failure "could not read from server" + Just a -> + pure $ fromEither $ either (Left . ms) pure $ eitherDecodeStrict a + where + req = Request { reqMethod = GET + -- FIXME: can replace this hardcoding with a function? + , reqURI = "/api/people" + , reqLogin = Nothing + , reqHeaders = [] + , reqWithCredentials = False + , reqData = NoData + } diff --git a/Biz/Ibb/Server.hs b/Biz/Ibb/Server.hs new file mode 100644 index 0000000..9f1ac5f --- /dev/null +++ b/Biz/Ibb/Server.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | Server +-- +-- : exe ibb +-- +-- : dep clay +-- : dep miso +-- : dep protolude +-- : dep servant +-- : dep text +-- : dep MonadRandom +-- : dep acid-state +-- : dep bytestring +-- : dep ixset +-- : dep random +-- : dep safecopy +-- : dep scotty +-- : dep servant-server +-- : dep text +module Biz.Ibb.Server where + +import Alpha +import qualified Clay +import Biz.Ibb.Core +import qualified Biz.Ibb.Keep as Keep +import qualified Biz.Ibb.Look as Look +import Network.RemoteData +import Data.Acid ( AcidState ) +import qualified Data.Acid.Abstract as Acid +import Data.Maybe ( fromMaybe ) +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy.Encoding as Lazy +import qualified Lucid as L +import Lucid.Base +import Miso +import Network.HTTP.Media ( (//) + , (/:) + ) +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Application.Static +import Network.Wai.Handler.Warp +import Network.Wai.Middleware.Gzip +import Network.Wai.Middleware.RequestLogger +import Servant +import System.Environment ( lookupEnv ) + +main :: IO () +main = do + say "rise: ibb" + staticDir <- fromMaybe "static" <$> lookupEnv "STATIC_DIR" :: IO [Char] + port <- read <$> fromMaybe "3000" <$> lookupEnv "PORT" :: IO Int + keep <- Keep.openLocal "_keep/" + say "port: 3000" + run port $ logStdout $ compress $ app staticDir $ keep + where compress = gzip def { gzipFiles = GzipCompress } + +newtype HtmlPage a = HtmlPage a + deriving (Show, Eq) + +instance L.ToHtml a => L.ToHtml (HtmlPage a) where + toHtmlRaw = L.toHtml + toHtml (HtmlPage x) = L.doctypehtml_ $ do + L.head_ $ do + L.meta_ [L.charset_ "utf-8"] + jsRef "/static/ibb.js" + cssRef "/css/main.css" + L.body_ $ do + page + where + page = L.toHtml x + jsRef href = L.with + (L.script_ mempty) + [ makeAttribute "src" href + , makeAttribute "type" "text/javascript" + , makeAttribute "async" mempty + , makeAttribute "defer" mempty + ] + cssRef href = L.with + (L.link_ mempty) + [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href] + +type ServerRoutes = ToServerRoutes AppRoutes HtmlPage Action + +handle404 :: Application +handle404 _ respond = + respond + $ responseLBS status404 [("Content-Type", "text/html")] + $ renderBS + $ toHtml + $ HtmlPage + $ notfound + +newtype CSS = CSS + { unCSS :: Text + } + +instance MimeRender CSS Text where + mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict + +instance Accept CSS where + contentType _ = "text" // "css" /: ("charset", "utf-8") + +type CssRoute = "css" :> "main.css" :> Get '[CSS] Text + +type Routes + = "static" + :> + Raw + :<|> + CssRoute + :<|> + ServerRoutes + :<|> + "api" + :> + ApiRoutes + :<|> + Raw + +cssHandlers :: Server CssRoute +cssHandlers = return . Lazy.toStrict . Clay.render $ Look.main + +app :: [Char] -> AcidState Keep.IbbKeep -> Application +app staticDir keep = + serve (Proxy @Routes) + $ static + :<|> cssHandlers + :<|> serverHandlers + :<|> apiHandlers keep + :<|> Tagged handle404 + where static = serveDirectoryWith (defaultWebAppSettings $ staticDir) + +type ApiRoutes = "people" :> Get '[JSON] [Person] + +serverHandlers :: Server ServerRoutes +serverHandlers = homeHandler + where + send f u = pure $ HtmlPage $ f Model { uri = u, people = NotAsked } + homeHandler = send home goHome + +-- | for now we just have one api endpoint, which returns all the people +apiHandlers :: AcidState Keep.IbbKeep -> Server ApiRoutes +apiHandlers keep = Acid.query' keep $ Keep.GetPeople 20 diff --git a/Biz/Ibb/service.nix b/Biz/Ibb/service.nix new file mode 100644 index 0000000..f9d0f36 --- /dev/null +++ b/Biz/Ibb/service.nix @@ -0,0 +1,42 @@ +{ options +, lib +, config +, pkgs +, modulesPath +}: + +let + cfg = config.services.ibb; +in +{ + options.services.ibb = { + enable = lib.mkEnableOption "Enable the IBB service"; + port = lib.mkOption { + type = lib.types.string; + default = "3000"; + description = '' + The port on which IBB will listen for + incoming HTTP traffic. + ''; + }; + }; + config = lib.mkIf cfg.enable { + systemd.services.ibb = { + path = with pkgs; [ ibb bash ]; + wantedBy = [ "multi-user.target" ]; + script = '' + PORT=${cfg.port} ./bin/ibb + ''; + description = '' + Influenced By Books website + ''; + serviceConfig = { + WorkingDirectory = pkgs.ibb; + KillSignal = "INT"; + Type = "simple"; + Restart = "on-abort"; + RestartSec = "10"; + }; + }; + }; +} diff --git a/Biz/Language/Bs.hs b/Biz/Language/Bs.hs new file mode 100644 index 0000000..a810706 --- /dev/null +++ b/Biz/Language/Bs.hs @@ -0,0 +1,12 @@ +-- https://github.com/write-you-a-scheme-v2/scheme +-- https://github.com/justinethier/husk-scheme +module Language.Bs + ( module X + ) where + +import Language.Bs.Cli as X +import Language.Bs.Eval as X +import Language.Bs.Expr as X +import Language.Bs.Parser as X +import Language.Bs.Primitives as X +import Language.Bs.Repl as X diff --git a/Biz/Language/Bs/Cli.hs b/Biz/Language/Bs/Cli.hs new file mode 100644 index 0000000..4c48c86 --- /dev/null +++ b/Biz/Language/Bs/Cli.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Language.Bs.Cli ( + run +) where + +import Data.String +import Data.Text.IO as TIO +import Language.Bs.Eval -- evalFile :: T.Text -> IO () +import Language.Bs.Repl -- Repl.mainLoop :: IO () +import Options.Applicative +import Protolude +import System.Directory + +-- SOURCES +--http://book.realworldhaskell.org/read/io.html +-- https://github.com/pcapriotti/optparse-applicative +-- https://hackage.haskell.org/package/optparse-applicative + +runScript :: FilePath -> IO () +runScript fname = do + exists <- doesFileExist fname + if exists + then TIO.readFile fname >>= evalFile fname + else TIO.putStrLn "File does not exist." + +data LineOpts = UseReplLineOpts | RunScriptLineOpts String + +parseLineOpts :: Parser LineOpts +parseLineOpts = runScriptOpt <|> runReplOpt + where + runScriptOpt = + RunScriptLineOpts <$> strOption (long "script" + <> short 's' + <> metavar "SCRIPT" + <> help "File containing the script you want to run") + runReplOpt = + UseReplLineOpts <$ flag' () (long "repl" + <> short 'r' + <> help "Run as interavtive read/evaluate/print/loop") + +schemeEntryPoint :: LineOpts -> IO () +schemeEntryPoint UseReplLineOpts = mainLoop --repl +schemeEntryPoint (RunScriptLineOpts script) = runScript script + +run :: IO () +run = execParser opts >>= schemeEntryPoint + where + opts = info (helper <*> parseLineOpts) + ( fullDesc + <> header "Executable binary for Write You A Scheme v2.0" + <> progDesc "contains an entry point for both running scripts and repl" ) diff --git a/Biz/Language/Bs/Eval.hs b/Biz/Language/Bs/Eval.hs new file mode 100644 index 0000000..290170b --- /dev/null +++ b/Biz/Language/Bs/Eval.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Language.Bs.Eval ( + evalText +, evalFile +, runParseTest +, safeExec +, runASTinEnv +, basicEnv +, fileToEvalForm +, textToEvalForm +, getFileContents +) where + +import Control.Exception +import Control.Monad.Reader +import qualified Data.Map as Map +import Data.String +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Language.Bs.Expr +import Language.Bs.Parser +import Language.Bs.Primitives +import Protolude +import System.Directory + +funcEnv :: Map.Map T.Text Expr +funcEnv = Map.fromList $ primEnv + <> [ ("read" , IFun $ IFunc $ unop readFn) + , ("parse", IFun $ IFunc $ unop parseFn) + , ("eval", IFun $ IFunc $ unop eval) + , ("show", IFun $ IFunc $ unop (return . Tape . ppexpr)) + ] + +basicEnv :: Env +basicEnv = Env Map.empty funcEnv + +readFn :: Expr -> Eval Expr +readFn (Tape txt) = lineToEvalForm txt +readFn val = throw $ TypeMismatch "read expects string, instead got:" val + +parseFn :: Expr -> Eval Expr +parseFn (Tape txt) = either (throw . ParseError . show) return $ readExpr txt +parseFn val = throw $ TypeMismatch "parse expects string, instead got:" val + +safeExec :: IO a -> IO (Either String a) +safeExec m = do + result <- Control.Exception.try m + case result of + Left (eTop :: SomeException) -> + case fromException eTop of + Just (enclosed :: LispError) -> + return $ Left (show enclosed) + Nothing -> + return $ Left (show eTop) + Right val -> + return $ Right val + +runASTinEnv :: Env -> Eval b -> IO b +runASTinEnv code action = runReaderT (unEval action) code + +lineToEvalForm :: T.Text -> Eval Expr +lineToEvalForm input = either (throw . ParseError . show ) eval $ readExpr input + +evalFile :: FilePath -> T.Text -> IO () -- program file +evalFile filePath fileExpr = (runASTinEnv basicEnv $ fileToEvalForm filePath fileExpr) >>= print + +fileToEvalForm :: FilePath -> T.Text -> Eval Expr +fileToEvalForm filePath input = either (throw . ParseError . show ) evalBody $ readExprFile filePath input + +runParseTest :: T.Text -> T.Text -- for view AST +runParseTest input = either (T.pack . show) (T.pack . show) $ readExpr input + +getFileContents :: FilePath -> IO T.Text +getFileContents fname = do + exists <- doesFileExist fname + if exists then TIO.readFile fname else return "File does not exist." + +textToEvalForm :: T.Text -> Eval Expr +textToEvalForm input = either (throw . ParseError . show ) evalBody $ readExpr input + +evalText :: T.Text -> IO () --REPL +evalText textExpr = do + res <- runASTinEnv basicEnv $ textToEvalForm textExpr + print res + +getVar :: Expr -> Eval Expr +getVar (Atom atom) = do + Env{..} <- ask + case Map.lookup atom (Map.union fenv env) of -- lookup, but prefer functions + Just x -> return x + Nothing -> throw $ UnboundVar atom +getVar n = throw $ TypeMismatch "failure to get variable: " n + +ensureAtom :: Expr -> Eval Expr +ensureAtom n@(Atom _) = return n +ensureAtom n@(List _) = throw $ TypeMismatch "got list" n +ensureAtom n = throw $ TypeMismatch "expected an atomic value" n + +extractVar :: Expr -> T.Text +extractVar (Atom atom) = atom +extractVar n = throw $ TypeMismatch "expected an atomic value" n + +getEven :: [t] -> [t] +getEven [] = [] +getEven (x:xs) = x : getOdd xs + +getOdd :: [t] -> [t] +getOdd [] = [] +getOdd (_:xs) = getEven xs + +applyFunc :: Expr -> [Expr] -> [Expr] -> Eval Expr +applyFunc expr params args = bindArgsEval params args expr + +bindArgsEval :: [Expr] -> [Expr] -> Expr -> Eval Expr +bindArgsEval params args expr = do + Env{..} <- ask + let newVars = zipWith (\a b -> (extractVar a,b)) params args + let (newEnv, newFenv) = Map.partition (not . isFunc) $ Map.fromList newVars + local (const $ Env (newEnv <> env) (newFenv <> fenv)) $ eval expr + +isFunc :: Expr -> Bool +isFunc (List ((Atom "lambda"):_)) = True +isFunc _ = False + +eval :: Expr -> Eval Expr +eval (List [Atom "dumpEnv", x]) = do + Env{..} <- ask + liftIO $ print $ toList env + liftIO $ print $ toList fenv + eval x + +eval (Numb i) = return $ Numb i +eval (Tape s) = return $ Tape s +eval (Bool b) = return $ Bool b +eval (List []) = return Nil +eval Nil = return Nil +eval n@(Atom _) = getVar n + +eval (List [Atom "showSF", rest]) = return . Tape . T.pack $ show rest +eval (List ((:) (Atom "showSF") rest)) = return . Tape . T.pack . show $ List rest + +eval (List [Atom "quote", val]) = return val + +eval (List [Atom "if", pred_, then_, else_]) = do + ifRes <- eval pred_ + case ifRes of + (Bool True) -> eval then_ + (Bool False) -> eval else_ + _ -> + throw $ BadSpecialForm "if's first arg must eval into a boolean" +eval (List ( (:) (Atom "if") _)) = + throw $ BadSpecialForm "(if )" + +eval (List [Atom "begin", rest]) = evalBody rest +eval (List ((:) (Atom "begin") rest )) = evalBody $ List rest + +-- top-level define +-- TODO: how to make this eval correctly? +eval (List [Atom "define", List (name:args), body]) = do + Env{..} <- ask + _ <- eval body + bindArgsEval (name:args) [body] name + +eval (List [Atom "define", name, body]) = do + Env{..} <- ask + _ <- eval body + bindArgsEval [name] [body] name + +eval (List [Atom "let", List pairs, expr]) = do + Env{..} <- ask + atoms <- mapM ensureAtom $ getEven pairs + vals <- mapM eval $ getOdd pairs + bindArgsEval atoms vals expr + +eval (List (Atom "let":_) ) = + throw $ BadSpecialForm "let function expects list of parameters and S-Expression body\n(let )" + + +eval (List [Atom "lambda", List params, expr]) = do + ctx <- ask + return $ Func (IFunc $ applyFunc expr params) ctx +eval (List (Atom "lambda":_) ) = throw $ BadSpecialForm "lambda function expects list of parameters and S-Expression body\n(lambda )" + + +-- needed to get cadr, etc to work +eval (List [Atom "cdr", List [Atom "quote", List (_:xs)]]) = + return $ List xs +eval (List [Atom "cdr", arg@(List (x:xs))]) = + case x of + -- proxy for if the list can be evaluated + Atom _ -> do + val <- eval arg + eval $ List [Atom "cdr", val] + _ -> return $ List xs + + +eval (List [Atom "car", List [Atom "quote", List (x:_)]]) = + return $ x +eval (List [Atom "car", arg@(List (x:_))]) = + case x of + Atom _ -> do + val <- eval arg + eval $ List [Atom "car", val] + _ -> return $ x + + +eval (List ((:) x xs)) = do + Env{..} <- ask + funVar <- eval x + xVal <- mapM eval xs + case funVar of + (IFun (IFunc internalFn)) -> + internalFn xVal + + (Func (IFunc definedFn) (Env benv _)) -> + local (const $ Env benv fenv) $ definedFn xVal + + _ -> + throw $ NotFunction funVar + +updateEnv :: T.Text -> Expr -> Env -> Env +updateEnv var e@(IFun _) Env{..} = Env env $ Map.insert var e fenv +updateEnv var e@(Func _ _) Env{..} = Env env $ Map.insert var e fenv +updateEnv var e Env{..} = Env (Map.insert var e env) fenv + +evalBody :: Expr -> Eval Expr +evalBody (List [List ((:) (Atom "define") [Atom var, defExpr]), rest]) = do + evalVal <- eval defExpr + ctx <- ask + local (const $ updateEnv var evalVal ctx) $ eval rest + +evalBody (List ((:) (List ((:) (Atom "define") [Atom var, defExpr])) rest)) = do + evalVal <- eval defExpr + ctx <- ask + local (const $ updateEnv var evalVal ctx) $ evalBody $ List rest + +evalBody x = eval x diff --git a/Biz/Language/Bs/Expr.hs b/Biz/Language/Bs/Expr.hs new file mode 100644 index 0000000..a39c7b6 --- /dev/null +++ b/Biz/Language/Bs/Expr.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Language.Bs.Expr where + +import Data.String (String) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Show +import Protolude hiding (show) +import qualified Text.PrettyPrint.Leijen.Text as PP +import Text.PrettyPrint.Leijen.Text hiding ((<$>)) + +type Ctx = Map Text Expr +data Env = Env { env :: Ctx, fenv :: Ctx } + deriving (Eq) + +newtype Eval a = Eval { unEval :: ReaderT Env IO a } + deriving (Monad, Functor, Applicative, MonadReader Env, MonadIO) + +data IFunc = IFunc { fn :: [Expr] -> Eval Expr } + deriving (Typeable) + +instance Eq IFunc where + (==) _ _ = False + +data Expr + = Atom Text + | List [Expr] + | Numb Integer + | Tape Text + | IFun IFunc -- TODO: call this Kern + | Func IFunc Env + | Bool Bool + | Nil + deriving (Typeable, Eq) + +instance Show Expr where + show = T.unpack . ppexpr + +data LispErrorType + = NumArgs Integer [Expr] + | LengthOfList Text Int + | ExpectedList Text + | ParseError String + | TypeMismatch Text Expr + | BadSpecialForm Text + | NotFunction Expr + | UnboundVar Text + | Default Expr + | ReadFileError Text + deriving (Typeable) + +data LispError = LispError Expr LispErrorType + +instance Show LispErrorType where + show = T.unpack . ppexpr + +instance Show LispError where + show = T.unpack . ppexpr + +instance Exception LispErrorType +instance Exception LispError + +ppexpr :: Pretty a => a -> Text +ppexpr x = PP.displayTStrict (PP.renderPretty 1.0 70 (pretty x)) + +--prettyList :: [Doc] -> Doc +--prettyList = encloseSep lparen rparen PP.space + +instance Pretty Expr where + pretty v = + case v of + Atom a -> + textStrict a + + List ls -> + prettyList $ fmap pretty ls + + Numb n -> + integer n + + Tape t -> + textStrict "\"" <> textStrict t <> textStrict "\"" + + IFun _ -> + textStrict "" + + Func _ _ -> + textStrict "" + + Bool True -> + textStrict "#t" + + Bool False -> + textStrict "#f" + + Nil -> + textStrict "'()" + +instance Pretty LispErrorType where + pretty err = case err of + NumArgs i args -> + textStrict "number of arguments" + <$$> textStrict "expected" + <+> textStrict (T.pack $ show i) + <$$> textStrict "received" + <+> textStrict (T.pack $ show $ length args) + + + LengthOfList txt i -> + textStrict "length of list in:" + <+> textStrict txt + <$$> textStrict "length:" + <+> textStrict (T.pack $ show i) + + ParseError txt -> + textStrict "cannot parse expr:" + <+> textStrict (T.pack txt) + + TypeMismatch txt expr -> + textStrict "type mismatch:" + <$$> textStrict txt + <$$> pretty expr + + BadSpecialForm txt -> + textStrict "bad special form:" + <$$> textStrict txt + + NotFunction expr -> + textStrict "not a function" + <$$> pretty expr + + UnboundVar txt -> + textStrict "unbound variable:" + <$$> textStrict txt + + Default _ -> + textStrict "default error" + + ReadFileError txt -> + textStrict "error reading file:" + <$$> textStrict txt + + ExpectedList txt -> + textStrict "expected list:" + <$$> textStrict txt + +instance Pretty LispError where + pretty (LispError expr typ) = + textStrict "error evaluating:" + <$$> indent 4 (pretty expr) + <$$> pretty typ diff --git a/Biz/Language/Bs/Parser.hs b/Biz/Language/Bs/Parser.hs new file mode 100644 index 0000000..3044a60 --- /dev/null +++ b/Biz/Language/Bs/Parser.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Language.Bs.Parser ( + readExpr +, readExprFile +) where + +import Control.Monad (fail) +import Control.Monad (mzero) +import Data.Char (digitToInt) +import Data.Functor.Identity (Identity) +import Data.String +import qualified Data.Text as T +import Language.Bs.Expr +import Protolude hiding ((<|>), try) +import Text.Parsec +import qualified Text.Parsec.Language as Lang +import Text.Parsec.Text +import qualified Text.Parsec.Token as Tok + +lexer :: Tok.GenTokenParser T.Text () Identity +lexer = Tok.makeTokenParser style + +style :: Tok.GenLanguageDef T.Text () Identity +style = Lang.emptyDef { + Tok.commentStart = "#|" + , Tok.commentEnd = "|#" + , Tok.commentLine = ";" + , Tok.opStart = mzero + , Tok.opLetter = mzero + , Tok.identStart = letter <|> oneOf "!$%&*/:<=>?^_~" + , Tok.identLetter = digit <|> letter <|> oneOf "!$%&*/:<=>?^_~+-.@" + } + +parens :: Parser a -> Parser a +parens = Tok.parens lexer + +whitespace :: Parser () +whitespace = Tok.whiteSpace lexer + +lexeme :: Parser a -> Parser a +lexeme = Tok.lexeme lexer + +quoted :: Parser a -> Parser a +quoted p = try (char '\'') *> p + +identifier :: Parser T.Text +identifier = T.pack <$> (Tok.identifier lexer <|> specialIdentifier) "identifier" + where + specialIdentifier :: Parser String + specialIdentifier = lexeme $ try $ + string "-" <|> string "+" <|> string "..." + +-- | The @Radix@ type consists of a base integer (e.g. @10@) and a parser for +-- digits in that base (e.g. @digit@). +type Radix = (Integer, Parser Char) + +-- | Parse an integer, given a radix as output by @radix@. +-- Copied from Text.Parsec.Token +numberWithRadix :: Radix -> Parser Integer +numberWithRadix (base, baseDigit) = do + digits <- many1 baseDigit + let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits + seq n (return n) + +decimal :: Parser Integer +decimal = Tok.decimal lexer + +-- | Parse a sign, return either @id@ or @negate@ based on the sign parsed. +-- Copied from Text.Parsec.Token +sign :: Parser (Integer -> Integer) +sign = char '-' *> return negate + <|> char '+' *> return identity + <|> return identity + +intRadix :: Radix -> Parser Integer +intRadix r = sign <*> numberWithRadix r + +textLiteral :: Parser T.Text +textLiteral = T.pack <$> Tok.stringLiteral lexer + +nil :: Parser () +nil = try ((char '\'') *> string "()") *> return () "nil" + +hashVal :: Parser Expr +hashVal = lexeme $ char '#' + *> (char 't' *> return (Bool True) + <|> char 'f' *> return (Bool False) + <|> char 'b' *> (Numb <$> intRadix (2, oneOf "01")) + <|> char 'o' *> (Numb <$> intRadix (8, octDigit)) + <|> char 'd' *> (Numb <$> intRadix (10, digit)) + <|> char 'x' *> (Numb <$> intRadix (16, hexDigit)) + <|> oneOf "ei" *> fail "Unsupported: exactness" + <|> char '(' *> fail "Unsupported: vector" + <|> char '\\' *> fail "Unsupported: char") + + +lispVal :: Parser Expr +lispVal = hashVal + <|> Nil <$ nil + <|> Numb <$> try (sign <*> decimal) + <|> Atom <$> identifier + <|> Tape <$> textLiteral + <|> _Quote <$> quoted lispVal + <|> List <$> parens manyExpr + +manyExpr :: Parser [Expr] +manyExpr = lispVal `sepBy` whitespace + +_Quote :: Expr -> Expr +_Quote x = List [Atom "quote", x] + +contents :: Parser a -> ParsecT T.Text () Identity a +contents p = whitespace *> lexeme p <* eof + +readExpr :: T.Text -> Either ParseError Expr +readExpr = parse (contents lispVal) "" + +readExprFile :: SourceName -> T.Text -> Either ParseError Expr +readExprFile = parse (contents (List <$> manyExpr)) diff --git a/Biz/Language/Bs/Primitives.hs b/Biz/Language/Bs/Primitives.hs new file mode 100644 index 0000000..c074c59 --- /dev/null +++ b/Biz/Language/Bs/Primitives.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | bs primitives +-- +-- I would like to reduce the number of primitives in the language to some +-- minimal number, like SKI combinator or Nock instructions. I'm not sure what +-- the minimal number is. The idea is to move primitives from here into core.scm +-- over time. +module Language.Bs.Primitives where + +import Control.Exception +import Control.Monad.Except +import Data.Text as T +import Data.Text.IO as TIO +import Language.Bs.Expr +import Network.HTTP +import Protolude +import System.Directory +import System.IO + +type Prim = [(T.Text, Expr)] +type Unary = Expr -> Eval Expr +type Binary = Expr -> Expr -> Eval Expr + +mkF :: ([Expr] -> Eval Expr) -> Expr +mkF = IFun . IFunc + +primEnv :: Prim +primEnv = [ + ("+" , mkF $ binopFold (numOp (+)) (Numb 0) ) + , ("*" , mkF $ binopFold (numOp (*)) (Numb 1) ) + , ("string-append", mkF $ binopFold (strOp (<>)) (Tape "") ) + , ("-" , mkF $ binop $ numOp (-)) + , ("<" , mkF $ binop $ numCmp (<)) + , ("<=" , mkF $ binop $ numCmp (<=)) + , (">" , mkF $ binop $ numCmp (>)) + , (">=" , mkF $ binop $ numCmp (>=)) + , ("==" , mkF $ binop $ numCmp (==)) + , ("even?" , mkF $ unop $ numBool even) + , ("odd?" , mkF $ unop $ numBool odd) + , ("neg?" , mkF $ unop $ numBool (< 0)) + , ("pos?" , mkF $ unop $ numBool (> 0)) + , ("eq?" , mkF $ binop eqCmd ) + , ("null?" , mkF $ unop (eqCmd Nil) ) + , ("bl-eq?" , mkF $ binop $ eqOp (==)) + , ("and" , mkF $ binopFold (eqOp (&&)) (Bool True)) + , ("or" , mkF $ binopFold (eqOp (||)) (Bool False)) + , ("not" , mkF $ unop $ notOp) + , ("cons" , mkF $ Language.Bs.Primitives.cons) + , ("cdr" , mkF $ Language.Bs.Primitives.cdr) + , ("car" , mkF $ Language.Bs.Primitives.car) + , ("quote" , mkF $ quote) + , ("file?" , mkF $ unop fileExists) + , ("slurp" , mkF $ unop slurp) + , ("wslurp" , mkF $ unop wSlurp) + , ("put" , mkF $ binop put_) + ] + +unop :: Unary -> [Expr] -> Eval Expr +unop op [x] = op x +unop _ args = throw $ NumArgs 1 args + +binop :: Binary -> [Expr] -> Eval Expr +binop op [x,y] = op x y +binop _ args = throw $ NumArgs 2 args + +fileExists :: Expr -> Eval Expr +fileExists (Tape txt) = Bool <$> liftIO (doesFileExist $ T.unpack txt) +fileExists val = throw $ TypeMismatch "read expects string, instead got: " val + +slurp :: Expr -> Eval Expr +slurp (Tape txt) = liftIO $ wFileSlurp txt +slurp val = throw $ TypeMismatch "read expects string, instead got: " val + +wFileSlurp :: T.Text -> IO Expr +wFileSlurp fileName = withFile (T.unpack fileName) ReadMode go + where go = readTextFile fileName + +openURL :: T.Text -> IO Expr +openURL x = do + req <- simpleHTTP (getRequest $ T.unpack x) + body <- getResponseBody req + return $ Tape $ T.pack body + +wSlurp :: Expr -> Eval Expr +wSlurp (Tape txt) = liftIO $ openURL txt +wSlurp val = throw $ TypeMismatch "wSlurp expects a string, instead got: " val + +readTextFile :: T.Text -> Handle -> IO Expr +readTextFile fileName h = do + exists <- doesFileExist $ T.unpack fileName + if exists + then (TIO.hGetContents h) >>= (return . Tape) + else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName] + +put_ :: Expr -> Expr -> Eval Expr +put_ (Tape file) (Tape msg) = liftIO $ wFilePut file msg +put_ (Tape _) val = throw $ TypeMismatch "put expects string in the second argument (try using show), instead got: " val +put_ val _ = throw $ TypeMismatch "put expects string, instead got: " val + +wFilePut :: T.Text -> T.Text -> IO Expr +wFilePut fileName msg = withFile (T.unpack fileName) WriteMode go + where go = putTextFile fileName msg + +putTextFile :: T.Text -> T.Text -> Handle -> IO Expr +putTextFile fileName msg h = do + canWrite <- hIsWritable h + if canWrite + then (TIO.hPutStr h msg) >> (return $ Tape msg) + else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName] + +binopFold :: Binary -> Expr -> [Expr] -> Eval Expr +binopFold op farg args = case args of + []-> throw $ NumArgs 2 args + [a,b] -> op a b + _ -> foldM op farg args + +numBool :: (Integer -> Bool) -> Expr -> Eval Expr +numBool op (Numb x) = return $ Bool $ op x +numBool _ x = throw $ TypeMismatch "numeric op " x + +numOp :: (Integer -> Integer -> Integer) -> Expr -> Expr -> Eval Expr +numOp op (Numb x) (Numb y) = return $ Numb $ op x y +numOp _ Nil (Numb y) = return $ Numb y +numOp _ (Numb x) Nil = return $ Numb x +numOp _ x (Numb _) = throw $ TypeMismatch "numeric op" x +numOp _ (Numb _) y = throw $ TypeMismatch "numeric op" y +numOp _ x _ = throw $ TypeMismatch "numeric op" x + +strOp :: (T.Text -> T.Text -> T.Text) -> Expr -> Expr -> Eval Expr +strOp op (Tape x) (Tape y) = return $ Tape $ op x y +strOp _ Nil (Tape y) = return $ Tape y +strOp _ (Tape x) Nil = return $ Tape x +strOp _ x (Tape _) = throw $ TypeMismatch "string op" x +strOp _ (Tape _) y = throw $ TypeMismatch "string op" y +strOp _ x _ = throw $ TypeMismatch "string op" x + +eqOp :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Expr +eqOp op (Bool x) (Bool y) = return $ Bool $ op x y +eqOp _ x (Bool _) = throw $ TypeMismatch "bool op" x +eqOp _ (Bool _) y = throw $ TypeMismatch "bool op" y +eqOp _ x _ = throw $ TypeMismatch "bool op" x + +numCmp :: (Integer -> Integer -> Bool) -> Expr -> Expr -> Eval Expr +numCmp op (Numb x) (Numb y) = return . Bool $ op x y +numCmp _ x (Numb _) = throw $ TypeMismatch "numeric op" x +numCmp _ (Numb _) y = throw $ TypeMismatch "numeric op" y +numCmp _ x _ = throw $ TypeMismatch "numeric op" x + +notOp :: Expr -> Eval Expr +notOp (Bool True) = return $ Bool False +notOp (Bool False) = return $ Bool True +notOp x = throw $ TypeMismatch " not expects Bool" x + +eqCmd :: Expr -> Expr -> Eval Expr +eqCmd (Atom x) (Atom y) = return . Bool $ x == y +eqCmd (Numb x) (Numb y) = return . Bool $ x == y +eqCmd (Tape x) (Tape y) = return . Bool $ x == y +eqCmd (Bool x) (Bool y) = return . Bool $ x == y +eqCmd Nil Nil = return $ Bool True +eqCmd _ _ = return $ Bool False + +cons :: [Expr] -> Eval Expr +cons [x,(List ys)] = return $ List $ x:ys +cons [x,y] = return $ List [x,y] +cons _ = throw $ ExpectedList "cons, in second argument" + +car :: [Expr] -> Eval Expr +car [List [] ] = return Nil +car [List (x:_)] = return x +car [] = return Nil +car _ = throw $ ExpectedList "car" + +cdr :: [Expr] -> Eval Expr +cdr [List (_:xs)] = return $ List xs +cdr [List []] = return Nil +cdr [] = return Nil +cdr _ = throw $ ExpectedList "cdr" + +quote :: [Expr] -> Eval Expr +quote [List xs] = return $ List $ Atom "quote" : xs +quote [expr] = return $ List $ Atom "quote" : [expr] +quote args = throw $ NumArgs 1 args diff --git a/Biz/Language/Bs/Repl.hs b/Biz/Language/Bs/Repl.hs new file mode 100644 index 0000000..64ffaa2 --- /dev/null +++ b/Biz/Language/Bs/Repl.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Language.Bs.Repl ( +mainLoop +) where + +import Control.Monad.Trans +import Data.String +import Data.Text as T +import Language.Bs.Eval +import Protolude +import System.Console.Haskeline + +type Repl a = InputT IO a + +mainLoop :: IO () +mainLoop = runInputT defaultSettings repl + +repl :: Repl () +repl = do + minput <- getInputLine "bs> " + case minput of + Nothing -> outputStrLn "bye." + Just input -> (liftIO $ process input) >> repl + --Just input -> (liftIO $ processToAST input) >> repl + +process :: String -> IO () +process str = do + res <- safeExec $ evalText $ T.pack str + either putStrLn return res + +processToAST :: String -> IO () +processToAST str = print $ runParseTest $ T.pack str diff --git a/Biz/Language/Bs/Test.hs b/Biz/Language/Bs/Test.hs new file mode 100644 index 0000000..4a40036 --- /dev/null +++ b/Biz/Language/Bs/Test.hs @@ -0,0 +1,2 @@ +-- TODO +module Language.Bs.Test where diff --git a/Biz/Serval.scm b/Biz/Serval.scm new file mode 100644 index 0000000..87cc238 --- /dev/null +++ b/Biz/Serval.scm @@ -0,0 +1,194 @@ +;; +;; Serval - fast container management +;; +;; `Container management' simply refers to tracking the configuration +;; for individual containers and their running state. +;; +;; Serval stores container configuration in a directory, which forms the +;; database. Each container is associated with a `.kit' file, which is a +;; serialized s-expr of a `@Kit' record type. +;; +;; Runtime state is offloaded to systemd, and certain commands simply +;; reach out to `systemctl' and `machinectl' for this functionality. +;; +;; Serval does not concern itself with deployment. For that, use `nix copy'. +;; +;; Currently Serval only supports a single physical machine: if we want +;; to cluster containers across machines, we must find a way to store +;; and reason about the host in addition to the container. This might +;; mean absorbing some functionality that systemd currently performs for +;; us. +;; +;; FILES +;; +;; /var/lib/serval/.kit - kit state (serialized s-expr) +;; /var/lib/serval// - root directory for the kit +;; /nix/var/nix/profiles/per-kit/ - symlink to cfg in /nix/store +;; +;; TODO +;; - save-kit function (write kit to /var/lib/serval/.kit) +;; - profiles in /nix/var/nix/profiles/per-kit +;; - each of the below commented functions for state manipulation +;; +(define-module (Biz Serval) + #:use-module ((ice-9 getopt-long)) + #:use-module ((ice-9 match) + #:select (match)) + #:use-module ((srfi srfi-9) + #:select (define-record-type)) + #:use-module ((Alpha Core) + #:select (second rest fmt prn first comment nil)) + #:use-module ((Alpha Test) + #:select (testing)) + #:use-module ((Alpha Shell) #:prefix Shell.) + #:export (main)) + +(define *data-dir* "/var/lib/serval") +(define *nix-profiles-dir* "/nix/var/nix/profiles") + +;; TODO: I would really like a better command line parser... +;; getopt-long sucks +(define (main args) + ;; pop first arg if its the executable + (let* ([args (if (equal? (first args) "Biz/Serval.scm") + (rest args) + args)] + [cmd (first args)]) + (match cmd + ["new" (new-kit! args)] + ["del" (del-kit! args)] + ["start" (start-kit! args)] + ["stop" (stop-kit! args)] + ["scale" (prn "TODO: scale running kits")] + ["ssh" (run-in-kit! args)] + ["info" (prn "TODO: show kit")] + ["ls" ("TODO: list available kits")] + [else (prn "help")]))) + +(define-record-type @Kit + (Kit name nix-path system-path host-address + host-port local-address auto-start) + kit? + ;; a unique name for this kit + (name kit-name) + ;; location in the nix store + (nix-path get-nix-path set-nix-path!) + ;; this is like /etc/nixos/conf.nix in NixOS proper. At + ;; initialization, this is just `/var/lib/serval/$kit'. Afterwards, + ;; it's `/nix/var/nix/profiles/per-kit/$kit'. + (system-path get-system-path set-system-path!) + ;; host IP + (host-address get-host-address set-host-address!) + ;; host port + (host-port get-host-port set-host-port!) + ;; the private IP + (local-address get-local-address set-local-address!) + ;; should this kit start when the host starts? + (auto-start get-auto-start set-auto-start!)) + +(define-syntax for + (syntax-rules () + ((_ a b) (map b a)) + ((_ a ... b) (map b a ...)))) + +(define (zip a b) + "Combine a and b into a single list of pairs." + ;; TODO: zip-list, zip-with, in Core + (apply map cons (list a b))) + +(define (serialize kit) + "Turns a kit into an association list." + (let* ((fields (record-type-fields @Kit)) + (values (for fields + (lambda (field) ((record-accessor @Kit field) kit))))) + (zip fields values))) + +(define (deserialize alist) + "Creates a @Kit from an association list." + (apply Kit (map rest alist))) + +(define (save-kit! kit) + (call-with-output-file (fmt "~a/~a.kit" *data-dir* (kit-name kit)) + (lambda (a) (write (serialize kit) a)))) + +(define (load-kit! kit-name) + (call-with-input-file (fmt "~a/~a.kit" *data-dir* kit-name) + (lambda (a) (deserialize (read a))))) + +;; TODO +(define (find-available-address) + "10.233.0.1") + +;; top-level commands, each take an argstr + +(define (setup!) + "Initial setup, only need to run once." + (Shell.exec (fmt "mkdir -p ~a" *nix-profiles-dir*)) + (Shell.exec (fmt "mkdir -p ~a" *data-dir*))) + +(define (new-kit! args) + "Creates a new kit: +1. first arg is name +2. second arg is nix-path +3. rest args parsed by getopt-long + +TODO: ensure kit-name is unique +" + (let* ([name (first args)] + [nix-path (second args)] + [option-spec '((auto-start (single-char #\a) (value #f)))] + [options (getopt-long args option-spec)] + [auto-start (option-ref options 'auto-start #f)] + [local-address (find-available-address)] + [kit (Kit name nix-path "fixme-system-path" "fixme-host-address" + "fixme-host-port" local-address auto-start)]) + (save-kit! kit) + (prn ;; Shell.exec + (fmt "nix-env -p ~a/per-kit/system --set ~a" + *nix-profiles-dir* (get-system-path kit))) + kit)) + +(define (del-kit! args) + (let ([name (first args)]) + (Shell.exec (fmt "rm ~a/~a" *data-dir* name)))) + +(define (list-kits) + (Shell.exec (fmt "ls ~a" *data-dir*))) + +(define (update-kit! args) + ;; TODO: load kit and update with new config file + (let ([kit nil]) + (Shell.exec + (fmt "nix-env -p ~a/system -I nixos-config=~a -f --set -A system" + *nix-profiles-dir* + (get-system-path nil))))) + +(define (run-in-kit! args) + (let ([kit nil]) + (Shell.exec + (fmt "systemd-run --machine ~a --pty --quiet -- ~{~a~}" + (kit-name kit) args)))) + +(define (is-kit-running? kit) + (Shell.exec + (fmt "systemctl show kit@~a" (kit-name kit)))) + +(define (start-kit! kit) + (Shell.exec + (fmt "systemctl start kit@~a" (kit-name kit)))) + +(define (stop-kit! kit) + (let* ([force-stop #f] + [cmd (if force-stop + (fmt "machinectl terminate ~a" (kit-name kit)) + (fmt "systemctl stop kit@~a" (kit-name kit)))]) + (Shell.exec cmd))) + +(define (restart-kit! kit) + (stop-kit! kit) + (start-kit! kit)) + +(define (get-leader kit) + "Return the PID of the init process of the kit." + (Shell.exec + (fmt "machinectl show ~a -p Leader" (kit-name kit)))) diff --git a/Biz/buildOS.nix b/Biz/buildOS.nix new file mode 100644 index 0000000..9e6c2f2 --- /dev/null +++ b/Biz/buildOS.nix @@ -0,0 +1,56 @@ +nixos: +{ ipAddress ? null +, enableVpn ? false +, vpnConnectTo ? "" +, vpnRsaPrivateKeyFile ? null +, vpnEd25519PrivateKeyFile ? null +, deps ? {} # an attrset overlayed to pkgs +, configuration # see: configuration.nix(5) +}: +# assert enableVpn -> builtins.isString ipAddress; +# assert enableVpn -> builtins.isString vpnRsaPrivateKeyFile; +# assert enableVpn -> builtins.isString vpnEd25519PrivateKeyFile; +let + vpnExtraConfig = if enableVpn then '' + ConnectTo = ${vpnConnectTo} + Ed25519PrivateKeyFile = "${vpnEd25519PrivateKeyFile}" + PrivateKeyFile = "${vpnRsaPrivateKeyFile}" + '' else ""; + overlay = self: super: deps; + defaults = { + boot.cleanTmpDir = true; + #networking.interfaces.simatime-vpn = [{ ipv4.address = ipAddress; }]; + networking.firewall.allowPing = true; + nix.binaryCaches = [ "https://cache.nixos.org" ]; + nix.gc.automatic = true; + nix.gc.dates = "Sunday 02:15"; + nix.maxJobs = 1; # "auto"; + nix.optimise.automatic = true; + nix.optimise.dates = [ "Sunday 02:30" ]; + nixpkgs.overlays = [ overlay ]; + programs.mosh.enable = true; + programs.mosh.withUtempter = true; + security.acme.email = "ben@bsima.me"; + security.acme.acceptTerms = true; + security.sudo.wheelNeedsPassword = false; + services.clamav.daemon.enable = true; # security + services.clamav.updater.enable = true; # security + services.fail2ban.enable = true; # security + services.openssh.enable = true; + services.openssh.openFirewall = true; + services.openssh.forwardX11 = true; + services.openssh.passwordAuthentication = false; + #services.tinc.networks.simatime-vpn.extraConfig = vpnExtraConfig; + #services.tinc.networks.simatime-vpn.debugLevel = 3; + #services.tinc.networks.simatime-vpn.interfaceType = "tap"; + #services.tinc.networks.simatime-vpn.hosts = import ./vpnHosts.nix; + system.autoUpgrade.enable = false; # 'true' breaks our nixpkgs pin + }; + os = nixos { + system = "x86_64-linux"; + configuration = (defaults // configuration); + }; +in { + system = os.system; + vm = os.vm; +} diff --git a/Biz/fathom.nix b/Biz/fathom.nix new file mode 100644 index 0000000..40e8b0b --- /dev/null +++ b/Biz/fathom.nix @@ -0,0 +1,109 @@ +{ options +, lib +, config +, pkgs +, modulesPath +, stdenv +}: + +with lib; + +let + cfg = config.services.fathom + pkgs.fathom = stdenv.mkDerivation rec { + name = "fathom-v${version}"; + version = "1.2.1"; + src = builtins.fetchurl { + url = "https://github.com/usefathom/fathom/releases/download/v${version}/fathom_${version}_linux_amd64.tar.gz"; + sha256 = "0sfpxh2xrvz992k0ynib57zzpcr0ikga60552i14m13wppw836nh"; + }; + sourceRoot = "."; + dontBuild = true; + installPhase = '' + mkdir -p $out/bin + cp fathom $out/bin + cp LICENSE $out + cp README.md $out + ''; + }; +in { + options.services.fathom = { + enable = lib.mkEnableOption "Enable the Fathom Analytics service"; + + port = mkOption { + type = types.string; + default = "3000"; + description = '' + The port on which Fathom will listen for + incoming HTTP traffic. + ''; + }; + + gzip = mkOption { + type = types.bool; + default = true; + description = "Whether or not to enable gzip compression."; + }; + + debug = mkOption { + type = types.bool; + default = false; + description = "Whether or not to enable debug mode."; + }; + + dataDir = mkOption { + type = types.path; + default = "/var/lib/fathom"; + description = "Fathom data directory"; + }; + }; + + config = mkIf cfg.enable { + systemd.services.fathom = { + wantedBy = [ "multi-user.target" ]; + after = [ "network.target" ]; + + environment = { + FATHOM_SERVER_ADDR = cfg.port; + FATHOM_GZIP = builtins.toString cfg.gzip; + FATHOM_DEBUG = builtins.toString cfg.debug; + FATHOM_DATABASE_DRIVER = "sqlite3"; + FATHOM_DATABASE_NAME = "${cfg.dataDir}/fathom.db"; + FATHOM_SECRET = "random-secret-string"; + }; + preStart = '' + echo "[fathom] creating ${cfg.dataDir}" + mkdir -p ${cfg.dataDir} + chown -R fathom:fathom ${cfg.dataDir} + echo "[fathom]" creating ${cfg.dataDir}/.env + env | grep "^FATHOM" > ${cfg.dataDir}/.env + ''; + description = '' + Fathom Analytics + ''; + + serviceConfig = { + Type = "simple"; + User = "fathom"; + Group = "fathom"; + ExecStart = "${pkgs.fathom}/bin/fathom server"; + KillSignal = "INT"; + WorkingDirectory = cfg.dataDir; + Restart = "on-failure"; + RestartSec = "10"; + PermissionsStartOnly = "true"; + }; + }; + + environment.systemPackages = [ pkgs.fathom ]; + + users = { + groups = { fathom = {}; }; + users.fathom = { + description = "Fathom daemon user"; + home = cfg.dataDir; + group = "fathom"; + }; + }; + }; +} diff --git a/Biz/firefox.nix b/Biz/firefox.nix new file mode 100644 index 0000000..12316fb --- /dev/null +++ b/Biz/firefox.nix @@ -0,0 +1,12 @@ +{ ... }: + +{ + services = { + firefox.syncserver = { + enable = true; + allowNewUsers = true; + listen.port = 5001; + publicUri = "http://firefoxsync.simatime.com"; + }; + }; +} diff --git a/Biz/idea/duree-pitch.org b/Biz/idea/duree-pitch.org new file mode 100644 index 0000000..d4d9d6f --- /dev/null +++ b/Biz/idea/duree-pitch.org @@ -0,0 +1,80 @@ +#+TITLE: Duree: automated universal database +#+SUBTITLE: seeking pre-seed funding +#+AUTHOR: Ben Sima +#+EMAIL: ben@bsima.me +#+OPTIONS: H:1 num:nil toc:nil +#+LATEX_CLASS: article +#+LATEX_CLASS_OPTIONS: +#+LATEX_HEADER: +#+LATEX_HEADER_EXTRA: +#+LATEX_COMPILER: pdflatex +#+DATE: \today +#+startup: beamer +#+LaTeX_CLASS: beamer +#+LaTeX_CLASS_OPTIONS: [presentation,smaller] +Start with this: + - https://news.ycombinator.com/item?id=14605 + - https://news.ycombinator.com/item?id=14754 +Then build AI layers on top. +* Problem +Developers spend too much time managing database schemas. Every database +migration is a risk to the business because of the high possibility of data +corruption. If the data is modeled incorrectly at the beginning, it requires a +lot of work (months of developer time) to gut the system and re-architect it. +* Solution +- Using machine learning and AI, we automatically detect the schema of your data. +- Data can be dumped into a noSQL database withouth the developer thinking much + about structure, then we infer the structure automatically. +- We can also generate a library of queries and provide an auto-generated client + in the choosen language of our users. +* Existing solutions +- Libraries like alembic and migra (Python) make data migrations easier, but + don't help you make queries or properly model data. +- ORMs help with queries but don't give you much insight into the deep structure + of your data (you still have to do manual joins) and don't help you properly + model data. +- Graph QL is the closest competitor, but requires manually writing types and + knowing about the deep structure of your data. We automate both. + +* Unsolved problems +- Unsure whether to build this on top of existing noSQL databases, or to develop + our own data store. Could re-use an existing [[https://en.wikipedia.org/wiki/Category:Database_engines][database engine]] to provide an + end-to-end database solution. +* Key metrics +- How much time do developers spend dealing with database migrations? What does + this cost the business? We can decrease this, decreasing costs. +- How costly are failed data migrations and backups? We reduce this risk. +* Unique value proposition +We can automate the backend data mangling for 90% of software applications. +* Unfair advantage +- I have domain expertise, having worked on similar schemaless database problems + before. +- First-mover advantage in this space. Everyone else is focused on making + database migrations easier, we want to make them obsolete. +* Channels +- Cold calling mongoDB et al users. +* Customer segments +- *Early adopters:* users of mongoDB and graphQL who want to spend time writing + application code, not managing database schemas. The MVP would be to generate + the Graph QL code from their Mongo database automatically. +- Will expand support to other databases one by one. The tech could be used on + any database... or we expand by offering our own data store. +* Cost structure +** Fixed costs + - Initial development will take about 3 months (~$30k) + - Each new database support will take a month or two of development. +** Variable costs + - Initial analysis will be compute-heavy. + - Following analyses can be computationally cheap by buildiing off of the + existing model. + - Customer acquisition could be expensive, will likely hire a small sales + team. +* Revenue streams +- $100 per month per database analyzed + - our hosted service connects to their database directly + - includes client libraries via graphQL + - may increase this if it turns out we save companies a lot more than $100/mo, + which is likely +- enterprise licenses available for on-prem + - allows them to have complete control over their database access + - necessary for HIPAA/PCI compliance diff --git a/Biz/idea/flash.org b/Biz/idea/flash.org new file mode 100644 index 0000000..1c392f0 --- /dev/null +++ b/Biz/idea/flash.org @@ -0,0 +1,36 @@ +#+title: Flash +#+description: a system for quickly testing business ideas + +- Each marketing iteration for a product requires some gear. A "gear" pack is just a yaml + file with all data for a single flash test. It will include ad content, + pricing info, links to necessary images, and so on. + - even better: store these in a database? Depends on how often we need to edit them... +- Data gets marshalled into a bunch of templates, one for each sales pipeline in + the /Traction/ book by Gabriel Weinberg (7 pipelines total) +- Each sales pipeline will have a number of integrations, we'll need at least + one for each pipeline before going to production. E.g.: + - google adwords + - facebook ads + - email lists (sendgrid) + - simple marketing website + - producthunt + - etc +- Pipelines will need to capture metrics on a pre-set schedule. + - Above integrations must also pull performance numbers from Adwords etc APIs. + - Will need some kind of scheduled job queue or robot background worker to handle this. + - A simple dashboard might also be useful, not sure. +- Metrics determine the performance of a pipeline. After the defined trial + duration, some pipelines will be dropped. The high-performing pipelines we + double-down on. +- Metrics to watch: + - conversion rate + - usage time - minutes spent on site/app + - money spent per customer + - see baremetrics for more ideas +- This can eventually be integrated to a larger product design platform (what Sam + Altman calls a "product improvement engine" in his playbook - PIE?). + - metric improvement can be plotted on a relative scale + - "If you improve your product 5% every week, it will really compound." - Sam + - PIE will differ from Flash in that Flash is only for the early stages of a + product - sell it before you build it. PIE will operate on existing products + to make them better. diff --git a/Biz/keys/ben.pub b/Biz/keys/ben.pub new file mode 100644 index 0000000..c661508 --- /dev/null +++ b/Biz/keys/ben.pub @@ -0,0 +1 @@ +ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAACAQDDhmSEbvX6LSk1ZO/whhAWpxwUxGPwbn7ZKVmxLcIilLdkd/vhFQKSYyMBW+21G3cMbwyFVsCyPbADoXcvV5OSIklxgitP77/2TAgkEPjyklJ4KD0QNDjpu+YGGIyVTgE9YPBhpwuUlxRhux15vN8xzAXq4f5/xpyBPekIdbEaEUZHrKN/z9g8cgw9ZMWSrchbsE3QlU8MJK78HO+v3TjH7Ip+LffWNuhckiYnzT8Duy47vgc1OYqtJaDMN/ufK7yeNILK81M1ybHGOlqYxSfV/RM7oD0P5w5YeTXMpRsOyn4YVzhWSQFrlf08XbwlZUNm6Pb8eNRjM+3YyFTcUU/S81xKwOPRNNhlPnxz+tUltCR3H/0Falu1pxJYT2qfuM9j9z9xA1bJEsSSZ1b2bsHw7ujpRmg0xsPUk7DXIQ1Kh92BFfmDoZWeqsMF1E7H8iuaVsN9k96BwbBfiB4stQqI3ycuHO9zbsa12y8AQusDbr9W8rl/vR0pKNrcNO32ojOzkblJGWgyNxDvTS4l69+qi6pMBONicUUMQnXEtJoasjpECzwlAHIYJMmFQUuloEafR8b0ZAaCw+I5SfsyYF4hHLYseHvMavxgLNZ6W4ZlaL9XmQ7ZGhh10ub4ceW61QvCzKD34yO1yl8PcmS8Fa7bZbGxkq36oCusGbD65AlY+w== ben@lithium diff --git a/Biz/keys/deploy.pub b/Biz/keys/deploy.pub new file mode 100644 index 0000000..664a2d9 --- /dev/null +++ b/Biz/keys/deploy.pub @@ -0,0 +1 @@ +ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAACAQDlLRbbXgwjF7IqObf4dZE/jj0HoT6xJR6bP/6ZrJz7NPCPIgY3GacOtBfkJp6KK0zKQdFmxNpcfb3zgpe/Ru7pkmSfI9IoWAU3aLPWK2G3tbLPmktGmF9C53OhyXgFtBGr2Q/+wSRKAfN/FrEEa2FuRBtvtcAMiwbQLbFCzlmWhE7swSBvg38ZSFrjhANsEhfNVCtsrtG16fkfrfmBFv4JIog1fEoMKmXg7rhMjpaas8+n52HMFXvjllePRpywK4wB20GOcOuDSdc3i3zs7NFuicGunEpW2S/byrHotSWHZ9VuUwPn3GJ6xorrGyvsRuPS2anhHTSBxYCqYdXg0BIYUn1x5Uhtzd8kIU06gSLsvuhqGCLNucnXAT1Zix7pSlO21be81SX4vwQEth+6Dkm6kja0ArHZL6wglF8Njd1fV9iOwvcS07clwa/2S8suFLwVrQXz16vfAfA2zi4/qeop5Sv9W4DIOZuIMPmbWZCoy7L6Fu4+x4prb8LCQNM5m4CP3HngCW8PpxtBbBJd0dcXVap1HgDTIt/CLH8ms52uX5k3bHuvzryOihSuwmi/cDZAJAmbgclM9klsZr4R/GAoAWhhGxXM2tLuiwZ2nLvCPlXbBazZpdM2aC3VIwnMwJrJFu2u9B6RSsz2ijbygecT98UmiMYK7Mk1y6GkvY+mDQ== ben@lithium diff --git a/Biz/keys/nick.pub b/Biz/keys/nick.pub new file mode 100644 index 0000000..4dc08fb --- /dev/null +++ b/Biz/keys/nick.pub @@ -0,0 +1 @@ +ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAACAQDfSOxXJTQADjROqbaiJtjbJaHTsBtuWNvQpDvXLigl9R27VqIn7dYk2STuWglwFyrvYfU1UmjgJcJ6J2KbXGTH5mhaC04MJ4aqmOR3Ynnq7nDzmtEtn1I+K7LmpFXsFXgOTzIlzggIWflGd1pPBwgWqMoPDcSqNQFPI/+rk1JOxk3e2Mq60VTp9WM9hs0AJQEyZ+wwZ0vyrj588kQb6jQUZ7qx1UZoDzPc57zREEZbQeU1Gd9FK2bCHlKOBHYlqIftSRBGGCpuo7zobhajR0xHO9RnF0NmeLbW85XhDus8vVgBg/BTDPxHEzm5jKiCkc+i3ia0Ff9mp2zgtSdXCp5jbVZ3AYfYLi1zbPWmaSdWqFx2ntOLwWR3/RHjw6+b4KmUQ4xtQHyXOijTBCH29i7VCo7l8WL+I2mSGJ7/Wtw7NFtMpVVs8/0iKt2t12FIefzvbZoWU7vbmuO7+gQI5l+F+JE6DLWOl04vT/V98WxiHA5rbCjTT/bubs4gTeCR9qNehaoM+apitpUP8HXygnxD7EJeK6JNkdub9TY663IkiKlpnWgeoDTNSP7JF/jkU0Nt8yoR2pTyxQqMFYa37/3WKjmSHk1TgxLEmlwHQFtIkTPn8PL+VLa4ACYuWUjxS4aMRpxo9eJUHdy0Y04yKxXN8BLw7FAhytm2pTXtT4zqaQ== nicksima@gmail.com diff --git a/Biz/packages.nix b/Biz/packages.nix new file mode 100644 index 0000000..4ffbbf8 --- /dev/null +++ b/Biz/packages.nix @@ -0,0 +1,18 @@ +{ pkgs, ... }: + +with pkgs; + +{ + environment.systemPackages = [ + file + gitAndTools.gitFull + htop + python3 + ranger + telnet + tinc_pre + traceroute + vnstat + wget + ]; +} diff --git a/Biz/users.nix b/Biz/users.nix new file mode 100644 index 0000000..b52043e --- /dev/null +++ b/Biz/users.nix @@ -0,0 +1,39 @@ +{ config, ... }: + +{ + users.motd = '' + + welcome to the simatime network! + your host is '${config.networking.hostName}' + + ''; + users.mutableUsers = false; + users.users = { # + # bots + # + deploy = { + isNormalUser = true; + home = "/home/deploy"; + openssh.authorizedKeys.keyFiles = [ ./keys/deploy.pub ]; + extraGroups = [ "wheel" ]; + }; + # + # humans + # + root.openssh.authorizedKeys.keyFiles = [ ./keys/ben.pub ]; + ben = { + description = "Ben Sima"; + isNormalUser = true; + home = "/home/ben"; + openssh.authorizedKeys.keyFiles = [ ./keys/ben.pub ]; + extraGroups = [ "wheel" "networkmanager" "docker" ]; + }; + nick = { + description = "Nick Sima"; + isNormalUser = true; + home = "/home/nick"; + openssh.authorizedKeys.keyFiles = [ ./keys/nick.pub ]; + extraGroups = [ "docker" ]; + }; + }; +} diff --git a/Biz/vpnHosts.nix b/Biz/vpnHosts.nix new file mode 100644 index 0000000..1a66e92 --- /dev/null +++ b/Biz/vpnHosts.nix @@ -0,0 +1,37 @@ +let + mkVpnPeer = { address, subnet, ed25519PublicKey, rsaPublicKey }: '' + Address = ${address} + Subnet = ${subnet} + Ed25519PublicKey = ${ed25519PublicKey} + ${rsaPublicKey} + ''; +in { + "com.simatime" = mkVpnPeer { + address = "159.89.128.69"; + subnet = "10.1.1.25"; + ed25519PublicKey = "TODO"; + rsaPublicKey = '' + TODO + ''; + }; + "com.simatime.dev" = mkVpnPeer { + address = "69.181.254.154"; + subnet = "10.1.1.21"; + ed25519PublicKey = "s5/rbuM7WaYqaZH0BP4/mYefrl3uWfaT+Ew4gmSsh8F"; + rsaPublicKey = '' + -----BEGIN RSA PUBLIC KEY----- + MIICCgKCAgEAydQHK4jUQnp4ZSqIB/fjfLxILqy/IHR6DPiUp/HustFDOaLKSVM8 + 75fVtBybiEkUmXLU3Bg8WX9zR+llTf3za1B13w+uJpcR4FS/LhAN/wgHCdgHUb4W + D7YZzGUnLhPAu3Ivnu5QZ6vzigqtbPCIFfwGDW2RGjq3iJMag1sM/xBOZrSn+zsZ + azCEP/snY30UE5ggrxJSMpZXSpS9u266nTblo8gTwfjdzrC93gmNNIxdHpeYGb0O + VGdaMmExq5Ny4flG2qtWA0u8nDscg7bEVIYfPjZr1G2FT5A0Ma4kteu6TeYpQEd9 + 0if3lRb48iMwh1VBfXBps9Heexz0HjG6EAku2B1mEL5orjmC3jJK0DpuXnwVN5pz + B+UrFnqbFykeHxZD5RdAB1tcuHZlJ/mQyZRQMJtkifFLdj4iBBK+si05GpodGhIz + iXkMYRIOja9/4EyukDdU2i2yEOmgif6DhIh4awss1b2Crtxs2bg6/xi2Hy63IQEy + u8LxuiPGA69NsaFZz49SXXJw11KQt5g7WE0jweYXmT3VO6yZlktGdJjzXyhaw7ma + G9VgHvxh+K/mDZ2SXwDcINzwYwZxxqcxcmA4o8glCKQyVHIT5hlo7QkSzK4P+GgN + Js+sRDreM6Rha2zcOaJWZ5IO2Xva6AZZ29oO5m4V/CYPCuMAzXwV2GMCAwEAAQ== + -----END RSA PUBLIC KEY----- + ''; + }; +} diff --git a/Com/InfluencedByBooks/Client.hs b/Com/InfluencedByBooks/Client.hs deleted file mode 100644 index 8c70a04..0000000 --- a/Com/InfluencedByBooks/Client.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Front-end --- --- : exe ibb.js --- --- : dep clay --- : dep miso --- : dep protolude --- : dep servant --- : dep text --- : dep aeson --- : dep containers --- : dep ghcjs-base -module Com.InfluencedByBooks.Client where - -import Alpha -import Com.InfluencedByBooks.Core ( Action(..) - , see - , init - ) -import Com.InfluencedByBooks.Move ( move ) -import Miso ( App(..) - , defaultEvents - , miso - ) - -main :: IO () -main = miso $ \u -> App { model = init u, .. } - where - initialAction = FetchPeople - update = move - view = see - events = defaultEvents - subs = [] - mountPoint = Nothing diff --git a/Com/InfluencedByBooks/Core.hs b/Com/InfluencedByBooks/Core.hs deleted file mode 100644 index 2b98914..0000000 --- a/Com/InfluencedByBooks/Core.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Main app logic -module Com.InfluencedByBooks.Core where - -import Alpha -import Com.Simatime.Network -import Data.Aeson hiding ( Success ) -import Data.Data ( Data - , Typeable - ) -import Data.Text ( Text ) -import GHC.Generics ( Generic ) -import Miso -import Miso.String -import Servant.API -import Servant.Links - --- * entity data types - -data Person = Person - { _name :: Text - -- ^ Their full name. - , _pic :: Text - -- ^ A link to their picture. - , _twitter :: Text - -- ^ Their twitter handle, without the `@` prefix. - , _website :: Text - -- ^ Their main website, fully formed: `https://example.com` - , _books :: [Book] - -- ^ A short list of the books they recommend. - , _blurb :: Text - -- ^ A short "about" section, like you would see on the jacket flap of a book. - } deriving (Generic, Show, Eq, Typeable, Data, Ord) - -instance FromJSON Person -instance ToJSON Person - -data Book = Book - { _title :: Text - , _author :: Text - , _amznref :: Text - -- ^ Amazon REF number, for creating affiliate links. - } deriving (Generic, Show, Eq, Typeable, Data, Ord) - -instance FromJSON Book -instance ToJSON Book - --- * app data types - -type AppRoutes = Home - -type Home = View Action - -data Model = Model - { uri :: URI - , people :: WebData [Person] - } deriving (Show, Eq) - -type WebData a = RemoteData MisoString a - -init :: URI -> Model -init u = Model u Loading - -data Action - = Nop - | ChangeRoute URI - | HandleRoute URI - | FetchPeople - | SetPeople (WebData [Person]) - deriving (Show, Eq) - -home :: Model -> View Action -home m = see m - -handlers :: Model -> View Action -handlers = home - -notfound :: View Action -notfound = div_ [] [text "404"] - -goHome :: URI -goHome = linkURI $ safeLink (Proxy :: Proxy AppRoutes) (Proxy :: Proxy Home) - -see :: Model -> View Action -see m = div_ - [class_ "container mt-5"] - [ div_ - [class_ "jumbotron"] - [ h1_ [class_ "display-4"] [text "Influenced by books"] - , p_ [class_ "lead"] - [text "Influential people and the books that made them."] - , p_ - [class_ "lead"] - [ a_ - [href_ "http://eepurl.com/ghBFjv"] - [ text - "Get new book recommendations from the world's influencers in your email." - ] - ] - ] - , div_ [class_ "card-columns"] $ case people m of - NotAsked -> [text "Initializing..."] - Loading -> [text "Loading..."] - Failure err -> [text err] - Success ps -> seePerson View Action -seePerson person = div_ - [class_ "card"] - [ div_ [class_ "card-img"] - [img_ [class_ "card-img img-fluid", src_ $ ms $ _pic person]] - , div_ - [class_ "card-body"] - [ h4_ [class_ "card-title"] [text $ ms $ _name person] - , h6_ - [] - [ a_ - [ class_ "fab fa-twitter" - , href_ $ "https://twitter.com/" <> (ms $ _twitter person) - ] - [] - , a_ [class_ "fas fa-globe", href_ $ ms $ _website person] [] - ] - , p_ [class_ "card-text"] - [text $ ms $ _blurb person, ul_ [] $ seeBook View Action -seeBook book = li_ - [] - [ a_ - [ class_ "text-dark" - , href_ $ "https://www.amazon.com/dp/" <> (ms $ _amznref book) - ] - [text $ ms $ _title book] - ] diff --git a/Com/InfluencedByBooks/Influencers.hs b/Com/InfluencedByBooks/Influencers.hs deleted file mode 100644 index 2583770..0000000 --- a/Com/InfluencedByBooks/Influencers.hs +++ /dev/null @@ -1,407 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module Com.InfluencedByBooks.Influencers where - -import Com.InfluencedByBooks.Core - -allPeople :: [Person] -allPeople = - [ Person { _name = "Joe Rogan" - , _pic = "https://pbs.twimg.com/profile_images/552307347851210752/vrXDcTFC_400x400.jpeg" - , _twitter = "joerogan" - , _blurb = "Stand up comic/mixed martial arts fanatic/psychedelic adventurer Host of The Joe Rogan Experience" - , _website = "http://joerogan.com" - , _books = [ Book {_title = "Food of the Gods" - , _author = "Terence McKenna" - , _amznref = "0553371304" - } - , Book { _title = "The War of Art" - , _author ="Steven Pressfield" - , _amznref ="B007A4SDCG" - } - ] - } - , Person { _name = "Beyoncé" - , _pic = "https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcTxT84sF19lxdnSiblIXAp-Y4wAigpQn8sZ2GtAerIR_ApiiEJfFQ" - , _twitter = "Beyonce" - , _blurb = "American singer, songwriter, actress, record producer and dancer" - , _website = "http://beyonce.com" - , _books = [ Book { _title = "What Will It Take To Make A Woman President?" - , _author = "Marianne Schnall" - , _amznref = "B00E257Y7G"} - ] - } - , Person { _name = "Barrack Obama" - , _pic = "https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcQeLzftR36p0hYI-EKNa5fm7CYDuN-vyz23_R48ocqa8X1nPr6C" - , _twitter = "BarackObama" - , _blurb = "Dad, husband, President, citizen. 44th POTUS" - , _website = "http://barackobama.com" - , _books = [ Book { _title = "An American Marriage" - , _author = "Tayari Jones" - , _amznref = "B01NCUXEFR"} - , Book { _title = "Americanah" - , _author = "Chimamanda Ngozi Adichie" - , _amznref = "B00A9ET4MC"} - ] - } - , Person { _name = "Warren Buffet" - , _pic = "https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcQQbmnUykS6zqgzaf44tsq1RAsnHe6H7fapEoSqUwAoJGSFKbAPSw" - , _twitter = "WarrenBuffett" - , _blurb = "Chairman and CEO of Berkshire Hathaway" - , _website = "http://berkshirehathaway.com" - , _books = [ Book { _title = "The Intelligent Investor" - , _author = "Benjamin Graham" - , _amznref = "B000FC12C8"} - , Book { _title = "Security Analysis" - , _author = "Benjamin Graham" - , _amznref = "B0037JO5J8"} - ] - } - , Person { _name = "Bill Gates" - , _pic = "https://pbs.twimg.com/profile_images/988775660163252226/XpgonN0X_400x400.jpg" - , _twitter = "BillGates" - , _blurb = "Sharing things I'm learning through my foundation work and other interests. Founder of Microsoft and Bill & Melinda Gates Foundation" - , _website = "https://www.gatesnotes.com" - , _books = [ Book { _title = "Leonardo da Vinci" - , _author = "Walter Isaacson" - , _amznref = "1501139169" - } - , Book { _title = "Educated" - , _author = "Tara Wetsover" - , _amznref = "B072BLVM83" - } - ] - } - , Person { _name = "Stephen King" - , _pic = "https://pbs.twimg.com/profile_images/378800000836981162/b683f7509ec792c3e481ead332940cdc_400x400.jpeg" - , _twitter = "StephenKing" - , _blurb = "World renowned Author" - , _website = "https://stephenking.com/" - , _books = [ Book { _title = "Red Moon" - , _author = "Benjamin Percy" - , _amznref = "B008TU2592" - } - , Book { _title = "The Marauders" - , _author = "Tom Cooper" - , _amznref = "B00MKZBVTM" - } - ] - } - , Person { _name = "Tobi Lütke" - , _pic = "https://pbs.twimg.com/profile_images/551403375141457920/28EOlhnM_400x400.jpeg" - , _twitter = "tobi" - , _blurb = "Shopify CEO by day, Dad in the evening, hacker at night. - Rails Core alumni; Author of ActiveMerchant, Liquid. Comprehensivist" - , _website = "https://www.shopify.com" - , _books = [ Book { _title = "Influence" - , _author ="Robert B. Cialdini" - , _amznref = "006124189X" - } - , Book { _title = "High Output Management" - , _author ="Andrew S. Grove" - , _amznref = "B015VACHOK" - } - ] - } - , Person { _name = "Susan Cain" - , _pic = "https://pbs.twimg.com/profile_images/1474290079/SusanCain5smaller-1_400x400.jpg" - , _twitter = "susancain" - , _blurb = "Bestselling author, award-winning speaker, http://Quietrev.com curator. Lover of bittersweet music & bittersweet chocolate, in equal measure." - , _website = "https://www.quietrev.com" - , _books = [ Book { _title = "Bird by Bird" - , _author ="Anne Lamott" - , _amznref = "0385480016" - } - , Book { _title = "Waking Up" - , _author ="Sam Harris" - , _amznref = "1451636024" - } - ] - } - , Person { _name = "Oprah Winfrey" - , _pic = "https://pbs.twimg.com/profile_images/1013835283698049025/q5ZN4yv3_400x400.jpg" - , _twitter = "Oprah" - , _blurb = "Oprah Winfrey is an American media executive, actress, talk show host, television producer and philanthropis" - , _website = "http://www.oprah.com/index.html" - , _books = [ Book { _title = "A New Earth" - , _author ="Eckhart Tolle" - , _amznref = "B000PC0S5K" - } - , Book { _title = "The Poisonwood Bible" - , _author ="Barbara Kingsolver" - , _amznref = "B000QTE9WU" - } - ] - } - , Person { _name = "Patrick Collison" - , _pic = "https://pbs.twimg.com/profile_images/825622525342199809/_iAaSUQf_400x400.jpg" - , _twitter = "patrickc" - , _blurb = "Fallibilist, optimist. Stripe CEO" - , _website = "https://patrickcollison.com" - , _books = [ Book { _title = "How Judges Think" - , _author ="Richard A. Posner" - , _amznref = "0674048067" - } - , Book { _title = "Programmers at Work" - , _author ="Susan Lammers" - , _amznref = "1556152116" - } - ] - } - , Person { _name = "Luis Von Ahn" - , _pic = "https://pbs.twimg.com/profile_images/1020343581087678464/NIXD5MdC_400x400.jpg" - , _twitter = "LuisvonAhn" - , _blurb = "CEO & co-founder of duolingo. Invented reCAPTCHA. Computer science professor at Carnegie Mellon. Proud Guatemalan" - , _website = "https://www.duolingo.com/" - , _books = [ Book { _title = "Zero to One" - , _author ="Peter Thiel" - , _amznref = "B00J6YBOFQ" - } - , Book { _title = "The Hard Thing About Hard Things" - , _author ="Ben Horowitz" - , _amznref = "B00DQ845EA" - } - ] - } - , Person { _name = "Bryan Johnson" - , _pic = "https://pbs.twimg.com/profile_images/1055165076372475904/vNp60sSl_400x400.jpg" - , _twitter = "bryan_johnson" - , _blurb = "Founder of Kernel, OS Fund and Braintree. Trying to go where there is no destination" - , _website = "https://bryanjohnson.co" - , _books = [ Book { _title = "A Good Man" - , _author ="Mark Shriver" - , _amznref = "B007CLBH0M" - } - , Book { _title = "Shackleton" - , _author ="Nick Bertozzi" - , _amznref = "1596434511" - } - ] - } - , Person { _name = "Peter Thiel" - , _pic = "https://pbs.twimg.com/profile_images/1121220551/Peter_Thiel_400x400.jpg" - , _twitter = "peterthiel" - , _blurb = "Technology entrepreneur, investor, philanthropist." - , _website = "http://zerotoonebook.com" - , _books = [ Book { _title = "Deceit, Desire, and the Novel" - , _author ="René Girard" - , _amznref = "0801818303" - } - , Book { _title = "Violence and the Sacred" - , _author ="René Girard" - , _amznref = "0801822181" - } - ] - } - , Person { _name = "Tim Ferris" - , _pic = "https://pbs.twimg.com/profile_images/49918572/half-face-ice_400x400.jpg" - , _twitter = "tferriss" - , _blurb = "Author of 5 #1 NYT/WSJ bestsellers, investor (FB, Uber, Twitter, 50+ more: http://angel.co/tim ), host of The Tim Ferriss Show podcast (300M+ downloads)" - , _website = "http://tim.blog" - , _books = [ Book { _title = "10% Happier" - , _author ="Dan Harris" - , _amznref = "0062265431" - } - , Book { _title = "A Guide to the Good Life" - , _author ="William Irvine" - , _amznref = "B0040JHNQG" - } - ] - } - , Person { _name = "Allen Walton" - , _pic = "https://pbs.twimg.com/profile_images/1038905908678545409/yUbF9Ruc_400x400.jpg" - , _twitter = "allenthird" - , _blurb = "Created http://SpyGuy.com and blogs about stuff at http://AllenWalton.com . All things ecommerce, personal dev, and Simpsons." - , _website = "https://www.allenwalton.com" - , _books = [ Book { _title = "4 Hour Work Week" - , _author ="Tim Ferris" - , _amznref = "B002WE46UW" - } - , Book { _title = "Choose Yourself" - , _author ="James Altucher" - , _amznref = "B00CO8D3G4" - } - ] - } - , Person { _name = "Peter Mallouk" - , _pic = "https://pbs.twimg.com/profile_images/713172266968715264/KsyDYghf_400x400.jpg" - , _twitter = "PeterMallouk" - , _blurb = "President of Creative Planning. Author “5 Mistakes Every Investor Makes & How to Avoid Them”. Radically moderate." - , _website = "https://creativeplanning.com" - , _books = [ Book { _title = "Awareness" - , _author ="Anthony de Mello SJ" - , _amznref = "B005GFBP6W" - } - , Book { _title = "The Prophet" - , _author ="Kahlil Gibran" - , _amznref = "B07NDJ3LMW" - } - ] - } - , Person { _name = "Adam Robinson" - , _pic = "https://pbs.twimg.com/profile_images/822708907051077632/y5KyboMV_400x400.jpg" - , _twitter = "IAmAdamRobinson" - , _blurb = "Entrepreneur. Systems builder. Wizard. Shaman of global financial markets. Manifester. Didact. Do-gooder. Alchemist. Aphorist. Seeker. Embracer of possibility." - , _website = "http://robinsonglobalstrategies.com" - , _books = [ Book { _title = "Wishcraft" - , _author ="Barbara Sher" - , _amznref = "0345465180" - } - , Book { _title = "You Can Be a Stock Market Genius" - , _author ="Joel Greenblatt" - , _amznref = "0684832135" - } - ] - } - , Person { _name = "Andrew Weil" - , _pic = "https://pbs.twimg.com/profile_images/987461787422359553/mpoZAmPH_400x400.jpg" - , _twitter = "DrWeil" - , _blurb = "A world-renowned leader and pioneer in the field of integrative medicine, a healing oriented approach to health care which encompasses body, mind, and spirit." - , _website = "https://www.drweil.com" - , _books = [ Book { _title = "The Way Of Life According To Lao Tzu" - , _author = "Witter Byner" - , _amznref = "0399512985" - } - , Book { _title = "The Psychology of Romantic Love" - , _author ="Nathaniel Branden" - , _amznref = "B0012RMVJI" - } - ] - } - , Person { _name = "Hubert Joly" - , _pic = "https://scontent-ort2-2.xx.fbcdn.net/v/t1.0-1/c1.0.193.193a/38444401_2156120597936470_9028564067043770368_n.jpg?_nc_cat=104&_nc_ht=scontent-ort2-2.xx&oh=162142edb167f389a5b585a329e4993a&oe=5CE1D578" - , _twitter = "BBYCEO" - , _blurb = "CEO of Best Buy" - , _website = "https://www.bestbuy.com" - , _books = [ Book { _title = "Who Says Elephants Can't Dance" - , _author = "Louis. V. Gerstner" - , _amznref = "0060523808" - } - , Book { _title = "Onward" - , _author ="Howard Schultz" - , _amznref = "1609613821" - } - ] - } - , Person { _name = "Esther Perel" - , _pic = "https://pbs.twimg.com/profile_images/1091062675151319040/MzxCcgdU_400x400.jpg" - , _twitter = "EstherPerel" - , _blurb = "Exploring modern relationships. Author of MatingInCaptivity and TheStateOfAffairsBook. Podcast: WhereShouldWeBegin. Psychotherapist in NYC." - , _website = "https://www.estherperel.com" - , _books = [ Book { _title = "Crime And Punishment" - , _author = "Fyodor Dostoyevsky" - , _amznref = "B07NL94DFD" - } - , Book { _title = "If This Is a Man and The Truce" - , _author ="Primo Levi" - , _amznref = "0349100136" - } - ] - } - , Person { _name ="Neil deGrasse Tyson" - , _pic = "https://pbs.twimg.com/profile_images/74188698/NeilTysonOriginsA-Crop_400x400.jpg" - , _twitter = "neiltyson" - , _blurb = "Astrophysicistthe. Fifth head since 1935 of the world-renowned Hayden Planetarium in New York City and the first occupant of its Frederick P. Rose Directorship. Research associate of the Department of Astrophysics at the American Museum of Natural History." - , _website = "https://www.haydenplanetarium.org/tyson/" - , _books = [ Book { _title = "The Prince" - , _author = "Machiavelli" - , _amznref = "B07ND3CM16" - } - , Book { _title = "The Art of War" - , _author ="Sun Tzu" - , _amznref = "1545211957" - } - ] - } - , Person { _name = "Mark Cuban" - , _pic = "https://pbs.twimg.com/profile_images/1422637130/mccigartrophy_400x400.jpg" - , _twitter = "mcuban" - , _blurb = "Owner of Dallas Mavericks, Shark on ABC’s Shark Tank, chairman and CEO of AXS tv, and investor in an ever-growing portfolio of businesses" - , _website = "http://markcubancompanies.com/" - , _books = [ Book { _title = "The Fountainhead" - , _author = "Ayn Rend" - , _amznref = "0452273331" - } - , Book { _title = "The Gospel of Wealth " - , _author ="Andrew Carnegie" - , _amznref = "1409942171" - } - ] - } - , Person { _name = "Robert Herjavec" - , _pic = "https://pbs.twimg.com/profile_images/608643660876423170/DgxUW3eZ_400x400.jpg" - , _twitter = "robertherjavec" - , _blurb = "Dad, Husband, Founder & CEO of global cybersecurity firm HerjavecGroup, Shark on ABC’s Shark Tank, Former Dragon, Author" - , _website = "https://www.robertherjavec.com/" - , _books = [ Book { _title = "Why I Run" - , _author = "Mark Sutcliffe" - , _amznref = "B007OC9P3A" - } - , Book { _title = "Swim with the Sharks Without Being Eaten Alive" - , _author ="Harvey B. Mackay" - , _amznref = "006074281X" - } - ] - } - , Person { _name = "Caterina Fake" - , _pic = "https://pbs.twimg.com/profile_images/378800000509318185/d968d62d1bc39f2c82d3fa44db478525_400x400.jpeg" - , _twitter = "Caterina" - , _blurb = "Host, Should this Exist? Investor, Yes VC. Cofounder: Flickr, Hunch, Sesat School. Etsy. Sundance. Homeschooling, film, literature. Dogs." - , _website = "https://caterina.net" - , _books = [ Book { _title = "Growth of the Soil" - , _author = "Knut Hamsun" - , _amznref = "0343181967" - } - , Book { _title = "The Thousand Autumns of Jacob de Zoet" - , _author ="David Mitchell" - , _amznref = "0812976363" - } - ] - } - , Person { _name = "Daymond John" - , _pic = "https://pbs.twimg.com/profile_images/1048022980863954944/eZvGANn0_400x400.jpg" - , _twitter = "TheSharkDaymond" - , _blurb = "CEO of FUBU, Shark on ABC’s Shark Tank, Author." - , _website = "https://daymondjohn.com/" - , _books = [ Book { _title = "Think and Grow Rich" - , _author = "Napoleon Hill" - , _amznref = "1585424331" - } - , Book { _title = "How to Win Friends & Influence People" - , _author ="Dale Carnegie" - , _amznref = "0671027034" - } - ] - } - , Person { _name = "Kevin O'Leary" - , _pic = "https://pbs.twimg.com/profile_images/1067383195597889536/cP6tNEt0_400x400.jpg" - , _twitter = "kevinolearytv" - , _blurb = "Chairman O'Shares ETFs, 4 time Emmy Award winning Shark Tank's Mr. Wonderful, bestselling author, CNBC contributor, wine maker, guitar dude and photographer." - , _website = "http://askmrwonderful.eone.libsynpro.com/" - , _books = [ Book { _title = "Competitive Advantage" - , _author = "Michael Porter" - , _amznref = "0684841460" - } - , Book { _title = "Secrets of Closing the Sale" - , _author ="Zig Ziglar" - , _amznref = "0425081028" - } - ] - } - , Person { _name = "Alex Rodriguez" - , _pic = "https://pbs.twimg.com/profile_images/796405335388848128/LbvsjCA3_400x400.jpg" - , _twitter = "AROD" - , _blurb = "3-time MVP • 14-time All Star • World Series Champ • CEO of @_ARodCorp• @FoxSports Commentator/Analyst • Special Advisor to the Yankees, @ABCSharkTank and ESPN" - , _website = "http://www.arodcorp.com/" - , _books = [ Book { _title = "Blitzscaling" - , _author = "Reid Hoffman" - , _amznref = "1524761419" - } - , Book { _title = "Measure What Matters" - , _author ="John Doerr" - , _amznref = "0525536221" - } - ] - } - ] diff --git a/Com/InfluencedByBooks/Keep.hs b/Com/InfluencedByBooks/Keep.hs deleted file mode 100644 index b84d4d8..0000000 --- a/Com/InfluencedByBooks/Keep.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Keep is a database built on Data.Acid. --- --- If this proves useful, maybe we could make it a more general thing. Like --- `Biz.Keep`. I could wrap all the safecopy stuff in my own template haskell --- like `$(keep ''MyType)`. --- -module Com.InfluencedByBooks.Keep where - -import Com.InfluencedByBooks.Core (Person(..), Book(..)) -import qualified Com.InfluencedByBooks.Influencers as Influencers -import Control.Monad.Reader (ask) -import Control.Monad.State (get, put) -import Data.Acid (Update, makeAcidic) -import qualified Data.Acid as Acid -import Data.Data (Data, Typeable) -import Data.IxSet (Indexable(..), IxSet, ixFun, ixSet) -import qualified Data.IxSet as IxSet -import Data.SafeCopy -import Data.Text (Text) -import qualified Data.Text as Text - --- * Keep - --- | Main database. Need to think of a better name for this. -data IbbKeep = IbbKeep - { _people :: IxSet Person - } - deriving (Data, Typeable) - -$(deriveSafeCopy 0 'base ''IbbKeep) - --- * Index @Person@ - -$(deriveSafeCopy 0 'base ''Person) - -newtype PersonName = - PersonName Text deriving (Eq, Ord, Data, Typeable) - -newtype PersonBlurb = - PersonBlurb Text deriving (Eq, Ord, Data, Typeable) - -instance Indexable Person where - empty = ixSet - [ ixFun $ \p -> [ PersonName $ _name p ] - , ixFun $ \p -> [ _pic p ] - , ixFun $ \p -> [ _twitter p ] - , ixFun $ \p -> [ _website p ] - , ixFun $ \p -> [ _books p ] - , ixFun $ \p -> [ PersonBlurb $ _blurb p ] - ] - --- | updates the `IbbKeep` with a new `Person` -newPerson :: Text -> Text -> Update IbbKeep Person -newPerson name blurb = do - k <- get - put $ k { _people = IxSet.insert p (_people k) - } - return p - where - p = Person - { _name = name - , _pic = Text.empty - , _twitter = Text.empty - , _website = Text.empty - , _books = [] - , _blurb = blurb - } - -getPeople :: Int -> Acid.Query IbbKeep [Person] -getPeople n = do - keep <- ask - return $ take n $ IxSet.toList $ _people keep - --- * Index @Book@ - -$(deriveSafeCopy 0 'base ''Book) - -newtype BookTitle = - BookTitle Text deriving (Eq, Ord, Data, Typeable) - -newtype BookAuthor = - BookAuthor Text deriving (Eq, Ord, Data, Typeable) - -instance Indexable Book where - empty = ixSet - [ ixFun $ \b -> [ BookTitle $ _title b ] - , ixFun $ \b -> [ BookAuthor $ _author b ] - , ixFun $ \b -> [ _amznref b ] - ] - --- | updates the `IbbKeep` with a new `Book` ---newBook :: Text -> Text -> Text -> Update IbbKeep Book ---newBook title author amznref = do --- ibbKeep <- get --- put $ ibbKeep { _books = IxSet.insert b (_books ibbKeep) --- , _people = _people ibbKeep --- } --- return b --- where --- b = Book { _title = title --- , _author = author --- , _amznref = amznref --- } - --- * Opening the keep - --- defines @NewPerson@ for us. -$(makeAcidic ''IbbKeep ['newPerson, 'getPeople]) - -initialIbbKeep :: IbbKeep -initialIbbKeep = IbbKeep - { _people = IxSet.fromList Influencers.allPeople - } - -openLocal :: String -> IO (Acid.AcidState IbbKeep) -openLocal dir = - Acid.openLocalStateFrom dir initialIbbKeep diff --git a/Com/InfluencedByBooks/Look.hs b/Com/InfluencedByBooks/Look.hs deleted file mode 100644 index d904d3a..0000000 --- a/Com/InfluencedByBooks/Look.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | The look and feel of Ibb -module Com.InfluencedByBooks.Look where - -import Alpha hiding ( Selector ) -import Clay -import qualified Clay.Flexbox as Flexbox -import qualified Clay.Media as Media -import qualified Clay.Render as Clay -import qualified Clay.Stylesheet as Stylesheet - -main :: Css -main = do - "html" <> "body" ? do - width (pct 100) - display flex - flexDirection column - alignItems center - alignContent center - justifyContent center - ".container" ? do - maxWidth (px 900) - display flex - justifyContent center - flexDirection column - fontFamily ["GillSans", "Calibri", "Trebuchet"] [sansSerif] - headings ? do - fontFamily - [ "Palatino" - , "Palatino Linotype" - , "Hoefler Text" - , "Times New Roman" - , "Times" - ] - [serif] - -headings :: Selector -headings = h1 <> h2 <> h3 <> h4 <> h5 <> h6 diff --git a/Com/InfluencedByBooks/Move.hs b/Com/InfluencedByBooks/Move.hs deleted file mode 100644 index 5d6f0c4..0000000 --- a/Com/InfluencedByBooks/Move.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - --- | App update logic -module Com.InfluencedByBooks.Move - ( move - -- * Server interactions - , fetchPeople - ) -where - -import Alpha -import Com.InfluencedByBooks.Core as Core -import Com.Simatime.Network -import Data.Aeson -import JavaScript.Web.XMLHttpRequest ( Request(..) - , Method(GET) - , RequestData(NoData) - , contents - , xhrByteString - ) -import Miso -import Miso.String - -move :: Action -> Model -> Effect Action Model -move Nop m = noEff m -move (HandleRoute u) m = m { uri = u } <# pure Nop -move (ChangeRoute u) m = m <# do - pushURI u >> pure Nop -move FetchPeople m = m <# (SetPeople pure $ Failure "could not read from server" - Just a -> - pure $ fromEither $ either (Left . ms) pure $ eitherDecodeStrict a - where - req = Request { reqMethod = GET - -- FIXME: can replace this hardcoding with a function? - , reqURI = "/api/people" - , reqLogin = Nothing - , reqHeaders = [] - , reqWithCredentials = False - , reqData = NoData - } diff --git a/Com/InfluencedByBooks/Server.hs b/Com/InfluencedByBooks/Server.hs deleted file mode 100644 index 244a7ca..0000000 --- a/Com/InfluencedByBooks/Server.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - --- | Server --- --- : exe ibb --- --- : dep clay --- : dep miso --- : dep protolude --- : dep servant --- : dep text --- : dep MonadRandom --- : dep acid-state --- : dep bytestring --- : dep ixset --- : dep random --- : dep safecopy --- : dep scotty --- : dep servant-server --- : dep text -module Com.InfluencedByBooks.Server where - -import Alpha -import qualified Clay -import Com.InfluencedByBooks.Core -import qualified Com.InfluencedByBooks.Keep as Keep -import qualified Com.InfluencedByBooks.Look as Look -import Com.Simatime.Network -import Data.Acid ( AcidState ) -import qualified Data.Acid.Abstract as Acid -import Data.Maybe ( fromMaybe ) -import qualified Data.Text.Lazy as Lazy -import qualified Data.Text.Lazy.Encoding as Lazy -import qualified Lucid as L -import Lucid.Base -import Miso -import Network.HTTP.Media ( (//) - , (/:) - ) -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Application.Static -import Network.Wai.Handler.Warp -import Network.Wai.Middleware.Gzip -import Network.Wai.Middleware.RequestLogger -import Servant -import System.Environment ( lookupEnv ) - -main :: IO () -main = do - say "rise: ibb" - staticDir <- fromMaybe "static" <$> lookupEnv "STATIC_DIR" :: IO [Char] - port <- read <$> fromMaybe "3000" <$> lookupEnv "PORT" :: IO Int - keep <- Keep.openLocal "_keep/" - say "port: 3000" - run port $ logStdout $ compress $ app staticDir $ keep - where compress = gzip def { gzipFiles = GzipCompress } - -newtype HtmlPage a = HtmlPage a - deriving (Show, Eq) - -instance L.ToHtml a => L.ToHtml (HtmlPage a) where - toHtmlRaw = L.toHtml - toHtml (HtmlPage x) = L.doctypehtml_ $ do - L.head_ $ do - L.meta_ [L.charset_ "utf-8"] - jsRef "/static/ibb.js" - cssRef "/css/main.css" - L.body_ $ do - page - where - page = L.toHtml x - jsRef href = L.with - (L.script_ mempty) - [ makeAttribute "src" href - , makeAttribute "type" "text/javascript" - , makeAttribute "async" mempty - , makeAttribute "defer" mempty - ] - cssRef href = L.with - (L.link_ mempty) - [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href] - -type ServerRoutes = ToServerRoutes AppRoutes HtmlPage Action - -handle404 :: Application -handle404 _ respond = - respond - $ responseLBS status404 [("Content-Type", "text/html")] - $ renderBS - $ toHtml - $ HtmlPage - $ notfound - -newtype CSS = CSS - { unCSS :: Text - } - -instance MimeRender CSS Text where - mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict - -instance Accept CSS where - contentType _ = "text" // "css" /: ("charset", "utf-8") - -type CssRoute = "css" :> "main.css" :> Get '[CSS] Text - -type Routes - = "static" - :> - Raw - :<|> - CssRoute - :<|> - ServerRoutes - :<|> - "api" - :> - ApiRoutes - :<|> - Raw - -cssHandlers :: Server CssRoute -cssHandlers = return . Lazy.toStrict . Clay.render $ Look.main - -app :: [Char] -> AcidState Keep.IbbKeep -> Application -app staticDir keep = - serve (Proxy @Routes) - $ static - :<|> cssHandlers - :<|> serverHandlers - :<|> apiHandlers keep - :<|> Tagged handle404 - where static = serveDirectoryWith (defaultWebAppSettings $ staticDir) - -type ApiRoutes = "people" :> Get '[JSON] [Person] - -serverHandlers :: Server ServerRoutes -serverHandlers = homeHandler - where - send f u = pure $ HtmlPage $ f Model { uri = u, people = NotAsked } - homeHandler = send home goHome - --- | for now we just have one api endpoint, which returns all the people -apiHandlers :: AcidState Keep.IbbKeep -> Server ApiRoutes -apiHandlers keep = Acid.query' keep $ Keep.GetPeople 20 diff --git a/Com/InfluencedByBooks/service.nix b/Com/InfluencedByBooks/service.nix deleted file mode 100644 index f9d0f36..0000000 --- a/Com/InfluencedByBooks/service.nix +++ /dev/null @@ -1,42 +0,0 @@ -{ options -, lib -, config -, pkgs -, modulesPath -}: - -let - cfg = config.services.ibb; -in -{ - options.services.ibb = { - enable = lib.mkEnableOption "Enable the IBB service"; - port = lib.mkOption { - type = lib.types.string; - default = "3000"; - description = '' - The port on which IBB will listen for - incoming HTTP traffic. - ''; - }; - }; - config = lib.mkIf cfg.enable { - systemd.services.ibb = { - path = with pkgs; [ ibb bash ]; - wantedBy = [ "multi-user.target" ]; - script = '' - PORT=${cfg.port} ./bin/ibb - ''; - description = '' - Influenced By Books website - ''; - serviceConfig = { - WorkingDirectory = pkgs.ibb; - KillSignal = "INT"; - Type = "simple"; - Restart = "on-abort"; - RestartSec = "10"; - }; - }; - }; -} diff --git a/Com/MusicMeetsComics/App.hs b/Com/MusicMeetsComics/App.hs deleted file mode 100644 index 3fa237d..0000000 --- a/Com/MusicMeetsComics/App.hs +++ /dev/null @@ -1,748 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Com.MusicMeetsComics.App where - -import Alpha -import qualified Clay -import qualified Com.MusicMeetsComics.Assets as Assets -import Com.MusicMeetsComics.Look as Look -import Com.MusicMeetsComics.Look.Typography -import Com.Simatime.Network -import Data.Aeson ( ToJSON(..) - , FromJSON(..) - , genericToJSON - , genericParseJSON - , defaultOptions - ) -import qualified Data.List as List -import qualified Data.List.Split as List -import Data.Proxy ( Proxy(..) ) -import Data.String -import Data.String.Quote -import Data.Text ( Text, replace, toLower ) -import GHC.Generics ( Generic ) -import qualified GHC.Show as Legacy -import Miso -import qualified Miso (for_) -import Miso.String -import Protolude hiding (replace) -import Servant.API ( Capture - , URI(..) - , safeLink - , (:<|>)(..) - , (:>) - ) -import Servant.Links ( linkURI ) - -crossorigin_ :: MisoString -> Attribute action -crossorigin_ = textProp "crossorigin" - --- | The css id for controling music in the comic player. -audioId :: MisoString -audioId = "audioSource" - --- | Like 'onClick' but prevents the default action from triggering. Use this to --- overide 'a_' links, for example. -onPreventClick :: Action -> Attribute Action -onPreventClick action = - onWithOptions Miso.defaultOptions { preventDefault = True } - "click" emptyDecoder (\() -> action) - --- TODO: make ComicId a hashid https://hackage.haskell.org/package/hashids-1.0.2.4/docs/Web-Hashids.html -type ComicId = String - --- | Class for turning different string types to snakeCase. -class CanSnakeCase str where - snake :: str -> str - -instance CanSnakeCase Text where - snake = Data.Text.replace " " "-" . Data.Text.toLower - --- | Used for looking up images on S3, mostly -comicSlug :: Comic -> Text -comicSlug Comic{..} = snake comicName <> "-" <> comicIssue - -data Comic = Comic - { comicId :: ComicId - , comicPages :: Integer - , comicName :: Text - , comicIssue :: Text -- ^ Ideally this would be a dynamic number-like type - , comicDescription :: Text - } deriving (Show, Eq, Generic) - -instance ToJSON Comic where - toJSON = genericToJSON Data.Aeson.defaultOptions - -instance FromJSON Comic where - parseJSON = genericParseJSON Data.Aeson.defaultOptions - --- | Class for rendering media objects in different ways. -class IsMediaObject o where - -- | Render a thumbnail for use in a shelf, or otherwise. - thumbnail :: o -> View Action - -- | Render a featured banner. - feature :: o -> Library -> View Action - -- | Media info view - info :: o -> Library -> View Action - -instance IsMediaObject Comic where - thumbnail c@Comic{..} = li_ [] - [ a_ - [ class_ "comic grow clickable" - , id_ $ "comic-" <> ms comicId - , onClick $ SetMediaInfo $ Just c - ] - [ img_ [ src_ $ ms $ Assets.demo <> comicSlug c <> ".png" ] - , span_ [] [ text $ "Issue #" <> ms comicIssue ] - , span_ [] [ text $ ms comicName ] - ] - ] - feature comic lib = div_ [ id_ "featured-comic" ] - [ img_ [ id_ "featured-banner", src_ $ ms $ Assets.demo <> "feature-banner.png" ] - , div_ [ id_ "featured-content" ] - [ div_ [ class_ "hero-original", css wide ] - [ span_ [ css thicc ] [ text "Herø" ] - , span_ [ css euro ] [ text " Original" ] - ] - , div_ [ class_ "comic-logo" ] - [ img_ [ src_ $ ms $ Assets.demo <> comicSlug comic <> "-logo.png" ] ] - , div_ [ class_ "comic-action-menu" ] $ el <$> [ Watch comic, Read comic, Save comic lib ] - , p_ [ class_ "description" ] - [ text . ms $ comicDescription comic - ] - ] - ] - info c@Comic {..} lib = div_ [ class_ "media-info", css euro ] - [ div_ [ class_ "media-info-meta" ] - [ column [ img_ [ src_ $ ms $ Assets.demo <> "dmc-widethumb.png" ] ] - , column - [ span_ [ style_ title ] [ text $ ms comicName ] - , span_ [ style_ subtitle ] [ text $ "Issue #" <> ms comicIssue ] - , span_ [] [ text "Released: " ] - , span_ [] [ text $ "Pages: " <> ms (show comicPages :: String) ] - ] - ] - , div_ [ class_ "media-info-summary" ] - [ p_ [ style_ $ uppercase <> bold <> Look.expanded <> "font-size" =: ".8rem" ] - [ text "Summary" ] - , p_ [] [ text $ ms comicDescription ] - ] - , div_ [ class_ "media-info-actions" ] $ el <$> [ Save c lib, Read c, Watch c ] - -- , row [ text "credits" ] - ] - where - title = "color" =: "red" <> "font-size" =: "1.6rem" <> uppercase - <> "line-height" =: "100%" <> Look.condensed <> bold - subtitle = "color" =: "#fff" <> "font-size" =: "1.2rem" <> bold <> Look.condensed - - -type ZoomModel = Int - --- | All the buttons. -data Button - = Watch Comic | Read Comic | Save Comic Library - | SaveIcon Comic Library - | ZoomIcon ZoomModel Comic Page - | PlayPause MisoString AudioState - | Arrow Action - --- | Class for defining general, widely used elements in the heroverse. -class Elemental v where el :: v -> View Action - --- TODO: what if I just did this on all actions? --- then I could e.g. `el $ ToggleAudio audioId audioState` -instance Elemental Button where - el (PlayPause id model) = button_ - [ class_ "button is-large icon" - , onClick $ ToggleAudio id - ] - [ i_ [ class_ $ "fa " <> icon ][]] - where - icon = case model of - Paused -> "fa-play-circle" - Playing -> "fa-pause-circle" - el (Arrow act) = button_ - [class_ "button is-large turn-page", onClick act] - [ img_ [src_ $ ms $ Assets.demo <> image <> ".png"]] - where image = case act of - PrevPage -> "prev-page" - NextPage -> "next-page" - _ -> "prev-page" - el (Save c lib) = - if c `elem` lib then -- in library - a_ [ class_ $ "wrs-button saved", onClick $ ToggleInLibrary c ] - [ img_ [ src_ $ ms $ Assets.icon <> "save.svg" ] - , span_ [] [ text "saved" ] - ] - else -- not in library - a_ [ class_ $ "wrs-button", onClick $ ToggleInLibrary c ] - [ img_ [ src_ $ ms $ Assets.icon <> "save.svg" ] - , span_ [] [ text "save" ] - ] - el (SaveIcon c lib) = - if c `elem` lib then -- in library - button_ - [ class_ "button is-large has-background-black" - , onClick $ ToggleInLibrary c - ] - [ img_ [ src_ $ ms $ Assets.demo <> "library-add.png" ] ] - else -- not in library - button_ - [ class_ "button is-large has-background-black-bis" - , onClick $ ToggleInLibrary c - ] - [ img_ [ src_ $ ms $ Assets.demo <> "library-add.png" ] ] - - el (ZoomIcon zmodel comic page) = button_ - [ id_ "zoom-button", class_ "button is-large" - , onClick $ ToggleZoom comic page - ] - [ img_ [ src_ $ ms $ Assets.demo <> "zoom.png" ] - , input_ - [ type_ "range", min_ "0", max_ "100", disabled_ True - , value_ $ ms (show zmodel :: String) - , class_ "ctrl", id_ "zoom" - ] - , label_ - [ class_ "ctrl", Miso.for_ "zoom" ] - [ text $ ms $ (show zmodel :: String) ++ "%" ] - ] - - el (Read c) = a_ [ class_ $ "wrs-button", onClick $ SelectExperience c ] - [ img_ [ src_ $ ms $ Assets.icon <> "read.svg" ] - , span_ [] [ text "read" ] - ] - - el (Watch c) = a_ [ class_ $ "wrs-button", onClick $ StartWatching c ] - [ img_ [ src_ $ ms $ Assets.icon <> "watch.svg" ] - , span_ [] [ text "watch" ] - ] - -data AudioState = Playing | Paused - deriving (Show, Eq) - -type Library = [Comic] - -data ComicReaderState - = NotReading - | Cover ComicId - | ChooseExperience ComicId Page - | Reading ComicReaderView ComicId Page - | Watching ComicId - deriving (Show, Eq) - -findComic :: ComicId -> [Comic] -> Maybe Comic -findComic id ls = List.find (\c -> comicId c == id) ls - --- | Main model for the app. --- --- Try to prefix component-specific state with the component initials: 'd' for --- discover, 'cp' for comic player. -data Model = Model - { uri :: URI - , appComics :: RemoteData MisoString [Comic] - , userLibrary :: Library - , dMediaInfo :: Maybe Comic - , cpState :: ComicReaderState - , cpAudioState :: AudioState - , zoomModel :: ZoomModel - } deriving (Show, Eq) - -initModel :: URI -> Model -initModel uri_ = - Model { uri = uri_ - , appComics = NotAsked - , dMediaInfo = Nothing - , userLibrary = Protolude.empty - , cpState = detectPlayerState uri_ - , cpAudioState = Paused - , zoomModel = 100 - } - --- | Hacky way to initialize the 'ComicReaderState' from the URI. -detectPlayerState :: URI -> ComicReaderState -detectPlayerState u = case List.splitOn "/" $ uriPath u of - ["", "comic", id, pg, "experience"] -> ChooseExperience id $ toPage pg - ["", "comic", id, _, "video"] -> Watching id - ["", "comic", id, pg, "full"] -> Reading Full id $ toPage pg - ["", "comic", id, pg] -> Reading Spread id $ toPage pg - ["", "comic", id] -> Cover id - _ -> NotReading - where - toPage pg = fromMaybe 1 (readMaybe pg :: Maybe Page) - -type Page = Int - -data Action - = NoOp - -- comic player stuff - | SelectExperience Comic - | StartReading Comic - | StartWatching Comic - | NextPage - | PrevPage - | ToggleZoom Comic Page - | ToggleAudio MisoString - | FetchComics - | SetComics (RemoteData MisoString [Comic]) - | ToggleFullscreen - -- discover stuff - | SetMediaInfo (Maybe Comic) - | ToggleInLibrary Comic - -- app stuff - | ScrollIntoView MisoString - | HandleURI URI - | ChangeURI URI - | DumpModel - deriving (Show, Eq) - -type Discover = "discover" :> View Action - -type Home = - View Action - -type ComicCover = - "comic" - :> Capture "comicId" ComicId - :> View Action - -type ComicReaderSpread = - "comic" - :> Capture "id" ComicId - :> Capture "page" Page - :> View Action - -type ComicReaderFull = - "comic" - :> Capture "id" ComicId - :> Capture "page" Page - :> "full" - :> View Action - -type ComicVideo = - "comic" - :> Capture "id" ComicId - :> Capture "page" Page - :> "video" - :> View Action - -type ChooseExperience = - "comic" - :> Capture "id" ComicId - :> Capture "page" Page - :> "experience" - :> View Action - -type Login = - "login" :> View Action - -type ClientRoutes = Home - :<|> ComicCover :<|> ComicReaderSpread :<|> ComicReaderFull :<|> ComicVideo - :<|> Login :<|> Discover :<|> ChooseExperience - -handlers = home - :<|> comicCover :<|> comicPlayer :<|> comicPlayer :<|> comicPlayer - :<|> login :<|> discover :<|> comicPlayer - -routes :: Proxy ClientRoutes -routes = Proxy - -comicPlayerSpreadProxy :: Proxy ComicReaderSpread -comicPlayerSpreadProxy = Proxy - -comicPlayerFullProxy :: Proxy ComicReaderFull -comicPlayerFullProxy = Proxy - -chooseExperienceProxy :: Proxy ChooseExperience -chooseExperienceProxy = Proxy - -comicProxy :: Proxy ComicCover -comicProxy = Proxy - -comicVideoProxy :: Proxy ComicVideo -comicVideoProxy = Proxy - -homeProxy :: Proxy Home -homeProxy = Proxy - -loginProxy :: Proxy Login -loginProxy = Proxy - -discoverProxy :: Proxy Discover -discoverProxy = Proxy - -home :: Model -> View Action -home = login - -discover :: Model -> View Action -discover model@(Model { userLibrary = lib}) = template "discover" - [ topbar - , main_ [id_ "app-body"] $ case appComics model of - NotAsked -> [loading] - Loading -> [loading] - Failure _ -> [nocomics] - Success [] -> [nocomics] - Success (comic:rest) -> - [ feature comic lib - , shelf "Recent Releases" (comic:rest) - , maybeView (flip info lib) $ dMediaInfo model - ] - , appmenu - , discoverFooter - ] - --- | If 'View' had a 'Monoid' instance, then '(text "")' could just be 'mempty' -maybeView :: (a -> View action) -> Maybe a -> View action -maybeView f obj = maybe (text "") f obj - -mediaInfo :: Maybe Comic -> Library -> View Action -mediaInfo Nothing _ = text "" -mediaInfo (Just comic) lib = div_ [ class_ "media-info" ] [ info comic lib ] - -appmenu :: View Action -appmenu = aside_ [ id_ "appmenu" ] $ btn img] - , span_ [] [ text label ] - ] - --- TODO: make this a loading gif of some sort... maybe the hero icon filling from white to red -loading :: View Action -loading = div_ [ class_ "loading" ] [ text "Loading..." ] - -nocomics :: View Action -nocomics = div_ [ class_ "loading" ] [ text "error: no comics found" ] - -shelf :: IsMediaObject o => MisoString -> [o] -> View Action -shelf title comics = div_ [ class_ "shelf" ] - [ div_ [ class_ "shelf-head" ] [ text title ] - , ul_ [ class_ "shelf-body" ] $ thumbnail "hero-logo.svg" ]] - , span_ [] [ text "© Com.MusicMeetsComics Records, Inc. All Rights Reserved" ] - ] - ] - where - attrs Nothing = [ class_ "social-icon" ] - attrs (Just lnk) = [ class_ "social-icon", href_ lnk, target_ "_blank" ] - smallImg x lnk = a_ (attrs lnk) - [ img_ [src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/" <> x ]] - -comicCover :: ComicId -> Model -> View Action -comicCover comicId_ model = comicPlayer comicId_ 1 model - -data ComicReaderView = Spread | Full - deriving (Show, Eq) - -comicPlayer :: ComicId -> Page -> Model -> View Action -comicPlayer _ _ model = case appComics model of - NotAsked -> loading - Loading -> loading - Failure _ -> nocomics - Success comics -> case cpState model of - NotReading -> template "comic-player" [ text "error: not reading" ] - Cover id -> viewOr404 comics comicSpread id 1 model - ChooseExperience id pg -> - viewOr404 comics chooseExperiencePage id pg model - Reading Spread id pg -> viewOr404 comics comicSpread id pg model - Reading Full id pg -> viewOr404 comics zoomScreen id pg model - Watching id -> viewOr404 comics comicVideo id 0 model - -viewOr404 :: [Comic] - -> (Comic -> Page -> Model -> View Action) - -> ComicId -> Page -> Model -> View Action -viewOr404 comics f id pg model = - case findComic id comics of - Just c -> f c pg model - Nothing -> the404 model - -template :: MisoString -> [View Action] -> View Action -template id rest = div_ [id_ id, class_ "app is-black"] rest - -closeButton :: View Action -closeButton = a_ [ id_ "close-button", onClick $ ChangeURI discoverLink ] - [ text "x" ] - -zoomScreen :: Comic -> Page -> Model -> View Action -zoomScreen comic page model = template "comic-player" - [ topbar - , main_ - [id_ "app-body"] - [ img_ - [ src_ comicImg - , class_ "comic-page-full" - ] - ] - , comicControls comic page model - ] - where - comicImg = - ms Assets.demo - <> ms (comicSlug comic) - <> "-" - <> padLeft page - <> ".png" - -comicSpread :: Comic -> Page -> Model -> View Action -comicSpread comic page model = template "comic-player" - [ topbar - , main_ - [id_ "app-body"] - [ div_ - [class_ "comic-player"] - [ img_ [ src_ comicImgLeft, class_ "comic-page" ] - , img_ [ src_ comicImgRight, class_ "comic-page" ] - ] - , closeButton - ] - , appmenu - , comicControls comic page model - ] - where - comicImgLeft, comicImgRight :: MisoString - comicImgLeft = - ms Assets.demo - <> ms (comicSlug comic) - <> "-" - <> padLeft page - <> ".png" - comicImgRight = - ms Assets.demo - <> ms (comicSlug comic) - <> "-" - <> (padLeft $ 1 + page) - <> ".png" - -frameborder_ :: MisoString -> Attribute action -frameborder_ = textProp "frameborder" - -allowfullscreen_ :: Bool -> Attribute action -allowfullscreen_ = boolProp "allowfullscreen" - -comicVideo :: Comic -> Page -> Model -> View Action -comicVideo _ _ _ = template "comic-player" - [ topbar - , main_ - [ id_ "app-body" ] - [ div_ [class_ "comic-video"] - [ iframe_ - [ src_ "//player.vimeo.com/video/325757560" - , frameborder_ "0" - , allowfullscreen_ True - ] - [] - ] - ] - ] - -padLeft :: Int -> MisoString -padLeft n | n < 10 = ms $ ("0" <> Legacy.show n) - | otherwise = ms $ Legacy.show n - -comicControls :: Comic -> Page -> Model -> View Action -comicControls comic page model = footer_ - [ id_ "app-foot", class_ "comic-controls" ] - [ div_ - [ class_ "comic-nav-audio" - , css $ flexCenter ] - [ audio_ - [id_ audioId, loop_ True, crossorigin_ "anonymous"] - [source_ [src_ $ ms $ Assets.demo <> "stars-instrumental.mp3"]] - , el $ PlayPause audioId $ cpAudioState model - , span_ - [ css $ euro <> thicc <> smol <> wide ] - [ text "Experiencing: Original" ] - ] - , div_ - [ class_ "comic-controls-pages", css euro ] - [ el $ Arrow $ PrevPage - , span_ [] [ text $ leftPage <> "-" <> rightPage <> " of " <> totalpages ] - , el $ Arrow $ NextPage - ] - , div_ [class_ "comic-controls-share"] - [ el $ SaveIcon comic $ userLibrary model - , el $ ZoomIcon (zoomModel model) comic page - , button_ - [class_ "button icon is-large", onClick ToggleFullscreen] - [i_ [ class_ "fa fa-expand" ] []] - ] - ] - where - leftPage = ms . Legacy.show $ page - rightPage = ms . Legacy.show $ 1 + page - totalpages = ms . Legacy.show $ comicPages comic - -login :: Model -> View Action -login _ = template "login" - [ div_ [ id_ "login-inner" ] - [ img_ [ class_ fadeIn - , src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/hero-large.png" - ] - , hr_ [class_ fadeIn] - , form_ [class_ fadeIn] - [ ctrl [class_ "input", type_ "email", placeholder_ "Email"] - , ctrl [class_ "input", type_ "password", placeholder_ "Password"] - , div_ [class_ "action", css euro] - [ div_ [class_ "checkbox remember-me"] - [ input_ [type_ "checkbox"] - , label_ [Miso.for_ "checkbox"] [text "Remember Me"] - ] - , div_ [class_ "button is-black", onClick $ ChangeURI discoverLink] - [ text "Login" ] - ] - ] - , hr_ [class_ fadeIn] - , p_ [ class_ $ "help " <> fadeIn ] - [ a_ [href_ "#"][text "Forgot your username or password?"] - , a_ [href_ "#"][text "Don't have an account? Sign Up"] - ] - , img_ [ id_ "hero-logo" - , class_ "blur-out" - , src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/success-her-image.png" - ] - ] - ] - where - fadeIn = "animated fadeIn delay-2s" - ctrl x = div_ [class_ "control"] [ input_ x ] - -chooseExperiencePage :: Comic -> Page -> Model -> View Action -chooseExperiencePage comic page model = template "choose-experience" - [ topbar - , main_ [ id_ "app-body" ] - [ h2_ [] [ text "Choose Your Musical Experience" ] - , p_ [] [ text experienceBlurb ] - , ul_ [] $ li comic name <> ".png" ] - , span_ [] [ text $ ms name ] - ] - , span_ [ css $ thicc ] [ text $ ms artist ] - , span_ [] [ text $ ms track ] - ] - experiences :: [(Text, Text, Text)] - experiences = - [ ("comedic", "RxGF", "Soft Reveal") - , ("dark", "Logan Henderson", "Speak of the Devil") - , ("original", "Mehcad Brooks", "Stars") - , ("energetic", "Skela", "What's wrong with me") - , ("dramatic", "Josh Jacobson", "Sideline") - ] - - -experienceBlurb :: MisoString -experienceBlurb = [s| -As you enter the world of Hero, you will find that music and visual art have a -symbiotic relationship that can only be experienced, not described. Here, choose -the tonality of the experience you wish to adventure on, whether it's a comedic, -dark, energetic or dramatic. Feeling indecisive? Let us navigate your journey -with the original curated music for this piece of visual art. -|] - -topbar :: View Action -topbar = header_ - [id_ "app-head", class_ "is-black", css euro] - [ a_ - [class_ "button is-medium is-black", onClick $ ChangeURI homeLink] - [img_ [src_ $ ms $ Assets.icon <> "hero-logo.svg"]] - , div_ - [id_ "app-head-right"] - [ button_ [class_ "button icon is-medium is-black"] - [i_ [class_ "fas fa-search" ] []] - , button_ [ class_ "button is-medium is-black is-size-7" - , css $ euro <> wide <> thicc - ] - [text "News"] - , span_ [ class_ "icon is-large" ] - [ i_ [ class_ "fas fa-user" ] [] - ] - ] - ] - -row :: [View Action] -> View Action -row = div_ [ css $ Clay.display Clay.flex <> Clay.flexDirection Clay.row ] - -column :: [View Action] -> View Action -column = div_ [ css $ Clay.display Clay.flex <> Clay.flexDirection Clay.column ] - --- | Links - -comicLink :: ComicId -> URI -comicLink comicId_ = linkURI $ safeLink routes comicProxy $ comicId_ - -comicPlayerSpreadLink :: ComicId -> Page -> URI -comicPlayerSpreadLink id page = - linkURI $ safeLink routes comicPlayerSpreadProxy id page - -comicPlayerFullLink :: ComicId -> Page -> URI -comicPlayerFullLink id page = - linkURI $ safeLink routes comicPlayerFullProxy id page - -comicVideoLink :: ComicId -> Page -> URI -comicVideoLink id page = - linkURI $ safeLink routes comicVideoProxy id page - -homeLink :: URI -homeLink = linkURI $ safeLink routes homeProxy - -loginLink :: URI -loginLink = linkURI $ safeLink routes loginProxy - -discoverLink :: URI -discoverLink = linkURI $ safeLink routes discoverProxy - -the404 :: Model -> View Action -the404 _ = template "404" [p_ [] [text "Not found"]] - -chooseExperienceLink :: ComicId -> Page -> URI -chooseExperienceLink id page = - linkURI $ safeLink routes chooseExperienceProxy id page diff --git a/Com/MusicMeetsComics/Assets.hs b/Com/MusicMeetsComics/Assets.hs deleted file mode 100644 index f4fabde..0000000 --- a/Com/MusicMeetsComics/Assets.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} --- | A module to wrap the CDN and provide convient helper functions to assets. -module Com.MusicMeetsComics.Assets where - -import Protolude - -cdnEdge :: Text -cdnEdge = "https://heroverse.sfo2.cdn.digitaloceanspaces.com" - -demo :: Text -demo = cdnEdge <> "/old-assets/demo/" - -icon :: Text -icon = cdnEdge <> "/icons/" diff --git a/Com/MusicMeetsComics/Client.hs b/Com/MusicMeetsComics/Client.hs deleted file mode 100644 index 2361939..0000000 --- a/Com/MusicMeetsComics/Client.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} --- | Hero app frontend --- --- : exe mmc.js --- --- : dep aeson --- : dep clay --- : dep containers --- : dep miso --- : dep protolude --- : dep servant --- : dep split --- : dep string-quote --- : dep text --- : dep ghcjs-base -module Com.MusicMeetsComics.Client where - -import Com.MusicMeetsComics.App ( Action(..) - , Comic(..) - , ComicReaderState(..) - , ComicReaderView(..) - , Model(..) - , AudioState(..) - , audioId - , chooseExperienceLink - , comicPlayerSpreadLink - , comicPlayerFullLink - , comicVideoLink - , handlers - , initModel - , the404 - , routes - ) -import qualified Com.Simatime.Network as Network -import Data.Aeson ( eitherDecodeStrict ) -import qualified Data.Set as Set -import qualified GHC.Show as Legacy -import JavaScript.Web.XMLHttpRequest ( Request(..) - , Method(GET) - , RequestData(NoData) - , contents - , xhrByteString - ) -import Miso -import Miso.Effect.DOM (scrollIntoView) -import qualified Miso.FFI.Audio as Audio -import qualified Miso.FFI.Document as Document -import qualified Miso.FFI.Fullscreen as Fullscreen -import Miso.String -import Protolude - --- | Entry point for a miso application -main :: IO () -main = miso $ \currentURI -> App { model = initModel currentURI, .. } - where - update = move - view = see - subs = [ uriSub HandleURI - , keyboardSub keynav - ] - events = defaultEvents - initialAction = FetchComics - mountPoint = Nothing - -(∈) :: Ord a => a -> Set a -> Bool -(∈) = Set.member - --- | Keyboard navigation - maps keys to actions. -keynav :: Set Int -> Action -keynav ks - | 37 ∈ ks = PrevPage -- ^ left arrow - | 39 ∈ ks = NextPage -- ^ right arrow - | 191 ∈ ks = DumpModel -- ^ ? - | 32 ∈ ks = ToggleAudio audioId -- ^ SPC - | otherwise = NoOp - -see :: Model -> View Action -see model = - case runRoute routes handlers uri model of - Left _ -> the404 model - Right v -> v - --- | Console-logging -foreign import javascript unsafe "console.log($1);" - say :: MisoString -> IO () - --- | Updates model, optionally introduces side effects -move :: Action -> Model -> Effect Action Model -move NoOp model = noEff model -move DumpModel model = model <# do - say $ ms $ Legacy.show model - pure NoOp -move (SelectExperience comic) model = model { cpState = ChooseExperience (comicId comic) 1 } - <# do pure $ ChangeURI $ chooseExperienceLink (comicId comic) 1 -move (StartReading comic) model = model { cpState = Reading Spread (comicId comic) 1 } - <# do pure $ ChangeURI $ comicPlayerSpreadLink (comicId comic) 1 -move (StartWatching comic) model = model { cpState = Watching (comicId comic) } - <# do pure $ ChangeURI $ comicVideoLink (comicId comic) 1 -move NextPage model = case cpState model of - Reading Spread id pg -> - model { cpState = Reading Spread id (pg+2) } <# do - pure $ ChangeURI $ comicPlayerSpreadLink id (pg+2) - Reading Full id pg -> - model { cpState = Reading Full id (pg+1) } <# do - pure $ ChangeURI $ comicPlayerFullLink id (pg+1) - Cover id -> - model { cpState = Reading Spread id 1 } <# do - pure $ ChangeURI $ comicPlayerSpreadLink id 1 - _ -> noEff model -move PrevPage model = case cpState model of - Reading Spread id pg -> - model { cpState = Reading Spread id (pg-2) } <# do - pure $ ChangeURI $ comicPlayerSpreadLink id (pg-2) - Reading Full id pg -> - model { cpState = Reading Full id (pg-1) } <# do - pure $ ChangeURI $ comicPlayerFullLink id (pg-1) - Cover _ -> noEff model - _ -> noEff model -move (ToggleZoom c pg) m = m { cpState = newState } <# do pure act - where - goto lnk = ChangeURI $ lnk (comicId c) pg - reading v = Reading v (comicId c) pg - (newState, act) = case cpState m of - Reading Full _ _ -> (reading Spread, goto comicPlayerSpreadLink) - Reading Spread _ _ -> (reading Full, goto comicPlayerFullLink) - x -> (x, NoOp) -move (ToggleInLibrary c) model = model { userLibrary = newLib } <# pure NoOp - where - newLib | c `elem` (userLibrary model) = - Protolude.filter (/= c) $ userLibrary model - | otherwise = c : (userLibrary model) -move (HandleURI u) model = model { uri = u } <# pure NoOp -move (ChangeURI u) model = model <# do - pushURI u - pure NoOp -move FetchComics model = model <# (SetComics <$> fetchComics) -move (SetComics cs) model = noEff model { appComics = cs } -move (ToggleAudio i ) model = model { cpAudioState = newState } <# do - el <- Document.getElementById i - toggle el - pure NoOp - where - (newState, toggle) = case cpAudioState model of - Playing -> (Paused, Audio.pause) - Paused -> (Playing, Audio.play) -move ToggleFullscreen model = model { cpState = newState } <# do - el <- Document.querySelector "body" - -- TODO: check Document.fullscreenEnabled - -- https://developer.mozilla.org/en-US/docs/Web/API/Document/fullscreenEnabled - _ <- toggle el - pure NoOp - where - (toggle, newState) = case cpState model of - Reading Full c n -> (const Fullscreen.exit, Reading Full c n) - Reading Spread c n -> (Fullscreen.request, Reading Spread c n) - -- otherwise, do nothing: - x -> (pure, x) -move (SetMediaInfo x) model = model { dMediaInfo = x } <# do - case x of - Just Comic {comicId = id} -> - pure $ ScrollIntoView $ "comic-" <> ms id - Nothing -> - pure NoOp -move (ScrollIntoView id) model = model <# do - say $ ms $ Legacy.show id - scrollIntoView id - pure NoOp - -fetchComics :: IO (Network.RemoteData MisoString [Comic]) -fetchComics = do - mjson <- contents <$> xhrByteString req - case mjson of - Nothing -> - pure $ Network.Failure "Could not fetch comics from server." - Just json -> pure $ Network.fromEither - $ either (Left . ms) pure - $ eitherDecodeStrict json - where - req = Request - { reqMethod = GET - , reqURI = "/api/comic" -- FIXME: can we replace this hardcoding? - , reqLogin = Nothing - , reqHeaders = [] - , reqWithCredentials = False - , reqData = NoData - } diff --git a/Com/MusicMeetsComics/Database.hs b/Com/MusicMeetsComics/Database.hs deleted file mode 100644 index c5a0068..0000000 --- a/Com/MusicMeetsComics/Database.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Com.MusicMeetsComics.Database - ( ComicDB - , getComics - , load - , dummy - ) -where - -import Com.MusicMeetsComics.App -import Data.Map ( Map ) -import qualified Data.Map as Map -import Dhall -import Protolude -import Servant ( Handler ) - -type ComicDB = (Map ComicId Comic) - -instance Interpret Comic - -load :: IO ComicDB -load = listToComicDB <$> input auto "./comic-database.dhall" - -dummy :: IO ComicDB -dummy = return $ listToComicDB - [ Comic { comicId = "ComicId" - , comicPages = 10 - , comicName = "Dummy comic" - , comicIssue = "dummy issue" - , comicDescription = "Lorem ipsum" - } - ] - -listToComicDB :: [Comic] -> ComicDB -listToComicDB ls = Map.fromList $ (,) <$> comicId <*> identity <$> ls - -getComics :: ComicDB -> Handler [Comic] -getComics db = return $ Map.elems db diff --git a/Com/MusicMeetsComics/Look.hs b/Com/MusicMeetsComics/Look.hs deleted file mode 100644 index f53955c..0000000 --- a/Com/MusicMeetsComics/Look.hs +++ /dev/null @@ -1,567 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- | Styles --- --- Eventually move make this mostly well-typed. Use this EDSL: --- http://fvisser.nl/clay/ -module Com.MusicMeetsComics.Look where - -import Clay -import qualified Clay.Flexbox as Flexbox -import qualified Clay.Media as Media -import qualified Clay.Render as Clay -import qualified Clay.Stylesheet as Stylesheet -import Com.MusicMeetsComics.Look.Typography as Typo -import qualified Data.Map as Map -import qualified Data.Text.Lazy as L -import Miso (Attribute, (=:), style_) -import Miso.String (MisoString, toMisoString) -import Protolude hiding ((**), (&), rem) - -main :: Css -main = do - -- bulma adjustments - input ? marginRight (px 10) <> marginBottom (px 10) - -- base - ".fixed" ? position fixed - ".clickable" ? clickable - ".row" ? do - display flex - alignItems center - justifyContent spaceBetween - a <> a # hover <> a # visited ? do - color white - textDecoration none - ".loading" ? do - display flex - justifyContent center - alignItems center - height $ vh 100 - width $ vw 100 - -- animations - ".grow" ? do - transition "all" (sec 0.2) easeInOut (sec 0.2) - ":hover" & transform (scale 1.1 1.1) - ".blur-out" ? do - position absolute - animation - "blur" - (sec 1) - easeInOut - (sec 1) - (iterationCount 1) - normal - forwards - keyframes "blur" [ (0, Clay.filter $ blur (px 0)) - , (50, Clay.filter $ blur (px 0)) - , (100, Clay.filter $ blur (px 10)) - ] - html <> body ? do - background nite - mobile $ do - overflowX hidden - width (vw 100) - -- general app wrapper stuf - ".app" ? do - display flex - justifyContent spaceBetween - alignItems stretch - flexDirection column - color white - "#hero-logo" ? zIndex (-1) - "#app-head" <> "#app-body" <> "#app-foot" ? flexGrow 1 - "#app-head" <> "#app-foot" ? do - display flex - alignItems center - flexShrink 0 - justifyContent spaceBetween - padding 0 (rem 2) 0 (rem 2) - width (pct 100) - height (px navbarHeight) - background nite - position fixed - zIndex 999 - "#app-head" ? do - alignSelf flexStart - borderBottom solid (px 3) grai - wide - top (px 0) - mobile $ noBorder <> width (vw 100) - "#app-body" ? do - display flex - desktop $ width (vw 93) - alignContent center - alignItems flexStart - justifyContent flexStart - flexDirection column - flexShrink 0 - padding (px 0) 0 0 0 - marginY $ px 74 - mobile $ flexDirection column - "#discover #app-body" ? do desktop $ marginLeft appmenuWidth - "#app-head-right" ? do - display flex - justifyContent spaceBetween - textTransform Clay.uppercase - thicc - alignItems center - width (px 200) - "#app-foot" ? do - alignSelf flexEnd - bottom (px 0) - mobile $ remove - "#app-foot-social" ? do - display flex - flexDirection column - alignSelf flexStart - ".social-icon" ? padding 0 (px 20) (px 10) 0 - "#app-foot-logo" ? do - display flex - flexDirection column - alignItems flexEnd - "#app-foot-quote" ? do - textTransform Clay.uppercase - textAlign center - -- hide app-foot-quote when it gets crowded - query Clay.all [Media.maxDeviceWidth (px 800)] $ - hide - - -- login - "#login" ? do - -- TODO: next 3 lines can be DRYed up, methinks - display flex - justifyContent center - alignItems center - alignSelf center - height (vh 100) - "#login-inner" ? do - display flex - justifyContent center - alignItems center - flexDirection column - zIndex 1 - height (vh 100) - width (px 400) - mobile $ width (vw 90) - "#login" ** ".help" ** a ? do - color white - display flex - alignItems center - flexDirection column - "#login" ** form <> "#login" ** hr ? do - width (pct 100) - "#login" ** hr ? border solid (px 1) grai - "#login" ** ".button" ? do - marginTop (px 10) - display inlineBlock - border solid (px 2) white - "#login" ** ".action" ? do - display flex - justifyContent spaceBetween - alignItems baseline - - -- choose your experience - "#choose-experience" ** "#app-body" ? do - euro <> wide - flexCenter - width (pct 100) - desktop $ marginLeft appmenuWidth <> height (vh 90) - mobile $ marginX (rem 0) <> marginTop (rem 0) <> minHeight (vh 90) - h2 ? do - thicc <> wide <> smol <> lower <> coat 2 - textAlign center - mobile $ coat 0.8 - p ? do - thicc <> coat 0.8 <> textAlign center - maxWidth (px 900) - marginAll (rem 1) - mobile $ coat 0.6 - ul ? do - display flex - flexDirection row - flexWrap Flexbox.wrap - justifyContent spaceAround - li ? do - width (px 111) - position relative - display flex - flexDirection column - textAlign center - mobile $ coat 0.6 - coat 0.8 <> clickable - divv thicc - - - - -- comic player - ".comic-player" ? marginAll auto - ".comic-page" <> ".comic-page-full" ? do - width auto - marginAll auto - transform (scale 1 1) - ".comic-page" ? height (vh 90) - let ccb = ".comic-controls" ** button - ccb <> ccb # hover ? do - background nite - borderColor nite - color white - ".comic-controls-pages" ? do - justifyContent center - alignItems center - display flex - ".comic-video" |> iframe ? do - position absolute - height (pct 93) - width (pct 100) - "#close-button" ? do - euro <> wide - position fixed - cursor pointer - let z = rem 1.8 - fontSize z - lineHeight z - let m = 24 :: Double - top $ px $ navbarHeight + m - left $ px $ m - zIndex 999 - - -- zoom button and slider - "#zoom-button" ? do - position relative - let sliderY = 75 - let sliderYY = 250 - euro <> wide - input ? do - transform $ Clay.rotate (deg (-90)) - margin 0 0 (px sliderYY) 0 - position absolute - height $ px sliderY - width $ px 200 - hide - label ? do - coat 0.9 - marginBottom $ px $ 2*sliderYY - position absolute - hide - ":hover" & ".ctrl" ? visibility visible - - -- discover - "#discover" ? do - alignItems flexStart - flexDirection column - ".media-info" ? do - padding (rem 2) 0 (rem 2) (rem 2) - margin (rem 2) 0 (rem 2) (rem 2) - borderTop solid (px 1) white - borderBottom solid (px 1) white - flexDirection row - display flex - alignItems center - justifyContent spaceBetween - mobile $ do - margin (rem 2) 0 (rem 2) 0 - padding 0 0 0 (rem 0) - noBorder - width (vw 100) - flexDirection column - ".media-info-meta" ? do - Flexbox.flex 2 1 (px 0) - display flex - flexDirection row - divv # lastChild wide - fontVariant smallCaps - position fixed - height (pct 100) - display flex - justifyContent center - zIndex 99 - alignContent center - alignItems center - flexDirection column - minWidth appmenuWidth - a ? do - display flex - flexDirection column - color white - background nite - borderColor nite - a |> img ? do - width (px 22) - height (px 22) - desktop $ a |> span ? remove - mobile $ do - order 2 - flexDirection row - position fixed - bottom (px 0) - width (vw 100) - height (px 74) - background nite - justifyContent center - alignItems center - a |> span ? fontSize (rem 0.5) - - button ? margin (rem 0.5) 0 (rem 0.5) 0 - - -- feature - "#featured-comic" ? do - display flex - flexDirection column - justifyContent center - Typo.euro - height (px 411) - mobile $ do - padding (px 0) 0 0 0 - margin 0 0 (px 50) 0 - after & do - display block - position relative - background $ linearGradient (straight sideTop) - [ (setA 0 nite, (pct 0)) - , (nite, (pct 100)) ] - let h = 149 - marginTop (px (-h)) - -- without +1, the gradient is offset by 1 px in chrome - height (px (h+1)) - content blank - ".hero-original" ? do - textTransform Clay.uppercase - fontSize (rem 1.2) - ".description" ? do - width (px 400) - mobile $ remove - "#featured-banner" ? do - position relative - minHeight (px 411) - minWidth (px 1214) - mobile $ marginLeft (px (-310)) - "#featured-content" ? do - position absolute - width (pct 100) - zIndex 9 - top (px 200) -- b/c Firefox & WebKit autocalc "top" differently - mobile $ do - marginTop (px 200) - alignItems center - display flex - flexDirection column - padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5) - width (vw 100) - - - -- buttons - "a.wrs-button" ? do -- the "watch/read/save" button - flexCenter - height (px 36) - width (px 132) - border solid (px 2) white - rounded - color white - margin 0 (px 15) (rem 1) 0 - fontSize (rem 0.8) - fontVariant smallCaps - euro <> thicc <> wide - mobile $ do - height (px 26) - width (px 100) - margin 0 (px 5) 0 (px 5) - fontSize (rem 0.6) - let alive = backgroundColor hero <> borderColor hero <> color white - ":hover" & alive - ".saved" & alive - img ? do - marginRight (px 7) - height (px 15) - mobile $ height (px 10) - - -- - ".comic-action-menu" ? display flex <> justifyContent (JustifyContentValue "left") - - -- shelving - ".shelf" ? do - display flex - flexDirection column - justifyContent flexStart - alignItems flexStart - mobile $ do - padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5) - width (vw 100) - ".comic" ? do - display flex - flexDirection column - justifyContent center - textAlign center - euro - maxWidth (px 110) - img ? do - marginBottom (rem 0.5) - minHeight (px 170) - minWidth (px 110) - ".shelf-head" ? do - width (pct 100) - margin (rem 1.5) 0 (rem 1.5) 0 - borderBottom solid (px 1) white - padding (rem 0.5) 0 0.5 0 - euro <> thicc - ".shelf-body" ? do - display flex - flexDirection row - justifyContent spaceBetween - width (vw 93) - alignItems baseline - li ? padding 0 (rem 0.5) 0 (rem 0.5) - overflowY visible - star ? overflowY visible - overflowX scroll - flexWrap Flexbox.nowrap - li Css -mobile = query Clay.all [Media.maxDeviceWidth (px 500)] - -desktop :: Css -> Css -desktop = query Clay.all [Media.minDeviceWidth (px 500)] - -rounded :: Css -rounded = borderRadius (px 30) (px 30) (px 30) (px 30) - -appmenuWidth :: Size LengthUnit -appmenuWidth = (px 67) - -flexCenter :: Css -flexCenter = do - display flex - justifyContent center - justifyItems center - alignContent center - alignItems center - -blank :: Content -blank = stringContent "" - -divv :: Clay.Selector -divv = Clay.div - -marginAll :: Size a -> Css -marginAll x = margin x x x x - -marginX :: Size a -> Css -marginX n = marginLeft n <> marginRight n - -marginY :: Size a -> Css -marginY n = marginTop n <> marginBottom n - -clickable :: Css -clickable = cursor pointer - --- heroic colors --------------------------------------------------------------- - -hero :: Color -hero = rgb 241 32 32 -- #f12020 - -nite :: Color -nite = rgb 10 10 10 -- #0a0a0a - -grai :: Color -grai = rgb 221 221 221 -- #dddddd - --- runtime (client) style stuff ------------------------------------------------ - --- | Put 'Clay.Css' into a Miso-compatible style property. --- --- Allows us to use any amount of CSS written with Clay inlined in HTML or --- dynamically as JavaScript object properties. The implementation is a bit --- hacky, but works. -css :: Clay.Css -> Attribute action -css = Miso.style_ . Map.fromList . f . Clay.renderWith Clay.htmlInline [] - where - f :: L.Text -> [(MisoString, MisoString)] - f t = L.splitOn ";" t - <&> L.splitOn ":" - <&> \(x:y) -> (toMisoString x, toMisoString $ L.intercalate ":" y) - -inlineCss :: Css -> MisoString -inlineCss = toMisoString . render - -type Style = Map MisoString MisoString - -red :: MisoString -red = "#f12020" - -bold :: Style -bold = "font-weight" =: "bold" - -condensed :: Style -condensed = "font-stretch" =: "condensed" - -expanded :: Style -expanded = "font-stretch" =: "expanded" - -uppercase :: Style -uppercase = "text-transform" =: "uppercase" - ---------------------------------------------------------------------------------- --- upstream this to Clay ---------------------------------------------------------------------------------- - - -newtype JustifyItemsValue = JustifyItemsValue Value - deriving (Val, Other, Inherit, Center, FlexEnd - , FlexStart, SpaceAround, SpaceBetween) - -justifyItems :: JustifyItemsValue -> Css -justifyItems = Stylesheet.key "justify-items" diff --git a/Com/MusicMeetsComics/Look/Typography.hs b/Com/MusicMeetsComics/Look/Typography.hs deleted file mode 100644 index 7f3b28d..0000000 --- a/Com/MusicMeetsComics/Look/Typography.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Com.MusicMeetsComics.Look.Typography where - -import Alpha -import Clay -import Clay.Stylesheet ( key ) -import qualified Com.MusicMeetsComics.Assets as Assets -import Data.Semigroup ( (<>) ) - -main :: Css -main = fonts - --- font modifiers - -euro, slim, wide, thicc, thinn, norm, lean, smol, lower, upper :: Css - -euro = fontFamily ["Eurostile"] [sansSerif] - --- | stretch -slim = fontStretch condensed -wide = fontStretch expanded - --- | weight -thicc = fontWeight bold -thinn = fontWeight normal - --- | style -norm = fontStyle normal -lean = fontStyle italic - --- | "smallcaps" is already taken by Clay -smol = fontVariant smallCaps - -lower = textTransform lowercase -upper = textTransform uppercase - --- | font sizing - --- | apparently "coat" is a synonym for "size" -coat :: Double -> Css -coat = fontSize . Clay.rem - -fontRoot :: Text -fontRoot = Assets.cdnEdge <> "/old-assets/fonts/eurostile/Eurostile" - --- | font faces -fonts :: Css -fonts = - mconcat - $ mkEuro - fontStyle normal) - , ("LTStd-Bold.otf" , OpenType, thicc <> norm) - , ("LTStd-Cn.otf" , OpenType, slim <> norm) - , ("LTStd-Ex2.otf" , OpenType, wide <> norm) - , ("LTStd-BoldCn.otf" , OpenType, slim <> thicc) - , ("LTStd-BoldEx2.otf", OpenType, wide <> thicc) - ] - where - mkEuro :: (Text, FontFaceFormat, Css) -> Css - mkEuro (sufx, fmt, extra) = fontFace $ do - fontFamily ["Eurostile"] [] - fontFaceSrc [FontFaceSrcUrl (fontRoot <> sufx) $ Just fmt] - extra - --- TODO: add the below to Clay.Font upstream - -newtype FontStretch = FontStretch Value - deriving (Val, Inherit, Normal, Other) - -expanded :: FontStretch -expanded = FontStretch "expanded" - -condensed :: FontStretch -condensed = FontStretch "condensed" - -fontStretch :: FontStretch -> Css -fontStretch = key "font-stretch" diff --git a/Com/MusicMeetsComics/Prod.nix b/Com/MusicMeetsComics/Prod.nix deleted file mode 100644 index 10650ee..0000000 --- a/Com/MusicMeetsComics/Prod.nix +++ /dev/null @@ -1,43 +0,0 @@ -{ config, pkgs, lib, ... }: -{ - imports = [ ]; - boot.loader.grub.device = "/dev/vda"; - fileSystems."/" = { device = "/dev/vda1"; fsType = "ext4"; }; - - services.herocomics = { - enable = true; - port = 3000; - server = pkgs.herocomics-server; - client = pkgs.herocomics-client; - }; - - networking = { - firewall.allowedTCPPorts = [ 22 80 443 ]; - nameservers = [ - "67.207.67.2" - "67.207.67.3" - ]; - defaultGateway = "138.68.40.1"; - defaultGateway6 = ""; - dhcpcd.enable = false; - usePredictableInterfaceNames = lib.mkForce true; - interfaces = { - eth0 = { - ipv4.addresses = [ - { address="138.68.40.97"; prefixLength=21; } - { address="10.46.0.5"; prefixLength=16; } - ]; - ipv6.addresses = [ - { address="fe80::b063:c4ff:fee5:d636"; prefixLength=64; } - ]; - ipv4.routes = [ { address = "138.68.40.1"; prefixLength = 32; } ]; - ipv6.routes = [ { address = ""; prefixLength = 32; } ]; - }; - - }; - }; - services.udev.extraRules = '' - ATTR{address}=="b2:63:c4:e5:d6:36", NAME="eth0" - - ''; -} diff --git a/Com/MusicMeetsComics/Server.hs b/Com/MusicMeetsComics/Server.hs deleted file mode 100644 index c173bd3..0000000 --- a/Com/MusicMeetsComics/Server.hs +++ /dev/null @@ -1,302 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} --- | Hero web app --- --- : exe mmc --- --- : dep aeson --- : dep clay --- : dep containers --- : dep dhall --- : dep envy --- : dep http-types --- : dep lucid --- : dep miso --- : dep mtl --- : dep network-uri --- : dep protolude --- : dep servant --- : dep servant-lucid --- : dep servant-server --- : dep split --- : dep split --- : dep string-quote --- : dep text --- : dep wai --- : dep wai-app-static --- : dep wai-extra --- : dep wai-middleware-metrics --- : dep warp -module Com.MusicMeetsComics.Server where - -import qualified Clay -import Com.MusicMeetsComics.App -import qualified Com.MusicMeetsComics.Assets as Assets -import qualified Com.MusicMeetsComics.Database as Database -import qualified Com.MusicMeetsComics.Look as Look -import qualified Com.MusicMeetsComics.Look.Typography - as Typography -import Data.Aeson -import Data.Proxy -import Data.Text ( Text ) -import qualified Data.Text.Lazy as Lazy -import qualified Data.Text.Lazy.Encoding as Lazy -import GHC.Generics -import qualified Lucid as L -import Lucid.Base -import Miso -import Miso.String -import Network.HTTP.Media ( (//) - , (/:) - ) -import Network.HTTP.Types hiding ( Header ) -import Network.Wai -import Network.Wai.Application.Static -import qualified Network.Wai.Handler.Warp as Warp -import Protolude -import Servant -import qualified System.Envy as Envy -import qualified System.Exit as Exit -import qualified System.IO as IO - - -main :: IO () -main = bracket startup shutdown $ uncurry Warp.run - where - say = IO.hPutStrLn IO.stderr - startup = Envy.decodeEnv >>= \case - Left e -> Exit.die e - Right c -> do - db <- Database.dummy - say $ "hero" - say $ "port: " ++ (show $ heroPort c) - say $ "client: " ++ heroClient c - let waiapp = app db c - return (heroPort c, waiapp) - shutdown :: a -> IO a - shutdown = pure . identity - -data Config = Config - { heroPort :: Warp.Port -- ^ HERO_PORT - , heroClient :: FilePath -- ^ HERO_CLIENT - } deriving (Generic, Show) - -instance Envy.DefConfig Config where - defConfig = Config 3000 "_bild/Com.MusicMeetsComics.Client/static" - -instance Envy.FromEnv Config - -app :: Database.ComicDB -> Config -> Application -app db cfg = serve - (Proxy @AllRoutes) - ( static - :<|> cssHandlers - :<|> jsonHandlers db - :<|> serverHandlers - :<|> pure heroManifest - :<|> Tagged handle404 - ) - where static = serveDirectoryWith $ defaultWebAppSettings $ heroClient cfg - - --- | HtmlPage for setting HTML doctype and header -newtype HtmlPage a = HtmlPage a - deriving (Show, Eq) - --- | Convert client side routes into server-side web handlers -type ServerRoutes = ToServerRoutes ClientRoutes HtmlPage Action - -type JsonApi = "api" :> "comic" :> Get '[JSON] [Comic] - -type CssRoute = "css" :> "main.css" :> Get '[CSS] Text - -newtype CSS = CSS - { unCSS :: Text - } - -instance Accept CSS where - contentType _ = "text" // "css" /: ("charset", "utf-8") - -instance MimeRender CSS Text where - mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict - -cssHandlers :: Server CssRoute -cssHandlers = - return . Lazy.toStrict . Clay.render $ Typography.main <> Look.main - -type AllRoutes - = ("static" :> Raw) - :<|> - CssRoute - :<|> - JsonApi - :<|> - ServerRoutes - :<|> - ("manifest.json" :> Get '[JSON] Manifest) - :<|> - Raw - -data Manifest = Manifest - { name :: Text - , short_name :: Text - , start_url :: Text - , display :: Text - , theme_color :: Text - , description :: Text - } deriving (Show, Eq, Generic) - -instance ToJSON Manifest - -heroManifest :: Manifest -heroManifest = Manifest { name = "Hero" - , short_name = "Hero" - , start_url = "." - , display = "standalone" - , theme_color = "#0a0a0a" - , description = "Comics for all" - } - -handle404 :: Application -handle404 _ respond = - respond - $ responseLBS status404 [("Content-Type", "text/html")] - $ renderBS - $ toHtml - $ HtmlPage - $ the404 - $ initModel homeLink - -instance L.ToHtml a => L.ToHtml (HtmlPage a) where - toHtmlRaw = L.toHtml - toHtml (HtmlPage x) = do - L.doctype_ - L.html_ [L.lang_ "en"] $ do - L.head_ $ do - L.title_ "Hero [alpha]" - L.link_ [L.rel_ "manifest", L.href_ "/manifest.json"] - L.link_ [L.rel_ "icon", L.type_ ""] - - -- icons - L.link_ - [ L.rel_ "apple-touch-icon" - , L.sizes_ "180x180" - , L.href_ - $ Assets.cdnEdge - <> "/old-assets/images/favicons/apple-touch-icon.png" - ] - L.link_ - [ L.rel_ "icon" - , L.type_ "image/png" - , L.sizes_ "32x32" - , L.href_ - $ Assets.cdnEdge - <> "/old-assets/images/favicons/favicon-32x32.png" - ] - L.link_ - [ L.rel_ "icon" - , L.type_ "image/png" - , L.sizes_ "16x16" - , L.href_ - $ Assets.cdnEdge - <> "/old-assets/images/favicons/favicon-16x16.png" - ] - L.link_ - [ L.rel_ "manifest" - , L.href_ - $ Assets.cdnEdge - <> "/old-assets/images/favicons/manifest.json" - ] - L.link_ - [ L.rel_ "mask-icon" - , L.href_ - $ Assets.cdnEdge - <> "/old-assets/images/favicons/safari-pinned-tab.svg" - ] - - L.meta_ [L.charset_ "utf-8"] - L.meta_ [L.name_ "theme-color", L.content_ "#000"] - L.meta_ [L.httpEquiv_ "X-UA-Compatible", L.content_ "IE=edge"] - L.meta_ - [L.name_ "viewport", L.content_ "width=device-width, initial-scale=1"] - cssRef animateRef - cssRef bulmaRef - cssRef fontAwesomeRef - cssRef "/css/main.css" -- TODO: make this a safeLink? - jsRef "/static/mmc.js" - jsRef "/static/usersnap.js" - L.body_ (L.toHtml x) - where - jsRef href = L.with - (L.script_ mempty) - [ makeAttribute "src" href - , makeAttribute "async" mempty - , makeAttribute "defer" mempty - ] - cssRef href = L.with - (L.link_ mempty) - [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href] - -fontAwesomeRef :: MisoString -fontAwesomeRef = "https://use.fontawesome.com/releases/v5.7.2/css/all.css" - -animateRef :: MisoString -animateRef = - "https://cdnjs.cloudflare.com/ajax/libs/animate.css/3.7.0/animate.min.css" - -bulmaRef :: MisoString -bulmaRef = - "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css" - -serverHandlers :: Server ServerRoutes -serverHandlers = - homeHandler - :<|> comicCoverHandler - :<|> comicPageHandler - :<|> comicPageFullHandler - :<|> comicVideoHandler - :<|> loginHandler - :<|> discoverHandler - :<|> chooseExperienceHandler - -jsonHandlers :: Database.ComicDB -> Server JsonApi -jsonHandlers db = Database.getComics db - -homeHandler :: Handler (HtmlPage (View Action)) -homeHandler = pure . HtmlPage . home $ initModel homeLink - -comicCoverHandler :: ComicId -> Handler (HtmlPage (View Action)) -comicCoverHandler id = - pure . HtmlPage . comicCover id . initModel $ comicLink id - -comicPageHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) -comicPageHandler id n = - pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerSpreadLink id n - -comicPageFullHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) -comicPageFullHandler id n = - pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerFullLink id n - -comicVideoHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) -comicVideoHandler id n = - pure . HtmlPage . comicPlayer id n . initModel $ comicVideoLink id n - -loginHandler :: Handler (HtmlPage (View Action)) -loginHandler = pure . HtmlPage . login $ initModel loginLink - -discoverHandler :: Handler (HtmlPage (View Action)) -discoverHandler = pure . HtmlPage . discover $ initModel discoverLink - -chooseExperienceHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) -chooseExperienceHandler id n = - pure . HtmlPage . comicPlayer id n . initModel $ chooseExperienceLink id n diff --git a/Com/MusicMeetsComics/Service.nix b/Com/MusicMeetsComics/Service.nix deleted file mode 100644 index f0f4227..0000000 --- a/Com/MusicMeetsComics/Service.nix +++ /dev/null @@ -1,76 +0,0 @@ -{ options -, lib -, config -, pkgs -, modulesPath -}: - -let - cfg = config.services.herocomics; -in -{ - options.services.herocomics = { - enable = lib.mkEnableOption "Enable the herocomics service"; - port = lib.mkOption { - type = lib.types.int; - default = 3000; - description = '' - The port on which herocomics-server will listen for incoming HTTP traffic. - ''; - }; - server = lib.mkOption { - type = lib.types.package; - description = "herocomics-server package to use"; - }; - client = lib.mkOption { - type = lib.types.package; - description = "herocomics-client package to use"; - }; - domain = lib.mkOption { - type = lib.types.str; - default = "herocomics.app"; - description = '' - Domain on which to bind herocomics-server. This is passed - to services.nginx.virtualHosts. directly. - ''; - }; - }; - config = lib.mkIf cfg.enable { - systemd.services.herocomics = { - path = [ cfg.server ]; - wantedBy = [ "multi-user.target" ]; - script = '' - ${cfg.server}/bin/mmc - ''; - description = '' - Hero Comics app server - ''; - serviceConfig = { - KillSignal = "INT"; - Environment = [ - "HERO_CLIENT=${cfg.client}/static" - "HERO_PORT=${toString cfg.port}" - ]; - Type = "simple"; - Restart = "on-abort"; - RestartSec = "1"; - }; - }; - services.nginx = { - enable = cfg.enable; - recommendedGzipSettings = true; - recommendedOptimisation = true; - recommendedProxySettings = true; - recommendedTlsSettings = true; - virtualHosts = { - "${cfg.domain}" = { - forceSSL = true; - enableACME = true; - locations."/" = { - proxyPass = "http://localhost:${toString cfg.port}"; - }; - }; - }; - }; - }; -} diff --git a/Com/Simatime/Bild.scm b/Com/Simatime/Bild.scm deleted file mode 100755 index 6b8c2ea..0000000 --- a/Com/Simatime/Bild.scm +++ /dev/null @@ -1,158 +0,0 @@ -;; -;; bild - a simple build tool -;; -;;; Notice: -;; -;; This is under active development. For now this is just a convenience wrapper -;; around `nix build`. The below commentary describes how this tool *should* -;; work. -;; -;;; Commentary: -;; -;; Design constraints -;; -;; - only input is a namespace, no subcommands, no packages -;; - no need to write specific build rules -;; - one rule for hs, one for rs, one for scm, and so on -;; - no need to distinguish between exe and lib, just have a single output -;; - never concerned with deployment/packaging - leave that to another tool (scp? tar?)) -;; -;; Features -;; -;; - namespace maps to filesystem -;; - no need for `bild -l` for listing available targets. Use `ls` or `tree` -;; - you build namespaces, not files/modules/packages/etc -;; - namespace maps to language modules -;; - build settings can be set in the file comments -;; - pwd is always considered the the source directory, no `src` vs `doc` etc. -;; - build methods automaticatly detected with file extensions -;; - flags modify the way to interact with the build -;; - -s = jump into a shell and/or repl -;; - -p = turn on profiling -;; - -t = limit build by type -;; - -e = exclude some regex in the ns tree -;; - -o = optimize level -;; -;; Example Commands -;; -;; bild [-rpt] -;; -;; The general scheme is to build the things described by the targets. A target -;; is a namespace. You can list as many as you want, but you must list at least -;; one. It could just be `.` for the current directory. Build outputs will go -;; into the _bild directory in the root of the project. -;; -;; bild biz.web -;; -;; Or `bild biz/web`. This shows building a file at ./biz/web.hs, this will -;; translate to something like `ghc --make Biz.Web`. -;; -;; bild -r -;; -;; Starts a repl/shell for target. -;; - if target.hs, load ghci -;; - if target.scm, load scheme repl -;; - if target.clj, load a clojure repl -;; - if target.nix, load nix-shell -;; - and so on. -;; -;; bild -p -;; -;; build target with profiling (if available) -;; -;; bild -t nix target -;; -;; only build target.nix, not target.hs and so on (in the case of multiple -;; targets with the same name but different extension). -;; -;; Here is an example integration with GHC. Given the following command-line -;; invocation to compile the namespace 'com.simatime.bild' which depends on -;; 'com.simatime.lib': -;; -;; ghc com/simatime/bild.hs -i com/simatime/lib.hs -o _bild/bild -v \ -;; -main-is Com.Simatime.Bild.main -;; -;; The general template of which is: -;; -;; ghc -i -o -main-is .main -;; -;; Some definitions: -;; -;; - is some source file -;; - is the stack of dependencies -;; - is the target namespace, indicated by 'bild ' -;; -;; To fill out the build template, we can parse the file for known -;; namespaces. The general recipe is: -;; -;; 1. Create a list of namespaces in my git repo. This can be cached, or I can -;; integrate with git somehow. -;; 2. Read the file corresponding to -;; 3. Look for 'import ', where is a namespace in the -;; aforementioned cache. -;; 4. If found, then save current build as a continuation and compile -;; . Result gets put on the dependency stack -;; 5. When finished, return to building -;; -;; Once the build command template is filled out, we can create the nix expression. -;; -;; Questions -;; -;; - how to import (third-party) dependencies? -;; 1 just don't have them...? yeah right -;; 2 the target.nix could be the build description for target.hs -;; 3 just use a default.nix for the com.whatever -;; 4 have a deps.nix file -;; 5 list them in the file with other settings. Starting with Haskell, -;; have comments like `{-: PACKAGE base <5.0.0.0 :-}' or `-- : PACKAGE base <5.0.0.0'. -;; Other languages could use `#:` for the special prefix, basically just -;; a comment plus colon. -;; - how to handle multiple output formats? -;; - e.g. that ghcjs and ghc take the same input files... -;; - say you have a .md file, you want to bild it to pdf, html, and more. What do? -;; - i guess the nix file could return a set of drvs instead of a single drv -;; -;; TODO -;; - stream output from 'nix build' subprocess -;; - get rid of guile notes during execution -;; - ns<->path macro -;; - support list (scheme namespace) in ns<->path fns -;; -;;; Code: - -(define-module (Com Simatime Bild) - #:use-module ((ice-9 popen) #:prefix popen/) - #:use-module ((ice-9 format) #:select (format)) - #:use-module ((ice-9 rdelim) #:prefix rdelim/) - #:use-module ((Com Simatime Core) #:select (fmt)) - #:use-module ((Com Simatime Shell) #:prefix sh/) - #:use-module ((Com Simatime String) #:prefix string/) - #:export (ns? - ns->path - path->ns - main)) - -(define (main args) - (let* ((root (sh/exec "git rev-parse --show-toplevel")) - (target (cadr args)) - (path (ns->path target))) - (display (fmt ":: bild ~a...\r" target)) - (sh/exec (fmt "nix build -f ~a/default.nix ~a" - root target)) - (display (fmt ":: bilt ~a" target)))) - -(define ns? symbol?) - -(define (ns->path ns) - (let ((to-path (lambda (s) (string/replace s #\. #\/)))) - (cond - ((symbol? ns) (to-path (symbol->string ns))) - ((string? ns) (to-path ns)) - (else (error "ns should be a string or symbol"))))) - -(define (path->ns path) - (let ((to-ns (lambda (s) (string/replace s #\/ #\.)))) - (cond - ((symbol? path) (to-ns (symbol->string path))) - ((string? path) (to-ns path)) - (else (error "path should be a string or symbol"))))) diff --git a/Com/Simatime/Cloud/chat.nix b/Com/Simatime/Cloud/chat.nix deleted file mode 100644 index e23b73e..0000000 --- a/Com/Simatime/Cloud/chat.nix +++ /dev/null @@ -1,100 +0,0 @@ -{ config, pkgs, ... }: -# -# a homeserver for matrix.org. -# -# - nixos manual: https://nixos.org/nixos/manual/index.html#module-services-matrix -# -# to create new users: -# -# nix run nixpkgs.matrix-synapse -# register_new_matrix_user -k http://localhost: -# -let - fqdn = "matrix.${config.networking.domain}"; - riot = "chat.${config.networking.domain}"; - matrix_port = 8448; -in { - # matrix-synapse server. for what the settings mean, see: - # https://nixos.org/nixos/manual/index.html#module-services-matrix - # - services.matrix-synapse = { - enable = true; - server_name = config.networking.domain; - registration_shared_secret = "AkGRWSQLga3RoKRFnHhKoeCEIeZzu31y4TRzMRkMyRbBnETkVTSxilf24qySLzQn"; - listeners = [ - { - port = matrix_port; - bind_address = "::1"; - type = "http"; - tls = false; - x_forwarded = true; - resources = [ - { - names = [ "client" "federation" ]; - compress = false; - } - ]; - } - ]; - }; - # matrix needs a database - # - services.postgresql.enable = true; - # web proxy for the matrix server - # - services.nginx = { - enable = true; - recommendedTlsSettings = true; - recommendedOptimisation = true; - recommendedGzipSettings = true; - recommendedProxySettings = true; - virtualHosts = { - # route to matrix-synapse - "${config.networking.domain}" = { - locations."= /.well-known/matrix/server".extraConfig = - let - server = { "m.server" = "${fqdn}:443"; }; - in '' - add_header Content-Type application/json; - return 200 '${builtins.toJSON server}'; - ''; - locations."= /.well-known/matrix/client".extraConfig = - let - client = { - "m.homeserver" = { "base_url" = "https://${fqdn}"; } ; - "m.identity_server" = { "base_url" = "https://vector.im"; }; - }; - in '' - add_header Content-Type application/json; - add_header Access-Control-Allow-Origin *; - return 200 '${builtins.toJSON client}'; - ''; - }; - # reverse proxy for matrix client-server and server-server communication - "${fqdn}" = { - enableACME = true; - forceSSL = true; - locations."/".extraConfig = '' - return 404; - ''; - locations."/_matrix" = { - proxyPass = "http://[::1]:${toString matrix_port}"; - }; - }; - }; - }; - # riot client, available at chat.simatime.com - # - # note that riot and matrix-synapse must be on separate fqdn's to - # protect from XSS attacks: - # https://github.com/vector-im/riot-web#important-security-note - # - services.nginx.virtualHosts."${riot}" = { - enableACME = true; - forceSSL = true; - serverAliases = [ - "chat.${config.networking.domain}" - ]; - root = pkgs.riot-web; - }; -} diff --git a/Com/Simatime/Cloud/git.nix b/Com/Simatime/Cloud/git.nix deleted file mode 100644 index 370f52a..0000000 --- a/Com/Simatime/Cloud/git.nix +++ /dev/null @@ -1,17 +0,0 @@ -{ pkgs, ... }: - -{ - services = { - gitolite = { - enable = true; - enableGitAnnex = true; - dataDir = "/srv/git"; - user = "git"; - group = "git"; - extraGitoliteRc = '' - $RC{SITE_INFO} = 'a computer is a bicycle for the mind.'; - ''; - adminPubkey = builtins.readFile ../keys/ben.pub; - }; - }; -} diff --git a/Com/Simatime/Cloud/hardware.nix b/Com/Simatime/Cloud/hardware.nix deleted file mode 100644 index 8c88cb7..0000000 --- a/Com/Simatime/Cloud/hardware.nix +++ /dev/null @@ -1,6 +0,0 @@ -{ ... }: -{ - imports = [ ]; - boot.loader.grub.device = "/dev/vda"; - fileSystems."/" = { device = "/dev/vda1"; fsType = "ext4"; }; -} diff --git a/Com/Simatime/Cloud/mail.nix b/Com/Simatime/Cloud/mail.nix deleted file mode 100644 index 81bddc2..0000000 --- a/Com/Simatime/Cloud/mail.nix +++ /dev/null @@ -1,43 +0,0 @@ -{ ... }: - -{ - mailserver = { - enable = true; - monitoring = { - enable = false; - alertAddress = "bsima@me.com"; - }; - fqdn = "simatime.com"; - domains = [ "simatime.com" "bsima.me" ]; - certificateScheme = 3; # let's encrypt - enableImap = true; - enablePop3 = true; - enableImapSsl = true; - enablePop3Ssl = true; - enableManageSieve = true; - virusScanning = false; # ur on ur own - localDnsResolver = true; - - loginAccounts = { - "ben@simatime.com" = { - hashedPassword = "$6$Xr180W0PqprtaFB0$9S/Ug1Yz11CaWO7UdVJxQLZWfRUE3/rarB0driXkXALugEeQDLIjG2STGQBLU23//JtK3Mz8Kwsvg1/Zo0vD2/"; - aliases = [ - # my default email - "ben@bsima.me" - # admin stuff - "postmaster@simatime.com" - "abuse@simatime.com" - ]; - catchAll = [ "simatime.com" "bsima.me" ]; - quota = "5G"; - }; - "nick@simatime.com" = { - hashedPassword = "$6$31P/Mg8k8Pezy1e$Fn1tDyssf.1EgxmLYFsQpSq6RP4wbEvP/UlBlXQhyKA9FnmFtJteXsbJM1naa8Kyylo8vZM9zmeoSthHS1slA1"; - aliases = [ - "nicolai@simatime.com" - ]; - quota = "1G"; - }; - }; - }; -} diff --git a/Com/Simatime/Cloud/networking.nix b/Com/Simatime/Cloud/networking.nix deleted file mode 100644 index d943c13..0000000 --- a/Com/Simatime/Cloud/networking.nix +++ /dev/null @@ -1,36 +0,0 @@ -{ lib, config, ... }: - -{ - networking = { - - firewall = { - allowedTCPPorts = [ 22 80 443 ]; - }; - - # This following was populated at runtime with the networking details - # gathered from the active system. - nameservers = [ - "67.207.67.2" - "67.207.67.3" - ]; - defaultGateway = "159.89.128.1"; - defaultGateway6 = "2604:a880:2:d0::1"; - dhcpcd.enable = false; - usePredictableInterfaceNames = lib.mkForce true; - interfaces = { - eth0 = { - ipv4.addresses = [ - { address="159.89.128.69"; prefixLength=20; } - { address="10.46.0.6"; prefixLength=16; } - ]; - ipv6.addresses = [ - { address="2604:a880:2:d0::35:c001"; prefixLength = 64; } - { address="fe80::e899:c0ff:fe9c:e194"; prefixLength = 64; } - ]; - }; - }; - }; - services.udev.extraRules = '' - ATTR{address}=="ea:99:c0:9c:e1:94", NAME="eth0" - ''; -} diff --git a/Com/Simatime/Cloud/web.nix b/Com/Simatime/Cloud/web.nix deleted file mode 100644 index 22d7199..0000000 --- a/Com/Simatime/Cloud/web.nix +++ /dev/null @@ -1,41 +0,0 @@ -{ ... }: - -let - bensIp = "73.222.221.62"; -in -{ - services = { - nginx = { - enable = true; - recommendedGzipSettings = true; - recommendedOptimisation = true; - recommendedProxySettings = true; - recommendedTlsSettings = true; - virtualHosts = { - "bsima.me".root = "/home/ben/public_html/"; - "www.bsima.me".root = "/home/ben/public_html/"; - "simatime.com".locations."/".root = "/srv/www/"; - "firefoxsync.simatime.com".locations."/".proxyPass = "http://localhost:5001"; - "hero.simatime.com".locations."/".proxyPass = "http://${bensIp}:3001"; - "tv.simatime.com".locations."/".proxyPass = "http://${bensIp}:8096"; # emby runs on port 8096 - "deluge.simatime.com".locations."/".proxyPass = "http://${bensIp}:8112"; - - "notebook.simatime.com".locations = { - "/" = { - proxyPass = "http://${bensIp}:3099"; - proxyWebsockets = true; - extraConfig = '' - proxy_buffering off; - proxy_read_timeout 86400; - - ''; - }; - "/(api/kernels/[^/]+/channels|terminals/websocket)/" = { - proxyPass = "http://${bensIp}:3099"; - proxyWebsockets = true; - }; - }; - }; - }; - }; -} diff --git a/Com/Simatime/Cloud/znc.nix b/Com/Simatime/Cloud/znc.nix deleted file mode 100644 index 9b1a28d..0000000 --- a/Com/Simatime/Cloud/znc.nix +++ /dev/null @@ -1,66 +0,0 @@ -/* - -N.B.: generate znc passwords with 'nix-shell -p znc --command "znc --makepass"' - -- https://wiki.znc.in/Configuration - -*/ - -{ ... }: - -{ - services = { - znc = { - enable = true; - mutable = false; - useLegacyConfig = false; - openFirewall = true; - config = { - LoadModule = [ "adminlog" ]; - User.bsima = { - Admin = true; - Nick = "bsima"; - AltNick = "bsima1"; - LoadModule = [ "chansaver" "controlpanel" "log" ]; - Network.freenode = { - Server = "chat.freenode.net +6697"; - LoadModule = [ "simple_away" "nickserv" "sasl" ]; - Chan = { - "#ai" = {}; - "#biz" = { Modes = "+Sp"; }; - "#bsima" = { Modes = "+Sp"; }; - "##categorytheory" = { Detached = true; }; - "#clojure" = { Detached = true; }; - "#coq" = { Detached = true; }; - "#emacs" = { Detached = true; }; - "#guile" = { Detached = true; }; - "#guix" = { Detached = true; }; - "#haskell" = {}; - "#haskell-miso" = { Detached = true; }; - "#hledger" = {}; - "#hnix" = { Detached = true; }; - "#home-manager" = { Detached = true; }; - "#ledger" = {}; - "#nix-darwin" = { Detached = true; }; - "#nixos" = {}; - "#org-mode" = {}; - "#scheme" = { Detached = true; }; - "#servant" = { Detached = true; }; - "#sr.ht" = { Detached = true; }; - "#xmonad" = { Detached = true; }; - }; - }; - Network.efnet = { - Server = "irc.efnet.info +6697"; - LoadModule = [ "simple_away" ]; - }; - Pass.password = { - Method = "sha256"; - Hash = "bead16d806e7bf5cbbc31d572b20f01e2b253eb60e2497ce465df56306becd02"; - Salt = "/GhmBMc+E6b7qd8muFEe"; - }; - }; - }; - }; - }; -} diff --git a/Com/Simatime/Core.scm b/Com/Simatime/Core.scm deleted file mode 100644 index 83ded5d..0000000 --- a/Com/Simatime/Core.scm +++ /dev/null @@ -1,158 +0,0 @@ -(define-module (Com Simatime Core) - #:use-module ((ice-9 format)) - #:export ( - ;; simple printing - fmt printf pr prn - - ;; navigating data - first next second rest - - ;; booleans - true? false? nil nil? - - ;; dev helpers - comment - )) - -(define (flip f) (lambda (x y) (f y x))) -(define (curry f a) (lambda (b) (apply f (cons a (list b))))) -(define pos? - (curry < 0)) - -(define neg? - (curry > 0)) - -(define (foldr f end lst) - (if (null? lst) - end - (f (car lst) (foldr f end (cdr lst))))) - -(define (foldl f acc lst) - (if (null? lst) - acc - (foldl f (f acc (car lst)) (cdr lst)))) - -(define fold foldl) - -(define (unfold f init pred) - (if (pred init) - (cons init '()) - (cons init (unfold f (f init) pred)))) - -(define (sum lst) (fold + 0 lst)) -(define (produce lst) (fold * 1 lst)) - -(define count length) - - -;; -;; clojure-like stuff -;; - -(define (pr . a) - (for-each display a)) - -(define (prn . a) (apply pr a) (newline)) - -(define (first a) - "Return the first item in the collection." - (car a)) - -(define (rest a) - "Returns a list of the items after the first." - (cdr a)) - -(define (next a) - "Returns the next item after the first." - (cadr a)) - -;; same thing, easier to remember/read -(define second next) - -(define (ffirst a) - (first (first a))) - -(define (nnext a) - (next (next a))) - -(define (last coll) - "Return the last time in coll, in linear time." - (if (next coll) - (last coll) - (first coll))) - -(define (butlast ls) - "Return everthing execpt the last element in ls." - (let ((len (length ls))) - (list-head ls (- len 1)))) - -(define (false? x) - (eq? #f x)) - -(define (true? x) - (eq? #t x)) - -(define nil #nil) - -(define (nil? x) - (eq? nil x)) - -;; Ignores body, returns nil. -(define-syntax comment - (syntax-rules () - ((_ ...) nil))) - -(comment - ;; nil is different from null. nil is supposed to be more like - ;; 'Nothing' in Haskell, it is the absence of any value or type; - ;; whereas null is specifically the empty list, which still has a type - ;; of 'list'. - (null? '()) ;; => #t - (nil? '()) ;; => #f - ) - -(define (some pred coll) - (or (pred (first coll)) - (some pred (next coll)))) - -(define comp compose) - -(define (not-any? pred coll) - (comp not some)) - -(define (printf . args) - (display (apply format args))) - -(define-syntax fmt - (syntax-rules () - ((_ s args ...) - (format #f s args ...)))) - -;; If I implement ML-like interface abstractions in scheme, what would it look like? - -;; -;; ;; seq - -;; (define-class () (_first)) - -;; -;; ;; Functor - -;; (define-class ()) - -;; (define-method (fmap (f ) (coll ))) - -;; -;; ;; Applicative - -;; ;; a -> f a -;; (define-method (pure (a ))) - -;; ;; f (a -> b) -> f a -> f b -;; (define-method (<*> (f ) (a ) (b ))) - -;; ;; f a -> f b -> f b -;; (define-method (*> (a ) (b ))) - -;; ;; f a -> f b -> f a -;; (define-method (<* (a ) (b ))) diff --git a/Com/Simatime/Dev/configuration.nix b/Com/Simatime/Dev/configuration.nix deleted file mode 100644 index 4a8839e..0000000 --- a/Com/Simatime/Dev/configuration.nix +++ /dev/null @@ -1,205 +0,0 @@ -{ config, lib, pkgs, ... }: - -let - murmurPort = 64738; - torrents = { from = 6000; to = 6999; }; -in { - networking = { - hosts = { - "::1" = [ "localhost" "ipv6-localhost" "ipv6-loopback" ]; - }; - - firewall = { - allowedTCPPorts = [ - 22 8000 8443 443 8080 8081 # standard ports - 500 10000 # no idea - 8096 # emby/jellyfin - 8112 # deluge - murmurPort - ]; - allowedTCPPortRanges = [ - { from = 3000; to = 3100; } # dev stuff - torrents - ]; - allowedUDPPorts = [ murmurPort ]; - allowedUDPPortRanges = [ - torrents - ]; - checkReversePath = false; - }; - - }; - - # Use the systemd-boot EFI boot loader. - boot.loader.systemd-boot.enable = true; - boot.loader.efi.canTouchEfiVariables = true; - boot.enableContainers = true; - - boot.initrd.luks.devices = { - root = { - device = "/dev/disk/by-uuid/a0160f25-e0e3-4af0-8236-3e298eac957a"; - preLVM = true; - }; - }; - - powerManagement.enable = false; - - time.timeZone = "America/Los_Angeles"; - - fonts.fonts = with pkgs; [ - google-fonts mononoki source-code-pro fantasque-sans-mono hack-font - fira fira-code fira-code-symbols - ]; - - environment.systemPackages = [ pkgs.wemux pkgs.tmux ]; - - nixpkgs = { - config = { - allowUnfree = true; - allowBroken = true; - }; - }; - - hardware = { - opengl.enable = true; - pulseaudio = { - enable = true; - extraConfig = '' - load-module module-loopback - ''; - }; - }; - - programs = { - bash.enableCompletion = true; - command-not-found.enable = true; - gnupg.agent = { - enable = true; - enableSSHSupport = true; - }; - mosh.enable = true; - }; - - virtualisation = { - docker = { - enable = true; - liveRestore = false; - }; - libvirtd.enable = true; - virtualbox = { - host = { - enable = false; - headless = false; - addNetworkInterface = false; - }; - guest = { - enable = false; - x11 = false; - }; - }; - }; - - services = { - pcscd.enable = true; - logind = { - lidSwitch = "ignore"; - extraConfig = "IdleAction=ignore"; - }; - - deluge = { - enable = true; - openFilesLimit = 10240; - web.enable = true; - }; - - printing.enable = true; - - murmur = { - enable = true; - registerName = "simatime"; - password = "simatime"; - port = murmurPort; - }; - - xserver = { - enable = true; - layout = "us"; - xkbOptions = "caps:ctrl_modifier"; - displayManager.sddm.enable = true; - desktopManager = { - kodi.enable = true; - plasma5.enable = true; - xterm.enable = true; - }; - }; - - jupyter = { - enable = false; - port = 3099; - ip = "*"; - password = "'sha1:4b14a407cabe:fbab8e5400f3f4f3ffbdb00e996190d6a84bf51e'"; - kernels = { - python3 = let - env = (pkgs.python3.withPackages (p: with p; [ - ipykernel pandas scikitlearn numpy matplotlib sympy ipywidgets - ])); - in { - displayName = "py3"; - argv = [ - "${env.interpreter}" - "-m" - "ipykernel_launcher" - "-f" - "{connection_file}" - ]; - language = "python"; - #logo32 = "${env.sitePackages}/lib/python3.6/site-packages/ipykernel/resources/logo-32x32.png"; - #logo64 = "${env.sitePackages}/lib/python3.6/site-packages/ipykernel/resources/logo-64x64.png"; - }; - }; - }; - - jellyfin = { # previously emby - enable = true; - user = "jellyfin"; - group = "jellyfin"; - }; - - vnstat.enable = true; - - postgresql = { - enable = true; - package = pkgs.postgresql_10; - authentication = '' - local all pprjam md5 - local all pprjam_test md5 - ''; - enableTCPIP = true; - }; - redis = { - enable = true; - }; - }; - - documentation = { - enable = true; - dev.enable = true; - doc.enable = true; - info.enable = true; - man.enable = true; - nixos.enable = true; - }; - - # Since this is the dev machine, we can turn these on at the expense of extra - # disk space. - nix.extraOptions = '' - keep-outputs = true - keep-derivations = true - ''; - - # This value determines the NixOS release with which your system is to be - # compatible, in order to avoid breaking some software such as database - # servers. You should change this only after NixOS release notes say you - # should. - system.stateVersion = "17.09"; # Did you read the comment? -} diff --git a/Com/Simatime/Dev/hardware.nix b/Com/Simatime/Dev/hardware.nix deleted file mode 100644 index fc0e7a0..0000000 --- a/Com/Simatime/Dev/hardware.nix +++ /dev/null @@ -1,34 +0,0 @@ -# Do not modify this file! It was generated by ‘nixos-generate-config’ -# and may be overwritten by future invocations. Please make changes -# to /etc/nixos/configuration.nix instead. -{ config, lib, pkgs, ... }: - -{ - imports = - [ - ]; - - boot.initrd.availableKernelModules = [ "xhci_pci" "ahci" "usbhid" "sd_mod" ]; - boot.kernelModules = [ "kvm-intel" ]; - boot.extraModulePackages = [ ]; - - fileSystems."/" = - { device = "/dev/disk/by-uuid/0d8b0e52-10de-4af2-bcd9-b36278352e77"; - fsType = "ext4"; - }; - - fileSystems."/boot" = - { device = "/dev/disk/by-uuid/9B89-85C7"; - fsType = "vfat"; - }; - - fileSystems."/mnt/lake" = - { device = "/dev/disk/by-uuid/037df3ae-4609-402c-ab1d-4593190d0ee7"; - fsType = "ext4"; - }; - - swapDevices = [ ]; - - nix.maxJobs = lib.mkDefault 4; - powerManagement.cpuFreqGovernor = "powersave"; -} diff --git a/Com/Simatime/Language/Bs.hs b/Com/Simatime/Language/Bs.hs deleted file mode 100644 index a810706..0000000 --- a/Com/Simatime/Language/Bs.hs +++ /dev/null @@ -1,12 +0,0 @@ --- https://github.com/write-you-a-scheme-v2/scheme --- https://github.com/justinethier/husk-scheme -module Language.Bs - ( module X - ) where - -import Language.Bs.Cli as X -import Language.Bs.Eval as X -import Language.Bs.Expr as X -import Language.Bs.Parser as X -import Language.Bs.Primitives as X -import Language.Bs.Repl as X diff --git a/Com/Simatime/Language/Bs/Cli.hs b/Com/Simatime/Language/Bs/Cli.hs deleted file mode 100644 index 4c48c86..0000000 --- a/Com/Simatime/Language/Bs/Cli.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Language.Bs.Cli ( - run -) where - -import Data.String -import Data.Text.IO as TIO -import Language.Bs.Eval -- evalFile :: T.Text -> IO () -import Language.Bs.Repl -- Repl.mainLoop :: IO () -import Options.Applicative -import Protolude -import System.Directory - --- SOURCES ---http://book.realworldhaskell.org/read/io.html --- https://github.com/pcapriotti/optparse-applicative --- https://hackage.haskell.org/package/optparse-applicative - -runScript :: FilePath -> IO () -runScript fname = do - exists <- doesFileExist fname - if exists - then TIO.readFile fname >>= evalFile fname - else TIO.putStrLn "File does not exist." - -data LineOpts = UseReplLineOpts | RunScriptLineOpts String - -parseLineOpts :: Parser LineOpts -parseLineOpts = runScriptOpt <|> runReplOpt - where - runScriptOpt = - RunScriptLineOpts <$> strOption (long "script" - <> short 's' - <> metavar "SCRIPT" - <> help "File containing the script you want to run") - runReplOpt = - UseReplLineOpts <$ flag' () (long "repl" - <> short 'r' - <> help "Run as interavtive read/evaluate/print/loop") - -schemeEntryPoint :: LineOpts -> IO () -schemeEntryPoint UseReplLineOpts = mainLoop --repl -schemeEntryPoint (RunScriptLineOpts script) = runScript script - -run :: IO () -run = execParser opts >>= schemeEntryPoint - where - opts = info (helper <*> parseLineOpts) - ( fullDesc - <> header "Executable binary for Write You A Scheme v2.0" - <> progDesc "contains an entry point for both running scripts and repl" ) diff --git a/Com/Simatime/Language/Bs/Eval.hs b/Com/Simatime/Language/Bs/Eval.hs deleted file mode 100644 index 290170b..0000000 --- a/Com/Simatime/Language/Bs/Eval.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Language.Bs.Eval ( - evalText -, evalFile -, runParseTest -, safeExec -, runASTinEnv -, basicEnv -, fileToEvalForm -, textToEvalForm -, getFileContents -) where - -import Control.Exception -import Control.Monad.Reader -import qualified Data.Map as Map -import Data.String -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import Language.Bs.Expr -import Language.Bs.Parser -import Language.Bs.Primitives -import Protolude -import System.Directory - -funcEnv :: Map.Map T.Text Expr -funcEnv = Map.fromList $ primEnv - <> [ ("read" , IFun $ IFunc $ unop readFn) - , ("parse", IFun $ IFunc $ unop parseFn) - , ("eval", IFun $ IFunc $ unop eval) - , ("show", IFun $ IFunc $ unop (return . Tape . ppexpr)) - ] - -basicEnv :: Env -basicEnv = Env Map.empty funcEnv - -readFn :: Expr -> Eval Expr -readFn (Tape txt) = lineToEvalForm txt -readFn val = throw $ TypeMismatch "read expects string, instead got:" val - -parseFn :: Expr -> Eval Expr -parseFn (Tape txt) = either (throw . ParseError . show) return $ readExpr txt -parseFn val = throw $ TypeMismatch "parse expects string, instead got:" val - -safeExec :: IO a -> IO (Either String a) -safeExec m = do - result <- Control.Exception.try m - case result of - Left (eTop :: SomeException) -> - case fromException eTop of - Just (enclosed :: LispError) -> - return $ Left (show enclosed) - Nothing -> - return $ Left (show eTop) - Right val -> - return $ Right val - -runASTinEnv :: Env -> Eval b -> IO b -runASTinEnv code action = runReaderT (unEval action) code - -lineToEvalForm :: T.Text -> Eval Expr -lineToEvalForm input = either (throw . ParseError . show ) eval $ readExpr input - -evalFile :: FilePath -> T.Text -> IO () -- program file -evalFile filePath fileExpr = (runASTinEnv basicEnv $ fileToEvalForm filePath fileExpr) >>= print - -fileToEvalForm :: FilePath -> T.Text -> Eval Expr -fileToEvalForm filePath input = either (throw . ParseError . show ) evalBody $ readExprFile filePath input - -runParseTest :: T.Text -> T.Text -- for view AST -runParseTest input = either (T.pack . show) (T.pack . show) $ readExpr input - -getFileContents :: FilePath -> IO T.Text -getFileContents fname = do - exists <- doesFileExist fname - if exists then TIO.readFile fname else return "File does not exist." - -textToEvalForm :: T.Text -> Eval Expr -textToEvalForm input = either (throw . ParseError . show ) evalBody $ readExpr input - -evalText :: T.Text -> IO () --REPL -evalText textExpr = do - res <- runASTinEnv basicEnv $ textToEvalForm textExpr - print res - -getVar :: Expr -> Eval Expr -getVar (Atom atom) = do - Env{..} <- ask - case Map.lookup atom (Map.union fenv env) of -- lookup, but prefer functions - Just x -> return x - Nothing -> throw $ UnboundVar atom -getVar n = throw $ TypeMismatch "failure to get variable: " n - -ensureAtom :: Expr -> Eval Expr -ensureAtom n@(Atom _) = return n -ensureAtom n@(List _) = throw $ TypeMismatch "got list" n -ensureAtom n = throw $ TypeMismatch "expected an atomic value" n - -extractVar :: Expr -> T.Text -extractVar (Atom atom) = atom -extractVar n = throw $ TypeMismatch "expected an atomic value" n - -getEven :: [t] -> [t] -getEven [] = [] -getEven (x:xs) = x : getOdd xs - -getOdd :: [t] -> [t] -getOdd [] = [] -getOdd (_:xs) = getEven xs - -applyFunc :: Expr -> [Expr] -> [Expr] -> Eval Expr -applyFunc expr params args = bindArgsEval params args expr - -bindArgsEval :: [Expr] -> [Expr] -> Expr -> Eval Expr -bindArgsEval params args expr = do - Env{..} <- ask - let newVars = zipWith (\a b -> (extractVar a,b)) params args - let (newEnv, newFenv) = Map.partition (not . isFunc) $ Map.fromList newVars - local (const $ Env (newEnv <> env) (newFenv <> fenv)) $ eval expr - -isFunc :: Expr -> Bool -isFunc (List ((Atom "lambda"):_)) = True -isFunc _ = False - -eval :: Expr -> Eval Expr -eval (List [Atom "dumpEnv", x]) = do - Env{..} <- ask - liftIO $ print $ toList env - liftIO $ print $ toList fenv - eval x - -eval (Numb i) = return $ Numb i -eval (Tape s) = return $ Tape s -eval (Bool b) = return $ Bool b -eval (List []) = return Nil -eval Nil = return Nil -eval n@(Atom _) = getVar n - -eval (List [Atom "showSF", rest]) = return . Tape . T.pack $ show rest -eval (List ((:) (Atom "showSF") rest)) = return . Tape . T.pack . show $ List rest - -eval (List [Atom "quote", val]) = return val - -eval (List [Atom "if", pred_, then_, else_]) = do - ifRes <- eval pred_ - case ifRes of - (Bool True) -> eval then_ - (Bool False) -> eval else_ - _ -> - throw $ BadSpecialForm "if's first arg must eval into a boolean" -eval (List ( (:) (Atom "if") _)) = - throw $ BadSpecialForm "(if )" - -eval (List [Atom "begin", rest]) = evalBody rest -eval (List ((:) (Atom "begin") rest )) = evalBody $ List rest - --- top-level define --- TODO: how to make this eval correctly? -eval (List [Atom "define", List (name:args), body]) = do - Env{..} <- ask - _ <- eval body - bindArgsEval (name:args) [body] name - -eval (List [Atom "define", name, body]) = do - Env{..} <- ask - _ <- eval body - bindArgsEval [name] [body] name - -eval (List [Atom "let", List pairs, expr]) = do - Env{..} <- ask - atoms <- mapM ensureAtom $ getEven pairs - vals <- mapM eval $ getOdd pairs - bindArgsEval atoms vals expr - -eval (List (Atom "let":_) ) = - throw $ BadSpecialForm "let function expects list of parameters and S-Expression body\n(let )" - - -eval (List [Atom "lambda", List params, expr]) = do - ctx <- ask - return $ Func (IFunc $ applyFunc expr params) ctx -eval (List (Atom "lambda":_) ) = throw $ BadSpecialForm "lambda function expects list of parameters and S-Expression body\n(lambda )" - - --- needed to get cadr, etc to work -eval (List [Atom "cdr", List [Atom "quote", List (_:xs)]]) = - return $ List xs -eval (List [Atom "cdr", arg@(List (x:xs))]) = - case x of - -- proxy for if the list can be evaluated - Atom _ -> do - val <- eval arg - eval $ List [Atom "cdr", val] - _ -> return $ List xs - - -eval (List [Atom "car", List [Atom "quote", List (x:_)]]) = - return $ x -eval (List [Atom "car", arg@(List (x:_))]) = - case x of - Atom _ -> do - val <- eval arg - eval $ List [Atom "car", val] - _ -> return $ x - - -eval (List ((:) x xs)) = do - Env{..} <- ask - funVar <- eval x - xVal <- mapM eval xs - case funVar of - (IFun (IFunc internalFn)) -> - internalFn xVal - - (Func (IFunc definedFn) (Env benv _)) -> - local (const $ Env benv fenv) $ definedFn xVal - - _ -> - throw $ NotFunction funVar - -updateEnv :: T.Text -> Expr -> Env -> Env -updateEnv var e@(IFun _) Env{..} = Env env $ Map.insert var e fenv -updateEnv var e@(Func _ _) Env{..} = Env env $ Map.insert var e fenv -updateEnv var e Env{..} = Env (Map.insert var e env) fenv - -evalBody :: Expr -> Eval Expr -evalBody (List [List ((:) (Atom "define") [Atom var, defExpr]), rest]) = do - evalVal <- eval defExpr - ctx <- ask - local (const $ updateEnv var evalVal ctx) $ eval rest - -evalBody (List ((:) (List ((:) (Atom "define") [Atom var, defExpr])) rest)) = do - evalVal <- eval defExpr - ctx <- ask - local (const $ updateEnv var evalVal ctx) $ evalBody $ List rest - -evalBody x = eval x diff --git a/Com/Simatime/Language/Bs/Expr.hs b/Com/Simatime/Language/Bs/Expr.hs deleted file mode 100644 index a39c7b6..0000000 --- a/Com/Simatime/Language/Bs/Expr.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Language.Bs.Expr where - -import Data.String (String) -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Show -import Protolude hiding (show) -import qualified Text.PrettyPrint.Leijen.Text as PP -import Text.PrettyPrint.Leijen.Text hiding ((<$>)) - -type Ctx = Map Text Expr -data Env = Env { env :: Ctx, fenv :: Ctx } - deriving (Eq) - -newtype Eval a = Eval { unEval :: ReaderT Env IO a } - deriving (Monad, Functor, Applicative, MonadReader Env, MonadIO) - -data IFunc = IFunc { fn :: [Expr] -> Eval Expr } - deriving (Typeable) - -instance Eq IFunc where - (==) _ _ = False - -data Expr - = Atom Text - | List [Expr] - | Numb Integer - | Tape Text - | IFun IFunc -- TODO: call this Kern - | Func IFunc Env - | Bool Bool - | Nil - deriving (Typeable, Eq) - -instance Show Expr where - show = T.unpack . ppexpr - -data LispErrorType - = NumArgs Integer [Expr] - | LengthOfList Text Int - | ExpectedList Text - | ParseError String - | TypeMismatch Text Expr - | BadSpecialForm Text - | NotFunction Expr - | UnboundVar Text - | Default Expr - | ReadFileError Text - deriving (Typeable) - -data LispError = LispError Expr LispErrorType - -instance Show LispErrorType where - show = T.unpack . ppexpr - -instance Show LispError where - show = T.unpack . ppexpr - -instance Exception LispErrorType -instance Exception LispError - -ppexpr :: Pretty a => a -> Text -ppexpr x = PP.displayTStrict (PP.renderPretty 1.0 70 (pretty x)) - ---prettyList :: [Doc] -> Doc ---prettyList = encloseSep lparen rparen PP.space - -instance Pretty Expr where - pretty v = - case v of - Atom a -> - textStrict a - - List ls -> - prettyList $ fmap pretty ls - - Numb n -> - integer n - - Tape t -> - textStrict "\"" <> textStrict t <> textStrict "\"" - - IFun _ -> - textStrict "" - - Func _ _ -> - textStrict "" - - Bool True -> - textStrict "#t" - - Bool False -> - textStrict "#f" - - Nil -> - textStrict "'()" - -instance Pretty LispErrorType where - pretty err = case err of - NumArgs i args -> - textStrict "number of arguments" - <$$> textStrict "expected" - <+> textStrict (T.pack $ show i) - <$$> textStrict "received" - <+> textStrict (T.pack $ show $ length args) - - - LengthOfList txt i -> - textStrict "length of list in:" - <+> textStrict txt - <$$> textStrict "length:" - <+> textStrict (T.pack $ show i) - - ParseError txt -> - textStrict "cannot parse expr:" - <+> textStrict (T.pack txt) - - TypeMismatch txt expr -> - textStrict "type mismatch:" - <$$> textStrict txt - <$$> pretty expr - - BadSpecialForm txt -> - textStrict "bad special form:" - <$$> textStrict txt - - NotFunction expr -> - textStrict "not a function" - <$$> pretty expr - - UnboundVar txt -> - textStrict "unbound variable:" - <$$> textStrict txt - - Default _ -> - textStrict "default error" - - ReadFileError txt -> - textStrict "error reading file:" - <$$> textStrict txt - - ExpectedList txt -> - textStrict "expected list:" - <$$> textStrict txt - -instance Pretty LispError where - pretty (LispError expr typ) = - textStrict "error evaluating:" - <$$> indent 4 (pretty expr) - <$$> pretty typ diff --git a/Com/Simatime/Language/Bs/Parser.hs b/Com/Simatime/Language/Bs/Parser.hs deleted file mode 100644 index 3044a60..0000000 --- a/Com/Simatime/Language/Bs/Parser.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Language.Bs.Parser ( - readExpr -, readExprFile -) where - -import Control.Monad (fail) -import Control.Monad (mzero) -import Data.Char (digitToInt) -import Data.Functor.Identity (Identity) -import Data.String -import qualified Data.Text as T -import Language.Bs.Expr -import Protolude hiding ((<|>), try) -import Text.Parsec -import qualified Text.Parsec.Language as Lang -import Text.Parsec.Text -import qualified Text.Parsec.Token as Tok - -lexer :: Tok.GenTokenParser T.Text () Identity -lexer = Tok.makeTokenParser style - -style :: Tok.GenLanguageDef T.Text () Identity -style = Lang.emptyDef { - Tok.commentStart = "#|" - , Tok.commentEnd = "|#" - , Tok.commentLine = ";" - , Tok.opStart = mzero - , Tok.opLetter = mzero - , Tok.identStart = letter <|> oneOf "!$%&*/:<=>?^_~" - , Tok.identLetter = digit <|> letter <|> oneOf "!$%&*/:<=>?^_~+-.@" - } - -parens :: Parser a -> Parser a -parens = Tok.parens lexer - -whitespace :: Parser () -whitespace = Tok.whiteSpace lexer - -lexeme :: Parser a -> Parser a -lexeme = Tok.lexeme lexer - -quoted :: Parser a -> Parser a -quoted p = try (char '\'') *> p - -identifier :: Parser T.Text -identifier = T.pack <$> (Tok.identifier lexer <|> specialIdentifier) "identifier" - where - specialIdentifier :: Parser String - specialIdentifier = lexeme $ try $ - string "-" <|> string "+" <|> string "..." - --- | The @Radix@ type consists of a base integer (e.g. @10@) and a parser for --- digits in that base (e.g. @digit@). -type Radix = (Integer, Parser Char) - --- | Parse an integer, given a radix as output by @radix@. --- Copied from Text.Parsec.Token -numberWithRadix :: Radix -> Parser Integer -numberWithRadix (base, baseDigit) = do - digits <- many1 baseDigit - let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits - seq n (return n) - -decimal :: Parser Integer -decimal = Tok.decimal lexer - --- | Parse a sign, return either @id@ or @negate@ based on the sign parsed. --- Copied from Text.Parsec.Token -sign :: Parser (Integer -> Integer) -sign = char '-' *> return negate - <|> char '+' *> return identity - <|> return identity - -intRadix :: Radix -> Parser Integer -intRadix r = sign <*> numberWithRadix r - -textLiteral :: Parser T.Text -textLiteral = T.pack <$> Tok.stringLiteral lexer - -nil :: Parser () -nil = try ((char '\'') *> string "()") *> return () "nil" - -hashVal :: Parser Expr -hashVal = lexeme $ char '#' - *> (char 't' *> return (Bool True) - <|> char 'f' *> return (Bool False) - <|> char 'b' *> (Numb <$> intRadix (2, oneOf "01")) - <|> char 'o' *> (Numb <$> intRadix (8, octDigit)) - <|> char 'd' *> (Numb <$> intRadix (10, digit)) - <|> char 'x' *> (Numb <$> intRadix (16, hexDigit)) - <|> oneOf "ei" *> fail "Unsupported: exactness" - <|> char '(' *> fail "Unsupported: vector" - <|> char '\\' *> fail "Unsupported: char") - - -lispVal :: Parser Expr -lispVal = hashVal - <|> Nil <$ nil - <|> Numb <$> try (sign <*> decimal) - <|> Atom <$> identifier - <|> Tape <$> textLiteral - <|> _Quote <$> quoted lispVal - <|> List <$> parens manyExpr - -manyExpr :: Parser [Expr] -manyExpr = lispVal `sepBy` whitespace - -_Quote :: Expr -> Expr -_Quote x = List [Atom "quote", x] - -contents :: Parser a -> ParsecT T.Text () Identity a -contents p = whitespace *> lexeme p <* eof - -readExpr :: T.Text -> Either ParseError Expr -readExpr = parse (contents lispVal) "" - -readExprFile :: SourceName -> T.Text -> Either ParseError Expr -readExprFile = parse (contents (List <$> manyExpr)) diff --git a/Com/Simatime/Language/Bs/Primitives.hs b/Com/Simatime/Language/Bs/Primitives.hs deleted file mode 100644 index c074c59..0000000 --- a/Com/Simatime/Language/Bs/Primitives.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} --- | bs primitives --- --- I would like to reduce the number of primitives in the language to some --- minimal number, like SKI combinator or Nock instructions. I'm not sure what --- the minimal number is. The idea is to move primitives from here into core.scm --- over time. -module Language.Bs.Primitives where - -import Control.Exception -import Control.Monad.Except -import Data.Text as T -import Data.Text.IO as TIO -import Language.Bs.Expr -import Network.HTTP -import Protolude -import System.Directory -import System.IO - -type Prim = [(T.Text, Expr)] -type Unary = Expr -> Eval Expr -type Binary = Expr -> Expr -> Eval Expr - -mkF :: ([Expr] -> Eval Expr) -> Expr -mkF = IFun . IFunc - -primEnv :: Prim -primEnv = [ - ("+" , mkF $ binopFold (numOp (+)) (Numb 0) ) - , ("*" , mkF $ binopFold (numOp (*)) (Numb 1) ) - , ("string-append", mkF $ binopFold (strOp (<>)) (Tape "") ) - , ("-" , mkF $ binop $ numOp (-)) - , ("<" , mkF $ binop $ numCmp (<)) - , ("<=" , mkF $ binop $ numCmp (<=)) - , (">" , mkF $ binop $ numCmp (>)) - , (">=" , mkF $ binop $ numCmp (>=)) - , ("==" , mkF $ binop $ numCmp (==)) - , ("even?" , mkF $ unop $ numBool even) - , ("odd?" , mkF $ unop $ numBool odd) - , ("neg?" , mkF $ unop $ numBool (< 0)) - , ("pos?" , mkF $ unop $ numBool (> 0)) - , ("eq?" , mkF $ binop eqCmd ) - , ("null?" , mkF $ unop (eqCmd Nil) ) - , ("bl-eq?" , mkF $ binop $ eqOp (==)) - , ("and" , mkF $ binopFold (eqOp (&&)) (Bool True)) - , ("or" , mkF $ binopFold (eqOp (||)) (Bool False)) - , ("not" , mkF $ unop $ notOp) - , ("cons" , mkF $ Language.Bs.Primitives.cons) - , ("cdr" , mkF $ Language.Bs.Primitives.cdr) - , ("car" , mkF $ Language.Bs.Primitives.car) - , ("quote" , mkF $ quote) - , ("file?" , mkF $ unop fileExists) - , ("slurp" , mkF $ unop slurp) - , ("wslurp" , mkF $ unop wSlurp) - , ("put" , mkF $ binop put_) - ] - -unop :: Unary -> [Expr] -> Eval Expr -unop op [x] = op x -unop _ args = throw $ NumArgs 1 args - -binop :: Binary -> [Expr] -> Eval Expr -binop op [x,y] = op x y -binop _ args = throw $ NumArgs 2 args - -fileExists :: Expr -> Eval Expr -fileExists (Tape txt) = Bool <$> liftIO (doesFileExist $ T.unpack txt) -fileExists val = throw $ TypeMismatch "read expects string, instead got: " val - -slurp :: Expr -> Eval Expr -slurp (Tape txt) = liftIO $ wFileSlurp txt -slurp val = throw $ TypeMismatch "read expects string, instead got: " val - -wFileSlurp :: T.Text -> IO Expr -wFileSlurp fileName = withFile (T.unpack fileName) ReadMode go - where go = readTextFile fileName - -openURL :: T.Text -> IO Expr -openURL x = do - req <- simpleHTTP (getRequest $ T.unpack x) - body <- getResponseBody req - return $ Tape $ T.pack body - -wSlurp :: Expr -> Eval Expr -wSlurp (Tape txt) = liftIO $ openURL txt -wSlurp val = throw $ TypeMismatch "wSlurp expects a string, instead got: " val - -readTextFile :: T.Text -> Handle -> IO Expr -readTextFile fileName h = do - exists <- doesFileExist $ T.unpack fileName - if exists - then (TIO.hGetContents h) >>= (return . Tape) - else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName] - -put_ :: Expr -> Expr -> Eval Expr -put_ (Tape file) (Tape msg) = liftIO $ wFilePut file msg -put_ (Tape _) val = throw $ TypeMismatch "put expects string in the second argument (try using show), instead got: " val -put_ val _ = throw $ TypeMismatch "put expects string, instead got: " val - -wFilePut :: T.Text -> T.Text -> IO Expr -wFilePut fileName msg = withFile (T.unpack fileName) WriteMode go - where go = putTextFile fileName msg - -putTextFile :: T.Text -> T.Text -> Handle -> IO Expr -putTextFile fileName msg h = do - canWrite <- hIsWritable h - if canWrite - then (TIO.hPutStr h msg) >> (return $ Tape msg) - else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName] - -binopFold :: Binary -> Expr -> [Expr] -> Eval Expr -binopFold op farg args = case args of - []-> throw $ NumArgs 2 args - [a,b] -> op a b - _ -> foldM op farg args - -numBool :: (Integer -> Bool) -> Expr -> Eval Expr -numBool op (Numb x) = return $ Bool $ op x -numBool _ x = throw $ TypeMismatch "numeric op " x - -numOp :: (Integer -> Integer -> Integer) -> Expr -> Expr -> Eval Expr -numOp op (Numb x) (Numb y) = return $ Numb $ op x y -numOp _ Nil (Numb y) = return $ Numb y -numOp _ (Numb x) Nil = return $ Numb x -numOp _ x (Numb _) = throw $ TypeMismatch "numeric op" x -numOp _ (Numb _) y = throw $ TypeMismatch "numeric op" y -numOp _ x _ = throw $ TypeMismatch "numeric op" x - -strOp :: (T.Text -> T.Text -> T.Text) -> Expr -> Expr -> Eval Expr -strOp op (Tape x) (Tape y) = return $ Tape $ op x y -strOp _ Nil (Tape y) = return $ Tape y -strOp _ (Tape x) Nil = return $ Tape x -strOp _ x (Tape _) = throw $ TypeMismatch "string op" x -strOp _ (Tape _) y = throw $ TypeMismatch "string op" y -strOp _ x _ = throw $ TypeMismatch "string op" x - -eqOp :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Expr -eqOp op (Bool x) (Bool y) = return $ Bool $ op x y -eqOp _ x (Bool _) = throw $ TypeMismatch "bool op" x -eqOp _ (Bool _) y = throw $ TypeMismatch "bool op" y -eqOp _ x _ = throw $ TypeMismatch "bool op" x - -numCmp :: (Integer -> Integer -> Bool) -> Expr -> Expr -> Eval Expr -numCmp op (Numb x) (Numb y) = return . Bool $ op x y -numCmp _ x (Numb _) = throw $ TypeMismatch "numeric op" x -numCmp _ (Numb _) y = throw $ TypeMismatch "numeric op" y -numCmp _ x _ = throw $ TypeMismatch "numeric op" x - -notOp :: Expr -> Eval Expr -notOp (Bool True) = return $ Bool False -notOp (Bool False) = return $ Bool True -notOp x = throw $ TypeMismatch " not expects Bool" x - -eqCmd :: Expr -> Expr -> Eval Expr -eqCmd (Atom x) (Atom y) = return . Bool $ x == y -eqCmd (Numb x) (Numb y) = return . Bool $ x == y -eqCmd (Tape x) (Tape y) = return . Bool $ x == y -eqCmd (Bool x) (Bool y) = return . Bool $ x == y -eqCmd Nil Nil = return $ Bool True -eqCmd _ _ = return $ Bool False - -cons :: [Expr] -> Eval Expr -cons [x,(List ys)] = return $ List $ x:ys -cons [x,y] = return $ List [x,y] -cons _ = throw $ ExpectedList "cons, in second argument" - -car :: [Expr] -> Eval Expr -car [List [] ] = return Nil -car [List (x:_)] = return x -car [] = return Nil -car _ = throw $ ExpectedList "car" - -cdr :: [Expr] -> Eval Expr -cdr [List (_:xs)] = return $ List xs -cdr [List []] = return Nil -cdr [] = return Nil -cdr _ = throw $ ExpectedList "cdr" - -quote :: [Expr] -> Eval Expr -quote [List xs] = return $ List $ Atom "quote" : xs -quote [expr] = return $ List $ Atom "quote" : [expr] -quote args = throw $ NumArgs 1 args diff --git a/Com/Simatime/Language/Bs/Repl.hs b/Com/Simatime/Language/Bs/Repl.hs deleted file mode 100644 index 64ffaa2..0000000 --- a/Com/Simatime/Language/Bs/Repl.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Language.Bs.Repl ( -mainLoop -) where - -import Control.Monad.Trans -import Data.String -import Data.Text as T -import Language.Bs.Eval -import Protolude -import System.Console.Haskeline - -type Repl a = InputT IO a - -mainLoop :: IO () -mainLoop = runInputT defaultSettings repl - -repl :: Repl () -repl = do - minput <- getInputLine "bs> " - case minput of - Nothing -> outputStrLn "bye." - Just input -> (liftIO $ process input) >> repl - --Just input -> (liftIO $ processToAST input) >> repl - -process :: String -> IO () -process str = do - res <- safeExec $ evalText $ T.pack str - either putStrLn return res - -processToAST :: String -> IO () -processToAST str = print $ runParseTest $ T.pack str diff --git a/Com/Simatime/Language/Bs/Test.hs b/Com/Simatime/Language/Bs/Test.hs deleted file mode 100644 index 4a40036..0000000 --- a/Com/Simatime/Language/Bs/Test.hs +++ /dev/null @@ -1,2 +0,0 @@ --- TODO -module Language.Bs.Test where diff --git a/Com/Simatime/Logic.scm b/Com/Simatime/Logic.scm deleted file mode 100644 index b693e9d..0000000 --- a/Com/Simatime/Logic.scm +++ /dev/null @@ -1,238 +0,0 @@ -;; my mini kanren impl - basically untested so far - -(define-module (Com Simatime Logic)) - -(define-syntax λg - (syntax-rules () - ((_ (s) e) (lambda (s) e)))) - -(define-syntax λf - (syntax-rules () - ((_ () e) (lambda () e)))) - -(define (unify u v s) - (let ([u (walk u s)] - [v (walk v s)]) - (cond - [(eq? u u) s] - - [(var? u) - (cond - [(var? v) (ext-s-check u v s)] - [else (ext-s-check u v s)])] - - [(and (pair? u) (pair? v)) - (let ([s (unify (car u) (car v) s)]) - (and s (unify (cdr u) (cdr v) s)))] - - [(equal? u v) s] - - [else #f]))) - -(define-syntax if-not - (syntax-rules () - ((_ pred then else) - (if (not pred) then else)))) - -(define (walk v s) - (if-not (var? v) - v - (let ([a (assq v s)]) - (if a - (walk (cdr a) s) - v)))) - -(define (ext-s-check x v s) - (if-not (occurs-check x v s) - (ext-s x v s) - #f)) - -(define (occurs-check x v s) - (let ([v (walk v s)]) - (cond - [(var? v) (eq? v x)] - [(pair? v) - (or (occurs-check x (car v) s) - (occurs-check x (cdr v) s))] - [else #f]))) - -(define (ext-s x v s) - (cons `(,x . ,v) s)) - -(define empty-s '()) - -(define var vector) -(define var? vector?) - -(define reify - (letrec ([reify-s (lambda [v s] - (let ([v (walk v s)]) - (cond - [(var? v) (ext-s v (reify-name (length s)) s)] - [(pair? v) (reify-s (cdr v) (reify-s (car v) s))] - [else s])))]) - (lambda [v s] - (let ([v (walk* v s)]) - (walk* v (reify-s v empty-s)))))) - -(define walk* - (lambda [w s] - (let ([v (walk w s)]) - (cond - [(var? v) v] - [(pair? v) (cons (walk* (car v) s) - (walk* (cdr v) s))] - [else v])))) - -(define reify-name - (lambda [n] - (string->symbol - (string-append "_" "." (number->string n))))) - -(define-syntax mzero - (syntax-rules () - ((_) #f))) - -(define-syntax unit - (syntax-rules () - ((_ a) a))) - -(define-syntax choice - (syntax-rules () - ((_ a f) (cons a f)))) - -(define-syntax inc - (syntax-rules () - ((_ e) (λf () e)))) - -(define-syntax case-inf - (syntax-rules () - ((_ e on-zero - [(a^) on-one] - [(a f) on-choice] - [(f^) on-inc]) - (let ([a-inf e]) - (cond - ;; a-inf = #f - [(not a-inf) on-zero] - ;; a-inf = lambda - [(procedure? a-inf) (let ((f^ a-inf)) on-inc)] - ;; a-inf = (x . lambda) - [(and (pair? a-inf) (procedure? (cdr a-inf))) - (let ([a (car a-inf)] - [f (cdr a-inf)]) - on-choice)] - [else (let ((a^ a-inf)) on-one)]))))) - -(define-syntax == - (syntax-rules () - ((_ u v) - (λg (s) (unify u v s))))) - -(define-syntax conde - (syntax-rules () - ((_ (g0 g ...) (g1 g^ ...) ...) - (λg (s) - (inc (mplus* - (bind* (g0 s) g ...) - (bind* (g1 s) g^ ...) ...)))))) - -(define-syntax mplus* - (syntax-rules () - ((_ e) e) - ((_ e0 e ...) (mplus e0 (λf () (mplus* e ...)))))) - -(define mplus - (lambda (a-inf f) - (case-inf a-inf (f) - ((a) (choice a f)) - ((a f^) (choice a (λf () (mplus (f) f^)))) - ((f^) (inc (mplus (f) f^)))))) - -(define-syntax fresh - (syntax-rules () - ((_ (x ...) g0 g ...) - (λg (s) - (let ((x (var 'x)) ...) - (bind* (g0 s) g ...)))))) - -(define-syntax bind* - (syntax-rules () - ((_ e) e) - ((_ e g0 g ...) - (let ((a-inf e)) - (and a-inf (bind* (bind a-inf g0) g ...)))))) - -(define bind - (lambda (a-inf g) - (case-inf a-inf (mzero) - ((a) (g a)) - ((a f) (mplus (g a) (λf () (bind (f) g)))) - ((f) (inc (bind (f) g)))))) - -(define-syntax run - (syntax-rules () - ((_ n (x) g0 g^ ...) - (take n - (λf - () - (let ((g (fresh - (x) - (λg - (s) - (bind* (g0 s) g^ ... - (λg (s) - (list (reify x s)))))))) - (g empty-s))))))) - -(define-syntax run* - (syntax-rules () - ((_ (x) g ...) (run #f (x) g ...)))) - -(define take - (lambda (n f) - (if (and n (zero? n)) - '() - (case-inf (f) '() - [(a) a] - [(a f) (cons (car a) (take (and n (- n 1)) f))] - [(f) (take n f)])))) - -(define-syntax conda - (syntax-rules () - ((_ (g0 g ...) (g1 g^ ...) ...) - (λg (s) - (if* (picka (g0 s) g ...) (picka (g1 s) g^ ...) ...))))) - -(define-syntax condu - (syntax-rules () - ((_ (g0 g ...) (g1 g^ ...) ...) - (λg (s) - (if* (picku (g0 s) g ...) - (picku (g1 s) g^ ...) - ...))))) - -(define-syntax if* - (syntax-rules () - ((_) (mzero)) - ((_ (pick e g ...) b ...) - (let loop ((a-inf e)) - (case-inf a-inf (if* b ...) - [(a) (bind* a-inf g ...)] - [(a f) (bind* (pick a a-inf) g ...)] - [(f) (inc (loop (f)))]))))) - -(define-syntax picka - (syntax-rules () - ((_ a a-inf) a-inf))) - -(define-syntax picku - (syntax-rules () - ((_ a a-inf) (unit a)))) - -(define-syntax project - (syntax-rules () - ((_ (x ...) g0 g ...) - (λg (s) - (let ((x (walk* x s)) ...) - (bind* (g0 s) g ...)))))) diff --git a/Com/Simatime/Network.hs b/Com/Simatime/Network.hs deleted file mode 100644 index e47e891..0000000 --- a/Com/Simatime/Network.hs +++ /dev/null @@ -1,31 +0,0 @@ --- | A port of Kris Jenkins' RemoteData Elm module --- . --- -module Com.Simatime.Network where - -data RemoteData a b - = NotAsked - | Loading - | Failure a - | Success b - deriving (Eq, Show) - --- TODO figure out Http.Error --- type WebData a = RemoteData Http.Error a - -instance Functor (RemoteData a) where - fmap _ NotAsked = NotAsked - fmap _ Loading = Loading - fmap _ (Failure a) = Failure a - fmap f (Success a) = Success (f a) - -instance Applicative (RemoteData e) where - pure = Success - NotAsked <*> _ = NotAsked - Loading <*> _ = Loading - Failure a <*> _ = Failure a - Success a <*> b = fmap a b - -fromEither :: Either a b -> RemoteData a b -fromEither (Left a) = Failure a -fromEither (Right a) = Success a diff --git a/Com/Simatime/Repl.scm b/Com/Simatime/Repl.scm deleted file mode 100644 index af9a494..0000000 --- a/Com/Simatime/Repl.scm +++ /dev/null @@ -1,23 +0,0 @@ -(define-module (Com Simatime Repl) - #:export ()) - - -;; -;; repl customization -;; - -;; (use-modules (system repl common)) -;; (repl-default-option-set! -;; 'prompt -;; (lambda (repl) -;; (format #f "\n[~a@~a:~a]\nλ> " -;; (getenv "USER") -;; (vector-ref (uname) 1) -;; (pwd)))) - -;; TODO(bsima): (doc x) -;; TODO(bsima): (src x) -;; TODO(bsima): ,src command -;; TODO(bsima): ,shell command -;; TODO(bsima): how to load this file on startup? -;; for ,src and ,shell https://github.com/NalaGinrut/nala-repl diff --git a/Com/Simatime/Sema.hs b/Com/Simatime/Sema.hs deleted file mode 100644 index f0f75da..0000000 --- a/Com/Simatime/Sema.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Com.Simatime.Sema - ( mapPool - ) -where - -import qualified Control.Concurrent.MSem as Sem - --- | Simaphore-based throttled 'mapConcurrently'. -mapPool :: Traversable t => Int -> (a -> IO b) -> t a -> IO (t b) -mapPool n f xs = do - sima <- Sem.new n - mapConcurrently (Sem.with sima . f) xs diff --git a/Com/Simatime/Serval.scm b/Com/Simatime/Serval.scm deleted file mode 100644 index 81f5e13..0000000 --- a/Com/Simatime/Serval.scm +++ /dev/null @@ -1,194 +0,0 @@ -;; -;; Serval - fast container management -;; -;; `Container management' simply refers to tracking the configuration -;; for individual containers and their running state. -;; -;; Serval stores container configuration in a directory, which forms the -;; database. Each container is associated with a `.kit' file, which is a -;; serialized s-expr of a `@Kit' record type. -;; -;; Runtime state is offloaded to systemd, and certain commands simply -;; reach out to `systemctl' and `machinectl' for this functionality. -;; -;; Serval does not concern itself with deployment. For that, use `nix copy'. -;; -;; Currently Serval only supports a single physical machine: if we want -;; to cluster containers across machines, we must find a way to store -;; and reason about the host in addition to the container. This might -;; mean absorbing some functionality that systemd currently performs for -;; us. -;; -;; FILES -;; -;; /var/lib/serval/.kit - kit state (serialized s-expr) -;; /var/lib/serval// - root directory for the kit -;; /nix/var/nix/profiles/per-kit/ - symlink to cfg in /nix/store -;; -;; TODO -;; - save-kit function (write kit to /var/lib/serval/.kit) -;; - profiles in /nix/var/nix/profiles/per-kit -;; - each of the below commented functions for state manipulation -;; -(define-module (Com Simatime Serval) - #:use-module ((ice-9 getopt-long)) - #:use-module ((ice-9 match) - #:select (match)) - #:use-module ((srfi srfi-9) - #:select (define-record-type)) - #:use-module ((Com Simatime Core) - #:select (second rest fmt prn first comment nil)) - #:use-module ((Com Simatime Test) - #:select (testing)) - #:use-module ((Com Simatime Shell) #:prefix Shell.) - #:export (main)) - -(define *data-dir* "/var/lib/serval") -(define *nix-profiles-dir* "/nix/var/nix/profiles") - -;; TODO: I would really like a better command line parser... -;; getopt-long sucks -(define (main args) - ;; pop first arg if its the executable - (let* ([args (if (equal? (first args) "Com/Simatime/Serval.scm") - (rest args) - args)] - [cmd (first args)]) - (match cmd - ["new" (new-kit! args)] - ["del" (del-kit! args)] - ["start" (start-kit! args)] - ["stop" (stop-kit! args)] - ["scale" (prn "TODO: scale running kits")] - ["ssh" (run-in-kit! args)] - ["info" (prn "TODO: show kit")] - ["ls" ("TODO: list available kits")] - [else (prn "help")]))) - -(define-record-type @Kit - (Kit name nix-path system-path host-address - host-port local-address auto-start) - kit? - ;; a unique name for this kit - (name kit-name) - ;; location in the nix store - (nix-path get-nix-path set-nix-path!) - ;; this is like /etc/nixos/conf.nix in NixOS proper. At - ;; initialization, this is just `/var/lib/serval/$kit'. Afterwards, - ;; it's `/nix/var/nix/profiles/per-kit/$kit'. - (system-path get-system-path set-system-path!) - ;; host IP - (host-address get-host-address set-host-address!) - ;; host port - (host-port get-host-port set-host-port!) - ;; the private IP - (local-address get-local-address set-local-address!) - ;; should this kit start when the host starts? - (auto-start get-auto-start set-auto-start!)) - -(define-syntax for - (syntax-rules () - ((_ a b) (map b a)) - ((_ a ... b) (map b a ...)))) - -(define (zip a b) - "Combine a and b into a single list of pairs." - ;; TODO: zip-list, zip-with, in Core - (apply map cons (list a b))) - -(define (serialize kit) - "Turns a kit into an association list." - (let* ((fields (record-type-fields @Kit)) - (values (for fields - (lambda (field) ((record-accessor @Kit field) kit))))) - (zip fields values))) - -(define (deserialize alist) - "Creates a @Kit from an association list." - (apply Kit (map rest alist))) - -(define (save-kit! kit) - (call-with-output-file (fmt "~a/~a.kit" *data-dir* (kit-name kit)) - (lambda (a) (write (serialize kit) a)))) - -(define (load-kit! kit-name) - (call-with-input-file (fmt "~a/~a.kit" *data-dir* kit-name) - (lambda (a) (deserialize (read a))))) - -;; TODO -(define (find-available-address) - "10.233.0.1") - -;; top-level commands, each take an argstr - -(define (setup!) - "Initial setup, only need to run once." - (Shell.exec (fmt "mkdir -p ~a" *nix-profiles-dir*)) - (Shell.exec (fmt "mkdir -p ~a" *data-dir*))) - -(define (new-kit! args) - "Creates a new kit: -1. first arg is name -2. second arg is nix-path -3. rest args parsed by getopt-long - -TODO: ensure kit-name is unique -" - (let* ([name (first args)] - [nix-path (second args)] - [option-spec '((auto-start (single-char #\a) (value #f)))] - [options (getopt-long args option-spec)] - [auto-start (option-ref options 'auto-start #f)] - [local-address (find-available-address)] - [kit (Kit name nix-path "fixme-system-path" "fixme-host-address" - "fixme-host-port" local-address auto-start)]) - (save-kit! kit) - (prn ;; Shell.exec - (fmt "nix-env -p ~a/per-kit/system --set ~a" - *nix-profiles-dir* (get-system-path kit))) - kit)) - -(define (del-kit! args) - (let ([name (first args)]) - (Shell.exec (fmt "rm ~a/~a" *data-dir* name)))) - -(define (list-kits) - (Shell.exec (fmt "ls ~a" *data-dir*))) - -(define (update-kit! args) - ;; TODO: load kit and update with new config file - (let ([kit nil]) - (Shell.exec - (fmt "nix-env -p ~a/system -I nixos-config=~a -f --set -A system" - *nix-profiles-dir* - (get-system-path nil))))) - -(define (run-in-kit! args) - (let ([kit nil]) - (Shell.exec - (fmt "systemd-run --machine ~a --pty --quiet -- ~{~a~}" - (kit-name kit) args)))) - -(define (is-kit-running? kit) - (Shell.exec - (fmt "systemctl show kit@~a" (kit-name kit)))) - -(define (start-kit! kit) - (Shell.exec - (fmt "systemctl start kit@~a" (kit-name kit)))) - -(define (stop-kit! kit) - (let* ([force-stop #f] - [cmd (if force-stop - (fmt "machinectl terminate ~a" (kit-name kit)) - (fmt "systemctl stop kit@~a" (kit-name kit)))]) - (Shell.exec cmd))) - -(define (restart-kit! kit) - (stop-kit! kit) - (start-kit! kit)) - -(define (get-leader kit) - "Return the PID of the init process of the kit." - (Shell.exec - (fmt "machinectl show ~a -p Leader" (kit-name kit)))) diff --git a/Com/Simatime/Shell.scm b/Com/Simatime/Shell.scm deleted file mode 100644 index b99e5cd..0000000 --- a/Com/Simatime/Shell.scm +++ /dev/null @@ -1,34 +0,0 @@ -(define-module (Com Simatime Shell) - #:use-module ((ice-9 popen) #:prefix popen/) - #:use-module ((ice-9 rdelim) #:prefix rdelim/) - #:use-module ((ice-9 ftw) #:prefix ftw/) - #:export (exec - stream - pwd - ls - cd)) - -(define (exec cmd) - (let* ((port (popen/open-input-pipe cmd)) - (ret (read port))) - (popen/close-pipe port) - ret)) - -(define (stream cmd) - (let* ((port (popen/open-input-pipe cmd)) - (_ (setvbuf port 'none)) - (ret (rdelim/read-string port))) - (flush-all-ports) - (popen/close-pipe port) - ret)) - -(define (pwd) - (regexp-substitute/global - #f "/home/ben" (getcwd) 'pre "~" 'post)) - -(define (ls) - (ftw/scandir (getcwd))) - -(define (cd path) - (chdir path) - (ls)) diff --git a/Com/Simatime/Shuffle.hs b/Com/Simatime/Shuffle.hs deleted file mode 100644 index 02cd3e0..0000000 --- a/Com/Simatime/Shuffle.hs +++ /dev/null @@ -1,122 +0,0 @@ -{- | -Module : System.Random.Shuffle -Copyright : (c) 2009 Oleg Kiselyov, Manlio Perillo -License : BSD3 (see LICENSE file) - - - - -Example: - - import System.Random (newStdGen) - import System.Random.Shuffle (shuffle') - - main = do - rng <- newStdGen - let xs = [1,2,3,4,5] - print $ shuffle' xs (length xs) rng --} -{-# OPTIONS_GHC -funbox-strict-fields #-} - -module System.Random.Shuffle - ( shuffle - , shuffle' - , shuffleM - ) -where - -import Data.Function ( fix ) -import System.Random ( RandomGen - , randomR - ) -import Control.Monad ( liftM - , liftM2 - ) -import Control.Monad.Random ( MonadRandom - , getRandomR - ) - - --- | A complete binary tree, of leaves and internal nodes. --- Internal node: Node card l r --- where card is the number of leaves under the node. --- Invariant: card >=2. All internal tree nodes are always full. -data Tree a = Leaf !a - | Node !Int !(Tree a) !(Tree a) - deriving Show - - --- | Convert a sequence (e1...en) to a complete binary tree -buildTree :: [a] -> Tree a -buildTree = (fix growLevel) . (map Leaf) - where - growLevel _ [node] = node - growLevel self l = self $ inner l - - inner [] = [] - inner [e ] = [e] - inner (e1 : e2 : es) = e1 `seq` e2 `seq` (join e1 e2) : inner es - - join l@(Leaf _ ) r@(Leaf _ ) = Node 2 l r - join l@(Node ct _ _ ) r@(Leaf _ ) = Node (ct + 1) l r - join l@(Leaf _ ) r@(Node ct _ _) = Node (ct + 1) l r - join l@(Node ctl _ _) r@(Node ctr _ _) = Node (ctl + ctr) l r - - --- |Given a sequence (e1,...en) to shuffle, and a sequence --- (r1,...r[n-1]) of numbers such that r[i] is an independent sample --- from a uniform random distribution [0..n-i], compute the --- corresponding permutation of the input sequence. -shuffle :: [a] -> [Int] -> [a] -shuffle elements = shuffleTree (buildTree elements) - where - shuffleTree (Leaf e) [] = [e] - shuffleTree tree (r : rs) = - let (b, rest) = extractTree r tree in b : (shuffleTree rest rs) - shuffleTree _ _ = error "[shuffle] called with lists of different lengths" - - -- Extracts the n-th element from the tree and returns - -- that element, paired with a tree with the element - -- deleted. - -- The function maintains the invariant of the completeness - -- of the tree: all internal nodes are always full. - extractTree 0 (Node _ (Leaf e) r ) = (e, r) - extractTree 1 (Node 2 (Leaf l) (Leaf r)) = (r, Leaf l) - extractTree n (Node c (Leaf l) r) = - let (e, r') = extractTree (n - 1) r in (e, Node (c - 1) (Leaf l) r') - - extractTree n (Node n' l (Leaf e)) | n + 1 == n' = (e, l) - - extractTree n (Node c l@(Node cl _ _) r) - | n < cl - = let (e, l') = extractTree n l in (e, Node (c - 1) l' r) - | otherwise - = let (e, r') = extractTree (n - cl) r in (e, Node (c - 1) l r') - extractTree _ _ = error "[extractTree] impossible" - --- |Given a sequence (e1,...en) to shuffle, its length, and a random --- generator, compute the corresponding permutation of the input --- sequence. -shuffle' :: RandomGen gen => [a] -> Int -> gen -> [a] -shuffle' elements len = shuffle elements . rseq len - where - -- The sequence (r1,...r[n-1]) of numbers such that r[i] is an - -- independent sample from a uniform random distribution - -- [0..n-i] - rseq :: RandomGen gen => Int -> gen -> [Int] - rseq n = fst . unzip . rseq' (n - 1) - where - rseq' :: RandomGen gen => Int -> gen -> [(Int, gen)] - rseq' 0 _ = [] - rseq' i gen = (j, gen) : rseq' (i - 1) gen' - where (j, gen') = randomR (0, i) gen - --- |shuffle' wrapped in a random monad -shuffleM :: (MonadRandom m) => [a] -> m [a] -shuffleM elements - | null elements = return [] - | otherwise = liftM (shuffle elements) (rseqM (length elements - 1)) - where - rseqM :: (MonadRandom m) => Int -> m [Int] - rseqM 0 = return [] - rseqM i = liftM2 (:) (getRandomR (0, i)) (rseqM (i - 1)) diff --git a/Com/Simatime/String.scm b/Com/Simatime/String.scm deleted file mode 100644 index 770b04b..0000000 --- a/Com/Simatime/String.scm +++ /dev/null @@ -1,24 +0,0 @@ -(define-module (Com Simatime String) - #:export (replace to-string str capitalize)) - -(define (replace s match repl) - (let ((f (lambda (a b) - (let ((next-char (if (eq? a match) repl a))) - (string-concatenate (list b (string next-char))))))) - (string-fold f "" s))) - -(define (to-string x) - (format #f "~a" x)) - -(define str - (case-lambda - (() "") - ((x) (to-string x)) - ((x . rest) (string-concatenate (map str (cons x rest)))))) - -(define (capitalize s) - (let ((s (to-string s))) - (if (< (string-length s) 2) - (string-upcase s) - (str (string-upcase (substring s 0 1)) - (substring s 1 ))))) diff --git a/Com/Simatime/Test.scm b/Com/Simatime/Test.scm deleted file mode 100644 index 638940f..0000000 --- a/Com/Simatime/Test.scm +++ /dev/null @@ -1,16 +0,0 @@ -;; a testing framework for scheme -;; inspired by clojure.test and srfi-64 - -(define-module (Com Simatime Test) - #:use-module ((Com Simatime core) - #:select (prn)) - #:export (testing)) - -;; TODO: learn srfi-64 -;; TODO: port over `deftest' et al from clojure -;; TODO: someday a quickcheck-like would be best - -;; simple analog to clojure's `testing' -(define-syntax testing - ((_ description ...) - ((begin (prn description) ...)))) diff --git a/Com/Simatime/buildOS.nix b/Com/Simatime/buildOS.nix deleted file mode 100644 index 9e6c2f2..0000000 --- a/Com/Simatime/buildOS.nix +++ /dev/null @@ -1,56 +0,0 @@ -nixos: -{ ipAddress ? null -, enableVpn ? false -, vpnConnectTo ? "" -, vpnRsaPrivateKeyFile ? null -, vpnEd25519PrivateKeyFile ? null -, deps ? {} # an attrset overlayed to pkgs -, configuration # see: configuration.nix(5) -}: -# assert enableVpn -> builtins.isString ipAddress; -# assert enableVpn -> builtins.isString vpnRsaPrivateKeyFile; -# assert enableVpn -> builtins.isString vpnEd25519PrivateKeyFile; -let - vpnExtraConfig = if enableVpn then '' - ConnectTo = ${vpnConnectTo} - Ed25519PrivateKeyFile = "${vpnEd25519PrivateKeyFile}" - PrivateKeyFile = "${vpnRsaPrivateKeyFile}" - '' else ""; - overlay = self: super: deps; - defaults = { - boot.cleanTmpDir = true; - #networking.interfaces.simatime-vpn = [{ ipv4.address = ipAddress; }]; - networking.firewall.allowPing = true; - nix.binaryCaches = [ "https://cache.nixos.org" ]; - nix.gc.automatic = true; - nix.gc.dates = "Sunday 02:15"; - nix.maxJobs = 1; # "auto"; - nix.optimise.automatic = true; - nix.optimise.dates = [ "Sunday 02:30" ]; - nixpkgs.overlays = [ overlay ]; - programs.mosh.enable = true; - programs.mosh.withUtempter = true; - security.acme.email = "ben@bsima.me"; - security.acme.acceptTerms = true; - security.sudo.wheelNeedsPassword = false; - services.clamav.daemon.enable = true; # security - services.clamav.updater.enable = true; # security - services.fail2ban.enable = true; # security - services.openssh.enable = true; - services.openssh.openFirewall = true; - services.openssh.forwardX11 = true; - services.openssh.passwordAuthentication = false; - #services.tinc.networks.simatime-vpn.extraConfig = vpnExtraConfig; - #services.tinc.networks.simatime-vpn.debugLevel = 3; - #services.tinc.networks.simatime-vpn.interfaceType = "tap"; - #services.tinc.networks.simatime-vpn.hosts = import ./vpnHosts.nix; - system.autoUpgrade.enable = false; # 'true' breaks our nixpkgs pin - }; - os = nixos { - system = "x86_64-linux"; - configuration = (defaults // configuration); - }; -in { - system = os.system; - vm = os.vm; -} diff --git a/Com/Simatime/fathom.nix b/Com/Simatime/fathom.nix deleted file mode 100644 index 40e8b0b..0000000 --- a/Com/Simatime/fathom.nix +++ /dev/null @@ -1,109 +0,0 @@ -{ options -, lib -, config -, pkgs -, modulesPath -, stdenv -}: - -with lib; - -let - cfg = config.services.fathom - pkgs.fathom = stdenv.mkDerivation rec { - name = "fathom-v${version}"; - version = "1.2.1"; - src = builtins.fetchurl { - url = "https://github.com/usefathom/fathom/releases/download/v${version}/fathom_${version}_linux_amd64.tar.gz"; - sha256 = "0sfpxh2xrvz992k0ynib57zzpcr0ikga60552i14m13wppw836nh"; - }; - sourceRoot = "."; - dontBuild = true; - installPhase = '' - mkdir -p $out/bin - cp fathom $out/bin - cp LICENSE $out - cp README.md $out - ''; - }; -in { - options.services.fathom = { - enable = lib.mkEnableOption "Enable the Fathom Analytics service"; - - port = mkOption { - type = types.string; - default = "3000"; - description = '' - The port on which Fathom will listen for - incoming HTTP traffic. - ''; - }; - - gzip = mkOption { - type = types.bool; - default = true; - description = "Whether or not to enable gzip compression."; - }; - - debug = mkOption { - type = types.bool; - default = false; - description = "Whether or not to enable debug mode."; - }; - - dataDir = mkOption { - type = types.path; - default = "/var/lib/fathom"; - description = "Fathom data directory"; - }; - }; - - config = mkIf cfg.enable { - systemd.services.fathom = { - wantedBy = [ "multi-user.target" ]; - after = [ "network.target" ]; - - environment = { - FATHOM_SERVER_ADDR = cfg.port; - FATHOM_GZIP = builtins.toString cfg.gzip; - FATHOM_DEBUG = builtins.toString cfg.debug; - FATHOM_DATABASE_DRIVER = "sqlite3"; - FATHOM_DATABASE_NAME = "${cfg.dataDir}/fathom.db"; - FATHOM_SECRET = "random-secret-string"; - }; - preStart = '' - echo "[fathom] creating ${cfg.dataDir}" - mkdir -p ${cfg.dataDir} - chown -R fathom:fathom ${cfg.dataDir} - echo "[fathom]" creating ${cfg.dataDir}/.env - env | grep "^FATHOM" > ${cfg.dataDir}/.env - ''; - description = '' - Fathom Analytics - ''; - - serviceConfig = { - Type = "simple"; - User = "fathom"; - Group = "fathom"; - ExecStart = "${pkgs.fathom}/bin/fathom server"; - KillSignal = "INT"; - WorkingDirectory = cfg.dataDir; - Restart = "on-failure"; - RestartSec = "10"; - PermissionsStartOnly = "true"; - }; - }; - - environment.systemPackages = [ pkgs.fathom ]; - - users = { - groups = { fathom = {}; }; - users.fathom = { - description = "Fathom daemon user"; - home = cfg.dataDir; - group = "fathom"; - }; - }; - }; -} diff --git a/Com/Simatime/firefox.nix b/Com/Simatime/firefox.nix deleted file mode 100644 index 12316fb..0000000 --- a/Com/Simatime/firefox.nix +++ /dev/null @@ -1,12 +0,0 @@ -{ ... }: - -{ - services = { - firefox.syncserver = { - enable = true; - allowNewUsers = true; - listen.port = 5001; - publicUri = "http://firefoxsync.simatime.com"; - }; - }; -} diff --git a/Com/Simatime/idea/duree-pitch.org b/Com/Simatime/idea/duree-pitch.org deleted file mode 100644 index d4d9d6f..0000000 --- a/Com/Simatime/idea/duree-pitch.org +++ /dev/null @@ -1,80 +0,0 @@ -#+TITLE: Duree: automated universal database -#+SUBTITLE: seeking pre-seed funding -#+AUTHOR: Ben Sima -#+EMAIL: ben@bsima.me -#+OPTIONS: H:1 num:nil toc:nil -#+LATEX_CLASS: article -#+LATEX_CLASS_OPTIONS: -#+LATEX_HEADER: -#+LATEX_HEADER_EXTRA: -#+LATEX_COMPILER: pdflatex -#+DATE: \today -#+startup: beamer -#+LaTeX_CLASS: beamer -#+LaTeX_CLASS_OPTIONS: [presentation,smaller] -Start with this: - - https://news.ycombinator.com/item?id=14605 - - https://news.ycombinator.com/item?id=14754 -Then build AI layers on top. -* Problem -Developers spend too much time managing database schemas. Every database -migration is a risk to the business because of the high possibility of data -corruption. If the data is modeled incorrectly at the beginning, it requires a -lot of work (months of developer time) to gut the system and re-architect it. -* Solution -- Using machine learning and AI, we automatically detect the schema of your data. -- Data can be dumped into a noSQL database withouth the developer thinking much - about structure, then we infer the structure automatically. -- We can also generate a library of queries and provide an auto-generated client - in the choosen language of our users. -* Existing solutions -- Libraries like alembic and migra (Python) make data migrations easier, but - don't help you make queries or properly model data. -- ORMs help with queries but don't give you much insight into the deep structure - of your data (you still have to do manual joins) and don't help you properly - model data. -- Graph QL is the closest competitor, but requires manually writing types and - knowing about the deep structure of your data. We automate both. - -* Unsolved problems -- Unsure whether to build this on top of existing noSQL databases, or to develop - our own data store. Could re-use an existing [[https://en.wikipedia.org/wiki/Category:Database_engines][database engine]] to provide an - end-to-end database solution. -* Key metrics -- How much time do developers spend dealing with database migrations? What does - this cost the business? We can decrease this, decreasing costs. -- How costly are failed data migrations and backups? We reduce this risk. -* Unique value proposition -We can automate the backend data mangling for 90% of software applications. -* Unfair advantage -- I have domain expertise, having worked on similar schemaless database problems - before. -- First-mover advantage in this space. Everyone else is focused on making - database migrations easier, we want to make them obsolete. -* Channels -- Cold calling mongoDB et al users. -* Customer segments -- *Early adopters:* users of mongoDB and graphQL who want to spend time writing - application code, not managing database schemas. The MVP would be to generate - the Graph QL code from their Mongo database automatically. -- Will expand support to other databases one by one. The tech could be used on - any database... or we expand by offering our own data store. -* Cost structure -** Fixed costs - - Initial development will take about 3 months (~$30k) - - Each new database support will take a month or two of development. -** Variable costs - - Initial analysis will be compute-heavy. - - Following analyses can be computationally cheap by buildiing off of the - existing model. - - Customer acquisition could be expensive, will likely hire a small sales - team. -* Revenue streams -- $100 per month per database analyzed - - our hosted service connects to their database directly - - includes client libraries via graphQL - - may increase this if it turns out we save companies a lot more than $100/mo, - which is likely -- enterprise licenses available for on-prem - - allows them to have complete control over their database access - - necessary for HIPAA/PCI compliance diff --git a/Com/Simatime/idea/flash.org b/Com/Simatime/idea/flash.org deleted file mode 100644 index 1c392f0..0000000 --- a/Com/Simatime/idea/flash.org +++ /dev/null @@ -1,36 +0,0 @@ -#+title: Flash -#+description: a system for quickly testing business ideas - -- Each marketing iteration for a product requires some gear. A "gear" pack is just a yaml - file with all data for a single flash test. It will include ad content, - pricing info, links to necessary images, and so on. - - even better: store these in a database? Depends on how often we need to edit them... -- Data gets marshalled into a bunch of templates, one for each sales pipeline in - the /Traction/ book by Gabriel Weinberg (7 pipelines total) -- Each sales pipeline will have a number of integrations, we'll need at least - one for each pipeline before going to production. E.g.: - - google adwords - - facebook ads - - email lists (sendgrid) - - simple marketing website - - producthunt - - etc -- Pipelines will need to capture metrics on a pre-set schedule. - - Above integrations must also pull performance numbers from Adwords etc APIs. - - Will need some kind of scheduled job queue or robot background worker to handle this. - - A simple dashboard might also be useful, not sure. -- Metrics determine the performance of a pipeline. After the defined trial - duration, some pipelines will be dropped. The high-performing pipelines we - double-down on. -- Metrics to watch: - - conversion rate - - usage time - minutes spent on site/app - - money spent per customer - - see baremetrics for more ideas -- This can eventually be integrated to a larger product design platform (what Sam - Altman calls a "product improvement engine" in his playbook - PIE?). - - metric improvement can be plotted on a relative scale - - "If you improve your product 5% every week, it will really compound." - Sam - - PIE will differ from Flash in that Flash is only for the early stages of a - product - sell it before you build it. PIE will operate on existing products - to make them better. diff --git a/Com/Simatime/keys/ben.pub b/Com/Simatime/keys/ben.pub deleted file mode 100644 index c661508..0000000 --- a/Com/Simatime/keys/ben.pub +++ /dev/null @@ -1 +0,0 @@ -ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAACAQDDhmSEbvX6LSk1ZO/whhAWpxwUxGPwbn7ZKVmxLcIilLdkd/vhFQKSYyMBW+21G3cMbwyFVsCyPbADoXcvV5OSIklxgitP77/2TAgkEPjyklJ4KD0QNDjpu+YGGIyVTgE9YPBhpwuUlxRhux15vN8xzAXq4f5/xpyBPekIdbEaEUZHrKN/z9g8cgw9ZMWSrchbsE3QlU8MJK78HO+v3TjH7Ip+LffWNuhckiYnzT8Duy47vgc1OYqtJaDMN/ufK7yeNILK81M1ybHGOlqYxSfV/RM7oD0P5w5YeTXMpRsOyn4YVzhWSQFrlf08XbwlZUNm6Pb8eNRjM+3YyFTcUU/S81xKwOPRNNhlPnxz+tUltCR3H/0Falu1pxJYT2qfuM9j9z9xA1bJEsSSZ1b2bsHw7ujpRmg0xsPUk7DXIQ1Kh92BFfmDoZWeqsMF1E7H8iuaVsN9k96BwbBfiB4stQqI3ycuHO9zbsa12y8AQusDbr9W8rl/vR0pKNrcNO32ojOzkblJGWgyNxDvTS4l69+qi6pMBONicUUMQnXEtJoasjpECzwlAHIYJMmFQUuloEafR8b0ZAaCw+I5SfsyYF4hHLYseHvMavxgLNZ6W4ZlaL9XmQ7ZGhh10ub4ceW61QvCzKD34yO1yl8PcmS8Fa7bZbGxkq36oCusGbD65AlY+w== ben@lithium diff --git a/Com/Simatime/keys/deploy.pub b/Com/Simatime/keys/deploy.pub deleted file mode 100644 index 664a2d9..0000000 --- a/Com/Simatime/keys/deploy.pub +++ /dev/null @@ -1 +0,0 @@ -ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAACAQDlLRbbXgwjF7IqObf4dZE/jj0HoT6xJR6bP/6ZrJz7NPCPIgY3GacOtBfkJp6KK0zKQdFmxNpcfb3zgpe/Ru7pkmSfI9IoWAU3aLPWK2G3tbLPmktGmF9C53OhyXgFtBGr2Q/+wSRKAfN/FrEEa2FuRBtvtcAMiwbQLbFCzlmWhE7swSBvg38ZSFrjhANsEhfNVCtsrtG16fkfrfmBFv4JIog1fEoMKmXg7rhMjpaas8+n52HMFXvjllePRpywK4wB20GOcOuDSdc3i3zs7NFuicGunEpW2S/byrHotSWHZ9VuUwPn3GJ6xorrGyvsRuPS2anhHTSBxYCqYdXg0BIYUn1x5Uhtzd8kIU06gSLsvuhqGCLNucnXAT1Zix7pSlO21be81SX4vwQEth+6Dkm6kja0ArHZL6wglF8Njd1fV9iOwvcS07clwa/2S8suFLwVrQXz16vfAfA2zi4/qeop5Sv9W4DIOZuIMPmbWZCoy7L6Fu4+x4prb8LCQNM5m4CP3HngCW8PpxtBbBJd0dcXVap1HgDTIt/CLH8ms52uX5k3bHuvzryOihSuwmi/cDZAJAmbgclM9klsZr4R/GAoAWhhGxXM2tLuiwZ2nLvCPlXbBazZpdM2aC3VIwnMwJrJFu2u9B6RSsz2ijbygecT98UmiMYK7Mk1y6GkvY+mDQ== ben@lithium diff --git a/Com/Simatime/keys/nick.pub b/Com/Simatime/keys/nick.pub deleted file mode 100644 index 4dc08fb..0000000 --- a/Com/Simatime/keys/nick.pub +++ /dev/null @@ -1 +0,0 @@ -ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAACAQDfSOxXJTQADjROqbaiJtjbJaHTsBtuWNvQpDvXLigl9R27VqIn7dYk2STuWglwFyrvYfU1UmjgJcJ6J2KbXGTH5mhaC04MJ4aqmOR3Ynnq7nDzmtEtn1I+K7LmpFXsFXgOTzIlzggIWflGd1pPBwgWqMoPDcSqNQFPI/+rk1JOxk3e2Mq60VTp9WM9hs0AJQEyZ+wwZ0vyrj588kQb6jQUZ7qx1UZoDzPc57zREEZbQeU1Gd9FK2bCHlKOBHYlqIftSRBGGCpuo7zobhajR0xHO9RnF0NmeLbW85XhDus8vVgBg/BTDPxHEzm5jKiCkc+i3ia0Ff9mp2zgtSdXCp5jbVZ3AYfYLi1zbPWmaSdWqFx2ntOLwWR3/RHjw6+b4KmUQ4xtQHyXOijTBCH29i7VCo7l8WL+I2mSGJ7/Wtw7NFtMpVVs8/0iKt2t12FIefzvbZoWU7vbmuO7+gQI5l+F+JE6DLWOl04vT/V98WxiHA5rbCjTT/bubs4gTeCR9qNehaoM+apitpUP8HXygnxD7EJeK6JNkdub9TY663IkiKlpnWgeoDTNSP7JF/jkU0Nt8yoR2pTyxQqMFYa37/3WKjmSHk1TgxLEmlwHQFtIkTPn8PL+VLa4ACYuWUjxS4aMRpxo9eJUHdy0Y04yKxXN8BLw7FAhytm2pTXtT4zqaQ== nicksima@gmail.com diff --git a/Com/Simatime/packages.nix b/Com/Simatime/packages.nix deleted file mode 100644 index 4ffbbf8..0000000 --- a/Com/Simatime/packages.nix +++ /dev/null @@ -1,18 +0,0 @@ -{ pkgs, ... }: - -with pkgs; - -{ - environment.systemPackages = [ - file - gitAndTools.gitFull - htop - python3 - ranger - telnet - tinc_pre - traceroute - vnstat - wget - ]; -} diff --git a/Com/Simatime/users.nix b/Com/Simatime/users.nix deleted file mode 100644 index b52043e..0000000 --- a/Com/Simatime/users.nix +++ /dev/null @@ -1,39 +0,0 @@ -{ config, ... }: - -{ - users.motd = '' - - welcome to the simatime network! - your host is '${config.networking.hostName}' - - ''; - users.mutableUsers = false; - users.users = { # - # bots - # - deploy = { - isNormalUser = true; - home = "/home/deploy"; - openssh.authorizedKeys.keyFiles = [ ./keys/deploy.pub ]; - extraGroups = [ "wheel" ]; - }; - # - # humans - # - root.openssh.authorizedKeys.keyFiles = [ ./keys/ben.pub ]; - ben = { - description = "Ben Sima"; - isNormalUser = true; - home = "/home/ben"; - openssh.authorizedKeys.keyFiles = [ ./keys/ben.pub ]; - extraGroups = [ "wheel" "networkmanager" "docker" ]; - }; - nick = { - description = "Nick Sima"; - isNormalUser = true; - home = "/home/nick"; - openssh.authorizedKeys.keyFiles = [ ./keys/nick.pub ]; - extraGroups = [ "docker" ]; - }; - }; -} diff --git a/Com/Simatime/vpnHosts.nix b/Com/Simatime/vpnHosts.nix deleted file mode 100644 index 1a66e92..0000000 --- a/Com/Simatime/vpnHosts.nix +++ /dev/null @@ -1,37 +0,0 @@ -let - mkVpnPeer = { address, subnet, ed25519PublicKey, rsaPublicKey }: '' - Address = ${address} - Subnet = ${subnet} - Ed25519PublicKey = ${ed25519PublicKey} - ${rsaPublicKey} - ''; -in { - "com.simatime" = mkVpnPeer { - address = "159.89.128.69"; - subnet = "10.1.1.25"; - ed25519PublicKey = "TODO"; - rsaPublicKey = '' - TODO - ''; - }; - "com.simatime.dev" = mkVpnPeer { - address = "69.181.254.154"; - subnet = "10.1.1.21"; - ed25519PublicKey = "s5/rbuM7WaYqaZH0BP4/mYefrl3uWfaT+Ew4gmSsh8F"; - rsaPublicKey = '' - -----BEGIN RSA PUBLIC KEY----- - MIICCgKCAgEAydQHK4jUQnp4ZSqIB/fjfLxILqy/IHR6DPiUp/HustFDOaLKSVM8 - 75fVtBybiEkUmXLU3Bg8WX9zR+llTf3za1B13w+uJpcR4FS/LhAN/wgHCdgHUb4W - D7YZzGUnLhPAu3Ivnu5QZ6vzigqtbPCIFfwGDW2RGjq3iJMag1sM/xBOZrSn+zsZ - azCEP/snY30UE5ggrxJSMpZXSpS9u266nTblo8gTwfjdzrC93gmNNIxdHpeYGb0O - VGdaMmExq5Ny4flG2qtWA0u8nDscg7bEVIYfPjZr1G2FT5A0Ma4kteu6TeYpQEd9 - 0if3lRb48iMwh1VBfXBps9Heexz0HjG6EAku2B1mEL5orjmC3jJK0DpuXnwVN5pz - B+UrFnqbFykeHxZD5RdAB1tcuHZlJ/mQyZRQMJtkifFLdj4iBBK+si05GpodGhIz - iXkMYRIOja9/4EyukDdU2i2yEOmgif6DhIh4awss1b2Crtxs2bg6/xi2Hy63IQEy - u8LxuiPGA69NsaFZz49SXXJw11KQt5g7WE0jweYXmT3VO6yZlktGdJjzXyhaw7ma - G9VgHvxh+K/mDZ2SXwDcINzwYwZxxqcxcmA4o8glCKQyVHIT5hlo7QkSzK4P+GgN - Js+sRDreM6Rha2zcOaJWZ5IO2Xva6AZZ29oO5m4V/CYPCuMAzXwV2GMCAwEAAQ== - -----END RSA PUBLIC KEY----- - ''; - }; -} diff --git a/Control/Concurrent/Sema.hs b/Control/Concurrent/Sema.hs new file mode 100644 index 0000000..e804cc3 --- /dev/null +++ b/Control/Concurrent/Sema.hs @@ -0,0 +1,12 @@ +module Control.Concurrent.Sema + ( mapPool + ) +where + +import qualified Control.Concurrent.MSem as Sem + +-- | Simaphore-based throttled 'mapConcurrently'. +mapPool :: Traversable t => Int -> (a -> IO b) -> t a -> IO (t b) +mapPool n f xs = do + sima <- Sem.new n + mapConcurrently (Sem.with sima . f) xs diff --git a/Hero/App.hs b/Hero/App.hs new file mode 100644 index 0000000..7f55052 --- /dev/null +++ b/Hero/App.hs @@ -0,0 +1,748 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Hero.App where + +import Alpha +import qualified Clay +import qualified Hero.Assets as Assets +import Hero.Look as Look +import Hero.Look.Typography +import Network.RemoteData +import Data.Aeson ( ToJSON(..) + , FromJSON(..) + , genericToJSON + , genericParseJSON + , defaultOptions + ) +import qualified Data.List as List +import qualified Data.List.Split as List +import Data.Proxy ( Proxy(..) ) +import Data.String +import Data.String.Quote +import Data.Text ( Text, replace, toLower ) +import GHC.Generics ( Generic ) +import qualified GHC.Show as Legacy +import Miso +import qualified Miso (for_) +import Miso.String +import Protolude hiding (replace) +import Servant.API ( Capture + , URI(..) + , safeLink + , (:<|>)(..) + , (:>) + ) +import Servant.Links ( linkURI ) + +crossorigin_ :: MisoString -> Attribute action +crossorigin_ = textProp "crossorigin" + +-- | The css id for controling music in the comic player. +audioId :: MisoString +audioId = "audioSource" + +-- | Like 'onClick' but prevents the default action from triggering. Use this to +-- overide 'a_' links, for example. +onPreventClick :: Action -> Attribute Action +onPreventClick action = + onWithOptions Miso.defaultOptions { preventDefault = True } + "click" emptyDecoder (\() -> action) + +-- TODO: make ComicId a hashid https://hackage.haskell.org/package/hashids-1.0.2.4/docs/Web-Hashids.html +type ComicId = String + +-- | Class for turning different string types to snakeCase. +class CanSnakeCase str where + snake :: str -> str + +instance CanSnakeCase Text where + snake = Data.Text.replace " " "-" . Data.Text.toLower + +-- | Used for looking up images on S3, mostly +comicSlug :: Comic -> Text +comicSlug Comic{..} = snake comicName <> "-" <> comicIssue + +data Comic = Comic + { comicId :: ComicId + , comicPages :: Integer + , comicName :: Text + , comicIssue :: Text -- ^ Ideally this would be a dynamic number-like type + , comicDescription :: Text + } deriving (Show, Eq, Generic) + +instance ToJSON Comic where + toJSON = genericToJSON Data.Aeson.defaultOptions + +instance FromJSON Comic where + parseJSON = genericParseJSON Data.Aeson.defaultOptions + +-- | Class for rendering media objects in different ways. +class IsMediaObject o where + -- | Render a thumbnail for use in a shelf, or otherwise. + thumbnail :: o -> View Action + -- | Render a featured banner. + feature :: o -> Library -> View Action + -- | Media info view + info :: o -> Library -> View Action + +instance IsMediaObject Comic where + thumbnail c@Comic{..} = li_ [] + [ a_ + [ class_ "comic grow clickable" + , id_ $ "comic-" <> ms comicId + , onClick $ SetMediaInfo $ Just c + ] + [ img_ [ src_ $ ms $ Assets.demo <> comicSlug c <> ".png" ] + , span_ [] [ text $ "Issue #" <> ms comicIssue ] + , span_ [] [ text $ ms comicName ] + ] + ] + feature comic lib = div_ [ id_ "featured-comic" ] + [ img_ [ id_ "featured-banner", src_ $ ms $ Assets.demo <> "feature-banner.png" ] + , div_ [ id_ "featured-content" ] + [ div_ [ class_ "hero-original", css wide ] + [ span_ [ css thicc ] [ text "Herø" ] + , span_ [ css euro ] [ text " Original" ] + ] + , div_ [ class_ "comic-logo" ] + [ img_ [ src_ $ ms $ Assets.demo <> comicSlug comic <> "-logo.png" ] ] + , div_ [ class_ "comic-action-menu" ] $ el <$> [ Watch comic, Read comic, Save comic lib ] + , p_ [ class_ "description" ] + [ text . ms $ comicDescription comic + ] + ] + ] + info c@Comic {..} lib = div_ [ class_ "media-info", css euro ] + [ div_ [ class_ "media-info-meta" ] + [ column [ img_ [ src_ $ ms $ Assets.demo <> "dmc-widethumb.png" ] ] + , column + [ span_ [ style_ title ] [ text $ ms comicName ] + , span_ [ style_ subtitle ] [ text $ "Issue #" <> ms comicIssue ] + , span_ [] [ text "Released: " ] + , span_ [] [ text $ "Pages: " <> ms (show comicPages :: String) ] + ] + ] + , div_ [ class_ "media-info-summary" ] + [ p_ [ style_ $ uppercase <> bold <> Look.expanded <> "font-size" =: ".8rem" ] + [ text "Summary" ] + , p_ [] [ text $ ms comicDescription ] + ] + , div_ [ class_ "media-info-actions" ] $ el <$> [ Save c lib, Read c, Watch c ] + -- , row [ text "credits" ] + ] + where + title = "color" =: "red" <> "font-size" =: "1.6rem" <> uppercase + <> "line-height" =: "100%" <> Look.condensed <> bold + subtitle = "color" =: "#fff" <> "font-size" =: "1.2rem" <> bold <> Look.condensed + + +type ZoomModel = Int + +-- | All the buttons. +data Button + = Watch Comic | Read Comic | Save Comic Library + | SaveIcon Comic Library + | ZoomIcon ZoomModel Comic Page + | PlayPause MisoString AudioState + | Arrow Action + +-- | Class for defining general, widely used elements in the heroverse. +class Elemental v where el :: v -> View Action + +-- TODO: what if I just did this on all actions? +-- then I could e.g. `el $ ToggleAudio audioId audioState` +instance Elemental Button where + el (PlayPause id model) = button_ + [ class_ "button is-large icon" + , onClick $ ToggleAudio id + ] + [ i_ [ class_ $ "fa " <> icon ][]] + where + icon = case model of + Paused -> "fa-play-circle" + Playing -> "fa-pause-circle" + el (Arrow act) = button_ + [class_ "button is-large turn-page", onClick act] + [ img_ [src_ $ ms $ Assets.demo <> image <> ".png"]] + where image = case act of + PrevPage -> "prev-page" + NextPage -> "next-page" + _ -> "prev-page" + el (Save c lib) = + if c `elem` lib then -- in library + a_ [ class_ $ "wrs-button saved", onClick $ ToggleInLibrary c ] + [ img_ [ src_ $ ms $ Assets.icon <> "save.svg" ] + , span_ [] [ text "saved" ] + ] + else -- not in library + a_ [ class_ $ "wrs-button", onClick $ ToggleInLibrary c ] + [ img_ [ src_ $ ms $ Assets.icon <> "save.svg" ] + , span_ [] [ text "save" ] + ] + el (SaveIcon c lib) = + if c `elem` lib then -- in library + button_ + [ class_ "button is-large has-background-black" + , onClick $ ToggleInLibrary c + ] + [ img_ [ src_ $ ms $ Assets.demo <> "library-add.png" ] ] + else -- not in library + button_ + [ class_ "button is-large has-background-black-bis" + , onClick $ ToggleInLibrary c + ] + [ img_ [ src_ $ ms $ Assets.demo <> "library-add.png" ] ] + + el (ZoomIcon zmodel comic page) = button_ + [ id_ "zoom-button", class_ "button is-large" + , onClick $ ToggleZoom comic page + ] + [ img_ [ src_ $ ms $ Assets.demo <> "zoom.png" ] + , input_ + [ type_ "range", min_ "0", max_ "100", disabled_ True + , value_ $ ms (show zmodel :: String) + , class_ "ctrl", id_ "zoom" + ] + , label_ + [ class_ "ctrl", Miso.for_ "zoom" ] + [ text $ ms $ (show zmodel :: String) ++ "%" ] + ] + + el (Read c) = a_ [ class_ $ "wrs-button", onClick $ SelectExperience c ] + [ img_ [ src_ $ ms $ Assets.icon <> "read.svg" ] + , span_ [] [ text "read" ] + ] + + el (Watch c) = a_ [ class_ $ "wrs-button", onClick $ StartWatching c ] + [ img_ [ src_ $ ms $ Assets.icon <> "watch.svg" ] + , span_ [] [ text "watch" ] + ] + +data AudioState = Playing | Paused + deriving (Show, Eq) + +type Library = [Comic] + +data ComicReaderState + = NotReading + | Cover ComicId + | ChooseExperience ComicId Page + | Reading ComicReaderView ComicId Page + | Watching ComicId + deriving (Show, Eq) + +findComic :: ComicId -> [Comic] -> Maybe Comic +findComic id ls = List.find (\c -> comicId c == id) ls + +-- | Main model for the app. +-- +-- Try to prefix component-specific state with the component initials: 'd' for +-- discover, 'cp' for comic player. +data Model = Model + { uri :: URI + , appComics :: RemoteData MisoString [Comic] + , userLibrary :: Library + , dMediaInfo :: Maybe Comic + , cpState :: ComicReaderState + , cpAudioState :: AudioState + , zoomModel :: ZoomModel + } deriving (Show, Eq) + +initModel :: URI -> Model +initModel uri_ = + Model { uri = uri_ + , appComics = NotAsked + , dMediaInfo = Nothing + , userLibrary = Protolude.empty + , cpState = detectPlayerState uri_ + , cpAudioState = Paused + , zoomModel = 100 + } + +-- | Hacky way to initialize the 'ComicReaderState' from the URI. +detectPlayerState :: URI -> ComicReaderState +detectPlayerState u = case List.splitOn "/" $ uriPath u of + ["", "comic", id, pg, "experience"] -> ChooseExperience id $ toPage pg + ["", "comic", id, _, "video"] -> Watching id + ["", "comic", id, pg, "full"] -> Reading Full id $ toPage pg + ["", "comic", id, pg] -> Reading Spread id $ toPage pg + ["", "comic", id] -> Cover id + _ -> NotReading + where + toPage pg = fromMaybe 1 (readMaybe pg :: Maybe Page) + +type Page = Int + +data Action + = NoOp + -- comic player stuff + | SelectExperience Comic + | StartReading Comic + | StartWatching Comic + | NextPage + | PrevPage + | ToggleZoom Comic Page + | ToggleAudio MisoString + | FetchComics + | SetComics (RemoteData MisoString [Comic]) + | ToggleFullscreen + -- discover stuff + | SetMediaInfo (Maybe Comic) + | ToggleInLibrary Comic + -- app stuff + | ScrollIntoView MisoString + | HandleURI URI + | ChangeURI URI + | DumpModel + deriving (Show, Eq) + +type Discover = "discover" :> View Action + +type Home = + View Action + +type ComicCover = + "comic" + :> Capture "comicId" ComicId + :> View Action + +type ComicReaderSpread = + "comic" + :> Capture "id" ComicId + :> Capture "page" Page + :> View Action + +type ComicReaderFull = + "comic" + :> Capture "id" ComicId + :> Capture "page" Page + :> "full" + :> View Action + +type ComicVideo = + "comic" + :> Capture "id" ComicId + :> Capture "page" Page + :> "video" + :> View Action + +type ChooseExperience = + "comic" + :> Capture "id" ComicId + :> Capture "page" Page + :> "experience" + :> View Action + +type Login = + "login" :> View Action + +type ClientRoutes = Home + :<|> ComicCover :<|> ComicReaderSpread :<|> ComicReaderFull :<|> ComicVideo + :<|> Login :<|> Discover :<|> ChooseExperience + +handlers = home + :<|> comicCover :<|> comicPlayer :<|> comicPlayer :<|> comicPlayer + :<|> login :<|> discover :<|> comicPlayer + +routes :: Proxy ClientRoutes +routes = Proxy + +comicPlayerSpreadProxy :: Proxy ComicReaderSpread +comicPlayerSpreadProxy = Proxy + +comicPlayerFullProxy :: Proxy ComicReaderFull +comicPlayerFullProxy = Proxy + +chooseExperienceProxy :: Proxy ChooseExperience +chooseExperienceProxy = Proxy + +comicProxy :: Proxy ComicCover +comicProxy = Proxy + +comicVideoProxy :: Proxy ComicVideo +comicVideoProxy = Proxy + +homeProxy :: Proxy Home +homeProxy = Proxy + +loginProxy :: Proxy Login +loginProxy = Proxy + +discoverProxy :: Proxy Discover +discoverProxy = Proxy + +home :: Model -> View Action +home = login + +discover :: Model -> View Action +discover model@(Model { userLibrary = lib}) = template "discover" + [ topbar + , main_ [id_ "app-body"] $ case appComics model of + NotAsked -> [loading] + Loading -> [loading] + Failure _ -> [nocomics] + Success [] -> [nocomics] + Success (comic:rest) -> + [ feature comic lib + , shelf "Recent Releases" (comic:rest) + , maybeView (flip info lib) $ dMediaInfo model + ] + , appmenu + , discoverFooter + ] + +-- | If 'View' had a 'Monoid' instance, then '(text "")' could just be 'mempty' +maybeView :: (a -> View action) -> Maybe a -> View action +maybeView f obj = maybe (text "") f obj + +mediaInfo :: Maybe Comic -> Library -> View Action +mediaInfo Nothing _ = text "" +mediaInfo (Just comic) lib = div_ [ class_ "media-info" ] [ info comic lib ] + +appmenu :: View Action +appmenu = aside_ [ id_ "appmenu" ] $ btn img] + , span_ [] [ text label ] + ] + +-- TODO: make this a loading gif of some sort... maybe the hero icon filling from white to red +loading :: View Action +loading = div_ [ class_ "loading" ] [ text "Loading..." ] + +nocomics :: View Action +nocomics = div_ [ class_ "loading" ] [ text "error: no comics found" ] + +shelf :: IsMediaObject o => MisoString -> [o] -> View Action +shelf title comics = div_ [ class_ "shelf" ] + [ div_ [ class_ "shelf-head" ] [ text title ] + , ul_ [ class_ "shelf-body" ] $ thumbnail "hero-logo.svg" ]] + , span_ [] [ text "© Hero Records, Inc. All Rights Reserved" ] + ] + ] + where + attrs Nothing = [ class_ "social-icon" ] + attrs (Just lnk) = [ class_ "social-icon", href_ lnk, target_ "_blank" ] + smallImg x lnk = a_ (attrs lnk) + [ img_ [src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/" <> x ]] + +comicCover :: ComicId -> Model -> View Action +comicCover comicId_ model = comicPlayer comicId_ 1 model + +data ComicReaderView = Spread | Full + deriving (Show, Eq) + +comicPlayer :: ComicId -> Page -> Model -> View Action +comicPlayer _ _ model = case appComics model of + NotAsked -> loading + Loading -> loading + Failure _ -> nocomics + Success comics -> case cpState model of + NotReading -> template "comic-player" [ text "error: not reading" ] + Cover id -> viewOr404 comics comicSpread id 1 model + ChooseExperience id pg -> + viewOr404 comics chooseExperiencePage id pg model + Reading Spread id pg -> viewOr404 comics comicSpread id pg model + Reading Full id pg -> viewOr404 comics zoomScreen id pg model + Watching id -> viewOr404 comics comicVideo id 0 model + +viewOr404 :: [Comic] + -> (Comic -> Page -> Model -> View Action) + -> ComicId -> Page -> Model -> View Action +viewOr404 comics f id pg model = + case findComic id comics of + Just c -> f c pg model + Nothing -> the404 model + +template :: MisoString -> [View Action] -> View Action +template id rest = div_ [id_ id, class_ "app is-black"] rest + +closeButton :: View Action +closeButton = a_ [ id_ "close-button", onClick $ ChangeURI discoverLink ] + [ text "x" ] + +zoomScreen :: Comic -> Page -> Model -> View Action +zoomScreen comic page model = template "comic-player" + [ topbar + , main_ + [id_ "app-body"] + [ img_ + [ src_ comicImg + , class_ "comic-page-full" + ] + ] + , comicControls comic page model + ] + where + comicImg = + ms Assets.demo + <> ms (comicSlug comic) + <> "-" + <> padLeft page + <> ".png" + +comicSpread :: Comic -> Page -> Model -> View Action +comicSpread comic page model = template "comic-player" + [ topbar + , main_ + [id_ "app-body"] + [ div_ + [class_ "comic-player"] + [ img_ [ src_ comicImgLeft, class_ "comic-page" ] + , img_ [ src_ comicImgRight, class_ "comic-page" ] + ] + , closeButton + ] + , appmenu + , comicControls comic page model + ] + where + comicImgLeft, comicImgRight :: MisoString + comicImgLeft = + ms Assets.demo + <> ms (comicSlug comic) + <> "-" + <> padLeft page + <> ".png" + comicImgRight = + ms Assets.demo + <> ms (comicSlug comic) + <> "-" + <> (padLeft $ 1 + page) + <> ".png" + +frameborder_ :: MisoString -> Attribute action +frameborder_ = textProp "frameborder" + +allowfullscreen_ :: Bool -> Attribute action +allowfullscreen_ = boolProp "allowfullscreen" + +comicVideo :: Comic -> Page -> Model -> View Action +comicVideo _ _ _ = template "comic-player" + [ topbar + , main_ + [ id_ "app-body" ] + [ div_ [class_ "comic-video"] + [ iframe_ + [ src_ "//player.vimeo.com/video/325757560" + , frameborder_ "0" + , allowfullscreen_ True + ] + [] + ] + ] + ] + +padLeft :: Int -> MisoString +padLeft n | n < 10 = ms $ ("0" <> Legacy.show n) + | otherwise = ms $ Legacy.show n + +comicControls :: Comic -> Page -> Model -> View Action +comicControls comic page model = footer_ + [ id_ "app-foot", class_ "comic-controls" ] + [ div_ + [ class_ "comic-nav-audio" + , css $ flexCenter ] + [ audio_ + [id_ audioId, loop_ True, crossorigin_ "anonymous"] + [source_ [src_ $ ms $ Assets.demo <> "stars-instrumental.mp3"]] + , el $ PlayPause audioId $ cpAudioState model + , span_ + [ css $ euro <> thicc <> smol <> wide ] + [ text "Experiencing: Original" ] + ] + , div_ + [ class_ "comic-controls-pages", css euro ] + [ el $ Arrow $ PrevPage + , span_ [] [ text $ leftPage <> "-" <> rightPage <> " of " <> totalpages ] + , el $ Arrow $ NextPage + ] + , div_ [class_ "comic-controls-share"] + [ el $ SaveIcon comic $ userLibrary model + , el $ ZoomIcon (zoomModel model) comic page + , button_ + [class_ "button icon is-large", onClick ToggleFullscreen] + [i_ [ class_ "fa fa-expand" ] []] + ] + ] + where + leftPage = ms . Legacy.show $ page + rightPage = ms . Legacy.show $ 1 + page + totalpages = ms . Legacy.show $ comicPages comic + +login :: Model -> View Action +login _ = template "login" + [ div_ [ id_ "login-inner" ] + [ img_ [ class_ fadeIn + , src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/hero-large.png" + ] + , hr_ [class_ fadeIn] + , form_ [class_ fadeIn] + [ ctrl [class_ "input", type_ "email", placeholder_ "Email"] + , ctrl [class_ "input", type_ "password", placeholder_ "Password"] + , div_ [class_ "action", css euro] + [ div_ [class_ "checkbox remember-me"] + [ input_ [type_ "checkbox"] + , label_ [Miso.for_ "checkbox"] [text "Remember Me"] + ] + , div_ [class_ "button is-black", onClick $ ChangeURI discoverLink] + [ text "Login" ] + ] + ] + , hr_ [class_ fadeIn] + , p_ [ class_ $ "help " <> fadeIn ] + [ a_ [href_ "#"][text "Forgot your username or password?"] + , a_ [href_ "#"][text "Don't have an account? Sign Up"] + ] + , img_ [ id_ "hero-logo" + , class_ "blur-out" + , src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/success-her-image.png" + ] + ] + ] + where + fadeIn = "animated fadeIn delay-2s" + ctrl x = div_ [class_ "control"] [ input_ x ] + +chooseExperiencePage :: Comic -> Page -> Model -> View Action +chooseExperiencePage comic page model = template "choose-experience" + [ topbar + , main_ [ id_ "app-body" ] + [ h2_ [] [ text "Choose Your Musical Experience" ] + , p_ [] [ text experienceBlurb ] + , ul_ [] $ li comic name <> ".png" ] + , span_ [] [ text $ ms name ] + ] + , span_ [ css $ thicc ] [ text $ ms artist ] + , span_ [] [ text $ ms track ] + ] + experiences :: [(Text, Text, Text)] + experiences = + [ ("comedic", "RxGF", "Soft Reveal") + , ("dark", "Logan Henderson", "Speak of the Devil") + , ("original", "Mehcad Brooks", "Stars") + , ("energetic", "Skela", "What's wrong with me") + , ("dramatic", "Josh Jacobson", "Sideline") + ] + + +experienceBlurb :: MisoString +experienceBlurb = [s| +As you enter the world of Hero, you will find that music and visual art have a +symbiotic relationship that can only be experienced, not described. Here, choose +the tonality of the experience you wish to adventure on, whether it's a comedic, +dark, energetic or dramatic. Feeling indecisive? Let us navigate your journey +with the original curated music for this piece of visual art. +|] + +topbar :: View Action +topbar = header_ + [id_ "app-head", class_ "is-black", css euro] + [ a_ + [class_ "button is-medium is-black", onClick $ ChangeURI homeLink] + [img_ [src_ $ ms $ Assets.icon <> "hero-logo.svg"]] + , div_ + [id_ "app-head-right"] + [ button_ [class_ "button icon is-medium is-black"] + [i_ [class_ "fas fa-search" ] []] + , button_ [ class_ "button is-medium is-black is-size-7" + , css $ euro <> wide <> thicc + ] + [text "News"] + , span_ [ class_ "icon is-large" ] + [ i_ [ class_ "fas fa-user" ] [] + ] + ] + ] + +row :: [View Action] -> View Action +row = div_ [ css $ Clay.display Clay.flex <> Clay.flexDirection Clay.row ] + +column :: [View Action] -> View Action +column = div_ [ css $ Clay.display Clay.flex <> Clay.flexDirection Clay.column ] + +-- | Links + +comicLink :: ComicId -> URI +comicLink comicId_ = linkURI $ safeLink routes comicProxy $ comicId_ + +comicPlayerSpreadLink :: ComicId -> Page -> URI +comicPlayerSpreadLink id page = + linkURI $ safeLink routes comicPlayerSpreadProxy id page + +comicPlayerFullLink :: ComicId -> Page -> URI +comicPlayerFullLink id page = + linkURI $ safeLink routes comicPlayerFullProxy id page + +comicVideoLink :: ComicId -> Page -> URI +comicVideoLink id page = + linkURI $ safeLink routes comicVideoProxy id page + +homeLink :: URI +homeLink = linkURI $ safeLink routes homeProxy + +loginLink :: URI +loginLink = linkURI $ safeLink routes loginProxy + +discoverLink :: URI +discoverLink = linkURI $ safeLink routes discoverProxy + +the404 :: Model -> View Action +the404 _ = template "404" [p_ [] [text "Not found"]] + +chooseExperienceLink :: ComicId -> Page -> URI +chooseExperienceLink id page = + linkURI $ safeLink routes chooseExperienceProxy id page diff --git a/Hero/Assets.hs b/Hero/Assets.hs new file mode 100644 index 0000000..06386b8 --- /dev/null +++ b/Hero/Assets.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | A module to wrap the CDN and provide convient helper functions to assets. +module Hero.Assets where + +import Protolude + +cdnEdge :: Text +cdnEdge = "https://heroverse.sfo2.cdn.digitaloceanspaces.com" + +demo :: Text +demo = cdnEdge <> "/old-assets/demo/" + +icon :: Text +icon = cdnEdge <> "/icons/" diff --git a/Hero/Client.hs b/Hero/Client.hs new file mode 100644 index 0000000..9a8fa02 --- /dev/null +++ b/Hero/Client.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | Hero app frontend +-- +-- : exe mmc.js +-- +-- : dep aeson +-- : dep clay +-- : dep containers +-- : dep miso +-- : dep protolude +-- : dep servant +-- : dep split +-- : dep string-quote +-- : dep text +-- : dep ghcjs-base +module Hero.Client where + +import Hero.App ( Action(..) + , Comic(..) + , ComicReaderState(..) + , ComicReaderView(..) + , Model(..) + , AudioState(..) + , audioId + , chooseExperienceLink + , comicPlayerSpreadLink + , comicPlayerFullLink + , comicVideoLink + , handlers + , initModel + , the404 + , routes + ) +import qualified Network.RemoteData as Network +import Data.Aeson ( eitherDecodeStrict ) +import qualified Data.Set as Set +import qualified GHC.Show as Legacy +import JavaScript.Web.XMLHttpRequest ( Request(..) + , Method(GET) + , RequestData(NoData) + , contents + , xhrByteString + ) +import Miso +import Miso.Effect.DOM (scrollIntoView) +import qualified Miso.FFI.Audio as Audio +import qualified Miso.FFI.Document as Document +import qualified Miso.FFI.Fullscreen as Fullscreen +import Miso.String +import Protolude + +-- | Entry point for a miso application +main :: IO () +main = miso $ \currentURI -> App { model = initModel currentURI, .. } + where + update = move + view = see + subs = [ uriSub HandleURI + , keyboardSub keynav + ] + events = defaultEvents + initialAction = FetchComics + mountPoint = Nothing + +(∈) :: Ord a => a -> Set a -> Bool +(∈) = Set.member + +-- | Keyboard navigation - maps keys to actions. +keynav :: Set Int -> Action +keynav ks + | 37 ∈ ks = PrevPage -- ^ left arrow + | 39 ∈ ks = NextPage -- ^ right arrow + | 191 ∈ ks = DumpModel -- ^ ? + | 32 ∈ ks = ToggleAudio audioId -- ^ SPC + | otherwise = NoOp + +see :: Model -> View Action +see model = + case runRoute routes handlers uri model of + Left _ -> the404 model + Right v -> v + +-- | Console-logging +foreign import javascript unsafe "console.log($1);" + say :: MisoString -> IO () + +-- | Updates model, optionally introduces side effects +move :: Action -> Model -> Effect Action Model +move NoOp model = noEff model +move DumpModel model = model <# do + say $ ms $ Legacy.show model + pure NoOp +move (SelectExperience comic) model = model { cpState = ChooseExperience (comicId comic) 1 } + <# do pure $ ChangeURI $ chooseExperienceLink (comicId comic) 1 +move (StartReading comic) model = model { cpState = Reading Spread (comicId comic) 1 } + <# do pure $ ChangeURI $ comicPlayerSpreadLink (comicId comic) 1 +move (StartWatching comic) model = model { cpState = Watching (comicId comic) } + <# do pure $ ChangeURI $ comicVideoLink (comicId comic) 1 +move NextPage model = case cpState model of + Reading Spread id pg -> + model { cpState = Reading Spread id (pg+2) } <# do + pure $ ChangeURI $ comicPlayerSpreadLink id (pg+2) + Reading Full id pg -> + model { cpState = Reading Full id (pg+1) } <# do + pure $ ChangeURI $ comicPlayerFullLink id (pg+1) + Cover id -> + model { cpState = Reading Spread id 1 } <# do + pure $ ChangeURI $ comicPlayerSpreadLink id 1 + _ -> noEff model +move PrevPage model = case cpState model of + Reading Spread id pg -> + model { cpState = Reading Spread id (pg-2) } <# do + pure $ ChangeURI $ comicPlayerSpreadLink id (pg-2) + Reading Full id pg -> + model { cpState = Reading Full id (pg-1) } <# do + pure $ ChangeURI $ comicPlayerFullLink id (pg-1) + Cover _ -> noEff model + _ -> noEff model +move (ToggleZoom c pg) m = m { cpState = newState } <# do pure act + where + goto lnk = ChangeURI $ lnk (comicId c) pg + reading v = Reading v (comicId c) pg + (newState, act) = case cpState m of + Reading Full _ _ -> (reading Spread, goto comicPlayerSpreadLink) + Reading Spread _ _ -> (reading Full, goto comicPlayerFullLink) + x -> (x, NoOp) +move (ToggleInLibrary c) model = model { userLibrary = newLib } <# pure NoOp + where + newLib | c `elem` (userLibrary model) = + Protolude.filter (/= c) $ userLibrary model + | otherwise = c : (userLibrary model) +move (HandleURI u) model = model { uri = u } <# pure NoOp +move (ChangeURI u) model = model <# do + pushURI u + pure NoOp +move FetchComics model = model <# (SetComics <$> fetchComics) +move (SetComics cs) model = noEff model { appComics = cs } +move (ToggleAudio i ) model = model { cpAudioState = newState } <# do + el <- Document.getElementById i + toggle el + pure NoOp + where + (newState, toggle) = case cpAudioState model of + Playing -> (Paused, Audio.pause) + Paused -> (Playing, Audio.play) +move ToggleFullscreen model = model { cpState = newState } <# do + el <- Document.querySelector "body" + -- TODO: check Document.fullscreenEnabled + -- https://developer.mozilla.org/en-US/docs/Web/API/Document/fullscreenEnabled + _ <- toggle el + pure NoOp + where + (toggle, newState) = case cpState model of + Reading Full c n -> (const Fullscreen.exit, Reading Full c n) + Reading Spread c n -> (Fullscreen.request, Reading Spread c n) + -- otherwise, do nothing: + x -> (pure, x) +move (SetMediaInfo x) model = model { dMediaInfo = x } <# do + case x of + Just Comic {comicId = id} -> + pure $ ScrollIntoView $ "comic-" <> ms id + Nothing -> + pure NoOp +move (ScrollIntoView id) model = model <# do + say $ ms $ Legacy.show id + scrollIntoView id + pure NoOp + +fetchComics :: IO (Network.RemoteData MisoString [Comic]) +fetchComics = do + mjson <- contents <$> xhrByteString req + case mjson of + Nothing -> + pure $ Network.Failure "Could not fetch comics from server." + Just json -> pure $ Network.fromEither + $ either (Left . ms) pure + $ eitherDecodeStrict json + where + req = Request + { reqMethod = GET + , reqURI = "/api/comic" -- FIXME: can we replace this hardcoding? + , reqLogin = Nothing + , reqHeaders = [] + , reqWithCredentials = False + , reqData = NoData + } diff --git a/Hero/Database.hs b/Hero/Database.hs new file mode 100644 index 0000000..5726f3c --- /dev/null +++ b/Hero/Database.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Hero.Database + ( ComicDB + , getComics + , load + , dummy + ) +where + +import Hero.App +import Data.Map ( Map ) +import qualified Data.Map as Map +import Dhall +import Protolude +import Servant ( Handler ) + +type ComicDB = (Map ComicId Comic) + +instance Interpret Comic + +load :: IO ComicDB +load = listToComicDB <$> input auto "./comic-database.dhall" + +dummy :: IO ComicDB +dummy = return $ listToComicDB + [ Comic { comicId = "ComicId" + , comicPages = 10 + , comicName = "Dummy comic" + , comicIssue = "dummy issue" + , comicDescription = "Lorem ipsum" + } + ] + +listToComicDB :: [Comic] -> ComicDB +listToComicDB ls = Map.fromList $ (,) <$> comicId <*> identity <$> ls + +getComics :: ComicDB -> Handler [Comic] +getComics db = return $ Map.elems db diff --git a/Hero/Look.hs b/Hero/Look.hs new file mode 100644 index 0000000..109ea76 --- /dev/null +++ b/Hero/Look.hs @@ -0,0 +1,567 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Styles +-- +-- Eventually move make this mostly well-typed. Use this EDSL: +-- http://fvisser.nl/clay/ +module Hero.Look where + +import Clay +import qualified Clay.Flexbox as Flexbox +import qualified Clay.Media as Media +import qualified Clay.Render as Clay +import qualified Clay.Stylesheet as Stylesheet +import Hero.Look.Typography as Typo +import qualified Data.Map as Map +import qualified Data.Text.Lazy as L +import Miso (Attribute, (=:), style_) +import Miso.String (MisoString, toMisoString) +import Protolude hiding ((**), (&), rem) + +main :: Css +main = do + -- bulma adjustments + input ? marginRight (px 10) <> marginBottom (px 10) + -- base + ".fixed" ? position fixed + ".clickable" ? clickable + ".row" ? do + display flex + alignItems center + justifyContent spaceBetween + a <> a # hover <> a # visited ? do + color white + textDecoration none + ".loading" ? do + display flex + justifyContent center + alignItems center + height $ vh 100 + width $ vw 100 + -- animations + ".grow" ? do + transition "all" (sec 0.2) easeInOut (sec 0.2) + ":hover" & transform (scale 1.1 1.1) + ".blur-out" ? do + position absolute + animation + "blur" + (sec 1) + easeInOut + (sec 1) + (iterationCount 1) + normal + forwards + keyframes "blur" [ (0, Clay.filter $ blur (px 0)) + , (50, Clay.filter $ blur (px 0)) + , (100, Clay.filter $ blur (px 10)) + ] + html <> body ? do + background nite + mobile $ do + overflowX hidden + width (vw 100) + -- general app wrapper stuf + ".app" ? do + display flex + justifyContent spaceBetween + alignItems stretch + flexDirection column + color white + "#hero-logo" ? zIndex (-1) + "#app-head" <> "#app-body" <> "#app-foot" ? flexGrow 1 + "#app-head" <> "#app-foot" ? do + display flex + alignItems center + flexShrink 0 + justifyContent spaceBetween + padding 0 (rem 2) 0 (rem 2) + width (pct 100) + height (px navbarHeight) + background nite + position fixed + zIndex 999 + "#app-head" ? do + alignSelf flexStart + borderBottom solid (px 3) grai + wide + top (px 0) + mobile $ noBorder <> width (vw 100) + "#app-body" ? do + display flex + desktop $ width (vw 93) + alignContent center + alignItems flexStart + justifyContent flexStart + flexDirection column + flexShrink 0 + padding (px 0) 0 0 0 + marginY $ px 74 + mobile $ flexDirection column + "#discover #app-body" ? do desktop $ marginLeft appmenuWidth + "#app-head-right" ? do + display flex + justifyContent spaceBetween + textTransform Clay.uppercase + thicc + alignItems center + width (px 200) + "#app-foot" ? do + alignSelf flexEnd + bottom (px 0) + mobile $ remove + "#app-foot-social" ? do + display flex + flexDirection column + alignSelf flexStart + ".social-icon" ? padding 0 (px 20) (px 10) 0 + "#app-foot-logo" ? do + display flex + flexDirection column + alignItems flexEnd + "#app-foot-quote" ? do + textTransform Clay.uppercase + textAlign center + -- hide app-foot-quote when it gets crowded + query Clay.all [Media.maxDeviceWidth (px 800)] $ + hide + + -- login + "#login" ? do + -- TODO: next 3 lines can be DRYed up, methinks + display flex + justifyContent center + alignItems center + alignSelf center + height (vh 100) + "#login-inner" ? do + display flex + justifyContent center + alignItems center + flexDirection column + zIndex 1 + height (vh 100) + width (px 400) + mobile $ width (vw 90) + "#login" ** ".help" ** a ? do + color white + display flex + alignItems center + flexDirection column + "#login" ** form <> "#login" ** hr ? do + width (pct 100) + "#login" ** hr ? border solid (px 1) grai + "#login" ** ".button" ? do + marginTop (px 10) + display inlineBlock + border solid (px 2) white + "#login" ** ".action" ? do + display flex + justifyContent spaceBetween + alignItems baseline + + -- choose your experience + "#choose-experience" ** "#app-body" ? do + euro <> wide + flexCenter + width (pct 100) + desktop $ marginLeft appmenuWidth <> height (vh 90) + mobile $ marginX (rem 0) <> marginTop (rem 0) <> minHeight (vh 90) + h2 ? do + thicc <> wide <> smol <> lower <> coat 2 + textAlign center + mobile $ coat 0.8 + p ? do + thicc <> coat 0.8 <> textAlign center + maxWidth (px 900) + marginAll (rem 1) + mobile $ coat 0.6 + ul ? do + display flex + flexDirection row + flexWrap Flexbox.wrap + justifyContent spaceAround + li ? do + width (px 111) + position relative + display flex + flexDirection column + textAlign center + mobile $ coat 0.6 + coat 0.8 <> clickable + divv thicc + + + + -- comic player + ".comic-player" ? marginAll auto + ".comic-page" <> ".comic-page-full" ? do + width auto + marginAll auto + transform (scale 1 1) + ".comic-page" ? height (vh 90) + let ccb = ".comic-controls" ** button + ccb <> ccb # hover ? do + background nite + borderColor nite + color white + ".comic-controls-pages" ? do + justifyContent center + alignItems center + display flex + ".comic-video" |> iframe ? do + position absolute + height (pct 93) + width (pct 100) + "#close-button" ? do + euro <> wide + position fixed + cursor pointer + let z = rem 1.8 + fontSize z + lineHeight z + let m = 24 :: Double + top $ px $ navbarHeight + m + left $ px $ m + zIndex 999 + + -- zoom button and slider + "#zoom-button" ? do + position relative + let sliderY = 75 + let sliderYY = 250 + euro <> wide + input ? do + transform $ Clay.rotate (deg (-90)) + margin 0 0 (px sliderYY) 0 + position absolute + height $ px sliderY + width $ px 200 + hide + label ? do + coat 0.9 + marginBottom $ px $ 2*sliderYY + position absolute + hide + ":hover" & ".ctrl" ? visibility visible + + -- discover + "#discover" ? do + alignItems flexStart + flexDirection column + ".media-info" ? do + padding (rem 2) 0 (rem 2) (rem 2) + margin (rem 2) 0 (rem 2) (rem 2) + borderTop solid (px 1) white + borderBottom solid (px 1) white + flexDirection row + display flex + alignItems center + justifyContent spaceBetween + mobile $ do + margin (rem 2) 0 (rem 2) 0 + padding 0 0 0 (rem 0) + noBorder + width (vw 100) + flexDirection column + ".media-info-meta" ? do + Flexbox.flex 2 1 (px 0) + display flex + flexDirection row + divv # lastChild wide + fontVariant smallCaps + position fixed + height (pct 100) + display flex + justifyContent center + zIndex 99 + alignContent center + alignItems center + flexDirection column + minWidth appmenuWidth + a ? do + display flex + flexDirection column + color white + background nite + borderColor nite + a |> img ? do + width (px 22) + height (px 22) + desktop $ a |> span ? remove + mobile $ do + order 2 + flexDirection row + position fixed + bottom (px 0) + width (vw 100) + height (px 74) + background nite + justifyContent center + alignItems center + a |> span ? fontSize (rem 0.5) + + button ? margin (rem 0.5) 0 (rem 0.5) 0 + + -- feature + "#featured-comic" ? do + display flex + flexDirection column + justifyContent center + Typo.euro + height (px 411) + mobile $ do + padding (px 0) 0 0 0 + margin 0 0 (px 50) 0 + after & do + display block + position relative + background $ linearGradient (straight sideTop) + [ (setA 0 nite, (pct 0)) + , (nite, (pct 100)) ] + let h = 149 + marginTop (px (-h)) + -- without +1, the gradient is offset by 1 px in chrome + height (px (h+1)) + content blank + ".hero-original" ? do + textTransform Clay.uppercase + fontSize (rem 1.2) + ".description" ? do + width (px 400) + mobile $ remove + "#featured-banner" ? do + position relative + minHeight (px 411) + minWidth (px 1214) + mobile $ marginLeft (px (-310)) + "#featured-content" ? do + position absolute + width (pct 100) + zIndex 9 + top (px 200) -- b/c Firefox & WebKit autocalc "top" differently + mobile $ do + marginTop (px 200) + alignItems center + display flex + flexDirection column + padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5) + width (vw 100) + + + -- buttons + "a.wrs-button" ? do -- the "watch/read/save" button + flexCenter + height (px 36) + width (px 132) + border solid (px 2) white + rounded + color white + margin 0 (px 15) (rem 1) 0 + fontSize (rem 0.8) + fontVariant smallCaps + euro <> thicc <> wide + mobile $ do + height (px 26) + width (px 100) + margin 0 (px 5) 0 (px 5) + fontSize (rem 0.6) + let alive = backgroundColor hero <> borderColor hero <> color white + ":hover" & alive + ".saved" & alive + img ? do + marginRight (px 7) + height (px 15) + mobile $ height (px 10) + + -- + ".comic-action-menu" ? display flex <> justifyContent (JustifyContentValue "left") + + -- shelving + ".shelf" ? do + display flex + flexDirection column + justifyContent flexStart + alignItems flexStart + mobile $ do + padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5) + width (vw 100) + ".comic" ? do + display flex + flexDirection column + justifyContent center + textAlign center + euro + maxWidth (px 110) + img ? do + marginBottom (rem 0.5) + minHeight (px 170) + minWidth (px 110) + ".shelf-head" ? do + width (pct 100) + margin (rem 1.5) 0 (rem 1.5) 0 + borderBottom solid (px 1) white + padding (rem 0.5) 0 0.5 0 + euro <> thicc + ".shelf-body" ? do + display flex + flexDirection row + justifyContent spaceBetween + width (vw 93) + alignItems baseline + li ? padding 0 (rem 0.5) 0 (rem 0.5) + overflowY visible + star ? overflowY visible + overflowX scroll + flexWrap Flexbox.nowrap + li Css +mobile = query Clay.all [Media.maxDeviceWidth (px 500)] + +desktop :: Css -> Css +desktop = query Clay.all [Media.minDeviceWidth (px 500)] + +rounded :: Css +rounded = borderRadius (px 30) (px 30) (px 30) (px 30) + +appmenuWidth :: Size LengthUnit +appmenuWidth = (px 67) + +flexCenter :: Css +flexCenter = do + display flex + justifyContent center + justifyItems center + alignContent center + alignItems center + +blank :: Content +blank = stringContent "" + +divv :: Clay.Selector +divv = Clay.div + +marginAll :: Size a -> Css +marginAll x = margin x x x x + +marginX :: Size a -> Css +marginX n = marginLeft n <> marginRight n + +marginY :: Size a -> Css +marginY n = marginTop n <> marginBottom n + +clickable :: Css +clickable = cursor pointer + +-- heroic colors --------------------------------------------------------------- + +hero :: Color +hero = rgb 241 32 32 -- #f12020 + +nite :: Color +nite = rgb 10 10 10 -- #0a0a0a + +grai :: Color +grai = rgb 221 221 221 -- #dddddd + +-- runtime (client) style stuff ------------------------------------------------ + +-- | Put 'Clay.Css' into a Miso-compatible style property. +-- +-- Allows us to use any amount of CSS written with Clay inlined in HTML or +-- dynamically as JavaScript object properties. The implementation is a bit +-- hacky, but works. +css :: Clay.Css -> Attribute action +css = Miso.style_ . Map.fromList . f . Clay.renderWith Clay.htmlInline [] + where + f :: L.Text -> [(MisoString, MisoString)] + f t = L.splitOn ";" t + <&> L.splitOn ":" + <&> \(x:y) -> (toMisoString x, toMisoString $ L.intercalate ":" y) + +inlineCss :: Css -> MisoString +inlineCss = toMisoString . render + +type Style = Map MisoString MisoString + +red :: MisoString +red = "#f12020" + +bold :: Style +bold = "font-weight" =: "bold" + +condensed :: Style +condensed = "font-stretch" =: "condensed" + +expanded :: Style +expanded = "font-stretch" =: "expanded" + +uppercase :: Style +uppercase = "text-transform" =: "uppercase" + +--------------------------------------------------------------------------------- +-- upstream this to Clay +--------------------------------------------------------------------------------- + + +newtype JustifyItemsValue = JustifyItemsValue Value + deriving (Val, Other, Inherit, Center, FlexEnd + , FlexStart, SpaceAround, SpaceBetween) + +justifyItems :: JustifyItemsValue -> Css +justifyItems = Stylesheet.key "justify-items" diff --git a/Hero/Look/Typography.hs b/Hero/Look/Typography.hs new file mode 100644 index 0000000..4d4f976 --- /dev/null +++ b/Hero/Look/Typography.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hero.Look.Typography where + +import Alpha +import Clay +import Clay.Stylesheet ( key ) +import qualified Hero.Assets as Assets +import Data.Semigroup ( (<>) ) + +main :: Css +main = fonts + +-- font modifiers + +euro, slim, wide, thicc, thinn, norm, lean, smol, lower, upper :: Css + +euro = fontFamily ["Eurostile"] [sansSerif] + +-- | stretch +slim = fontStretch condensed +wide = fontStretch expanded + +-- | weight +thicc = fontWeight bold +thinn = fontWeight normal + +-- | style +norm = fontStyle normal +lean = fontStyle italic + +-- | "smallcaps" is already taken by Clay +smol = fontVariant smallCaps + +lower = textTransform lowercase +upper = textTransform uppercase + +-- | font sizing + +-- | apparently "coat" is a synonym for "size" +coat :: Double -> Css +coat = fontSize . Clay.rem + +fontRoot :: Text +fontRoot = Assets.cdnEdge <> "/old-assets/fonts/eurostile/Eurostile" + +-- | font faces +fonts :: Css +fonts = + mconcat + $ mkEuro + fontStyle normal) + , ("LTStd-Bold.otf" , OpenType, thicc <> norm) + , ("LTStd-Cn.otf" , OpenType, slim <> norm) + , ("LTStd-Ex2.otf" , OpenType, wide <> norm) + , ("LTStd-BoldCn.otf" , OpenType, slim <> thicc) + , ("LTStd-BoldEx2.otf", OpenType, wide <> thicc) + ] + where + mkEuro :: (Text, FontFaceFormat, Css) -> Css + mkEuro (sufx, fmt, extra) = fontFace $ do + fontFamily ["Eurostile"] [] + fontFaceSrc [FontFaceSrcUrl (fontRoot <> sufx) $ Just fmt] + extra + +-- TODO: add the below to Clay.Font upstream + +newtype FontStretch = FontStretch Value + deriving (Val, Inherit, Normal, Other) + +expanded :: FontStretch +expanded = FontStretch "expanded" + +condensed :: FontStretch +condensed = FontStretch "condensed" + +fontStretch :: FontStretch -> Css +fontStretch = key "font-stretch" diff --git a/Hero/Prod.nix b/Hero/Prod.nix new file mode 100644 index 0000000..10650ee --- /dev/null +++ b/Hero/Prod.nix @@ -0,0 +1,43 @@ +{ config, pkgs, lib, ... }: +{ + imports = [ ]; + boot.loader.grub.device = "/dev/vda"; + fileSystems."/" = { device = "/dev/vda1"; fsType = "ext4"; }; + + services.herocomics = { + enable = true; + port = 3000; + server = pkgs.herocomics-server; + client = pkgs.herocomics-client; + }; + + networking = { + firewall.allowedTCPPorts = [ 22 80 443 ]; + nameservers = [ + "67.207.67.2" + "67.207.67.3" + ]; + defaultGateway = "138.68.40.1"; + defaultGateway6 = ""; + dhcpcd.enable = false; + usePredictableInterfaceNames = lib.mkForce true; + interfaces = { + eth0 = { + ipv4.addresses = [ + { address="138.68.40.97"; prefixLength=21; } + { address="10.46.0.5"; prefixLength=16; } + ]; + ipv6.addresses = [ + { address="fe80::b063:c4ff:fee5:d636"; prefixLength=64; } + ]; + ipv4.routes = [ { address = "138.68.40.1"; prefixLength = 32; } ]; + ipv6.routes = [ { address = ""; prefixLength = 32; } ]; + }; + + }; + }; + services.udev.extraRules = '' + ATTR{address}=="b2:63:c4:e5:d6:36", NAME="eth0" + + ''; +} diff --git a/Hero/Server.hs b/Hero/Server.hs new file mode 100644 index 0000000..730aada --- /dev/null +++ b/Hero/Server.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | Hero web app +-- +-- : exe mmc +-- +-- : dep aeson +-- : dep clay +-- : dep containers +-- : dep dhall +-- : dep envy +-- : dep http-types +-- : dep lucid +-- : dep miso +-- : dep mtl +-- : dep network-uri +-- : dep protolude +-- : dep servant +-- : dep servant-lucid +-- : dep servant-server +-- : dep split +-- : dep split +-- : dep string-quote +-- : dep text +-- : dep wai +-- : dep wai-app-static +-- : dep wai-extra +-- : dep wai-middleware-metrics +-- : dep warp +module Hero.Server where + +import qualified Clay +import Hero.App +import qualified Hero.Assets as Assets +import qualified Hero.Database as Database +import qualified Hero.Look as Look +import qualified Hero.Look.Typography + as Typography +import Data.Aeson +import Data.Proxy +import Data.Text ( Text ) +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy.Encoding as Lazy +import GHC.Generics +import qualified Lucid as L +import Lucid.Base +import Miso +import Miso.String +import Network.HTTP.Media ( (//) + , (/:) + ) +import Network.HTTP.Types hiding ( Header ) +import Network.Wai +import Network.Wai.Application.Static +import qualified Network.Wai.Handler.Warp as Warp +import Protolude +import Servant +import qualified System.Envy as Envy +import qualified System.Exit as Exit +import qualified System.IO as IO + + +main :: IO () +main = bracket startup shutdown $ uncurry Warp.run + where + say = IO.hPutStrLn IO.stderr + startup = Envy.decodeEnv >>= \case + Left e -> Exit.die e + Right c -> do + db <- Database.dummy + say $ "hero" + say $ "port: " ++ (show $ heroPort c) + say $ "client: " ++ heroClient c + let waiapp = app db c + return (heroPort c, waiapp) + shutdown :: a -> IO a + shutdown = pure . identity + +data Config = Config + { heroPort :: Warp.Port -- ^ HERO_PORT + , heroClient :: FilePath -- ^ HERO_CLIENT + } deriving (Generic, Show) + +instance Envy.DefConfig Config where + defConfig = Config 3000 "_bild/Hero.Client/static" + +instance Envy.FromEnv Config + +app :: Database.ComicDB -> Config -> Application +app db cfg = serve + (Proxy @AllRoutes) + ( static + :<|> cssHandlers + :<|> jsonHandlers db + :<|> serverHandlers + :<|> pure heroManifest + :<|> Tagged handle404 + ) + where static = serveDirectoryWith $ defaultWebAppSettings $ heroClient cfg + + +-- | HtmlPage for setting HTML doctype and header +newtype HtmlPage a = HtmlPage a + deriving (Show, Eq) + +-- | Convert client side routes into server-side web handlers +type ServerRoutes = ToServerRoutes ClientRoutes HtmlPage Action + +type JsonApi = "api" :> "comic" :> Get '[JSON] [Comic] + +type CssRoute = "css" :> "main.css" :> Get '[CSS] Text + +newtype CSS = CSS + { unCSS :: Text + } + +instance Accept CSS where + contentType _ = "text" // "css" /: ("charset", "utf-8") + +instance MimeRender CSS Text where + mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict + +cssHandlers :: Server CssRoute +cssHandlers = + return . Lazy.toStrict . Clay.render $ Typography.main <> Look.main + +type AllRoutes + = ("static" :> Raw) + :<|> + CssRoute + :<|> + JsonApi + :<|> + ServerRoutes + :<|> + ("manifest.json" :> Get '[JSON] Manifest) + :<|> + Raw + +data Manifest = Manifest + { name :: Text + , short_name :: Text + , start_url :: Text + , display :: Text + , theme_color :: Text + , description :: Text + } deriving (Show, Eq, Generic) + +instance ToJSON Manifest + +heroManifest :: Manifest +heroManifest = Manifest { name = "Hero" + , short_name = "Hero" + , start_url = "." + , display = "standalone" + , theme_color = "#0a0a0a" + , description = "Comics for all" + } + +handle404 :: Application +handle404 _ respond = + respond + $ responseLBS status404 [("Content-Type", "text/html")] + $ renderBS + $ toHtml + $ HtmlPage + $ the404 + $ initModel homeLink + +instance L.ToHtml a => L.ToHtml (HtmlPage a) where + toHtmlRaw = L.toHtml + toHtml (HtmlPage x) = do + L.doctype_ + L.html_ [L.lang_ "en"] $ do + L.head_ $ do + L.title_ "Hero [alpha]" + L.link_ [L.rel_ "manifest", L.href_ "/manifest.json"] + L.link_ [L.rel_ "icon", L.type_ ""] + + -- icons + L.link_ + [ L.rel_ "apple-touch-icon" + , L.sizes_ "180x180" + , L.href_ + $ Assets.cdnEdge + <> "/old-assets/images/favicons/apple-touch-icon.png" + ] + L.link_ + [ L.rel_ "icon" + , L.type_ "image/png" + , L.sizes_ "32x32" + , L.href_ + $ Assets.cdnEdge + <> "/old-assets/images/favicons/favicon-32x32.png" + ] + L.link_ + [ L.rel_ "icon" + , L.type_ "image/png" + , L.sizes_ "16x16" + , L.href_ + $ Assets.cdnEdge + <> "/old-assets/images/favicons/favicon-16x16.png" + ] + L.link_ + [ L.rel_ "manifest" + , L.href_ + $ Assets.cdnEdge + <> "/old-assets/images/favicons/manifest.json" + ] + L.link_ + [ L.rel_ "mask-icon" + , L.href_ + $ Assets.cdnEdge + <> "/old-assets/images/favicons/safari-pinned-tab.svg" + ] + + L.meta_ [L.charset_ "utf-8"] + L.meta_ [L.name_ "theme-color", L.content_ "#000"] + L.meta_ [L.httpEquiv_ "X-UA-Compatible", L.content_ "IE=edge"] + L.meta_ + [L.name_ "viewport", L.content_ "width=device-width, initial-scale=1"] + cssRef animateRef + cssRef bulmaRef + cssRef fontAwesomeRef + cssRef "/css/main.css" -- TODO: make this a safeLink? + jsRef "/static/mmc.js" + jsRef "/static/usersnap.js" + L.body_ (L.toHtml x) + where + jsRef href = L.with + (L.script_ mempty) + [ makeAttribute "src" href + , makeAttribute "async" mempty + , makeAttribute "defer" mempty + ] + cssRef href = L.with + (L.link_ mempty) + [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href] + +fontAwesomeRef :: MisoString +fontAwesomeRef = "https://use.fontawesome.com/releases/v5.7.2/css/all.css" + +animateRef :: MisoString +animateRef = + "https://cdnjs.cloudflare.com/ajax/libs/animate.css/3.7.0/animate.min.css" + +bulmaRef :: MisoString +bulmaRef = + "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css" + +serverHandlers :: Server ServerRoutes +serverHandlers = + homeHandler + :<|> comicCoverHandler + :<|> comicPageHandler + :<|> comicPageFullHandler + :<|> comicVideoHandler + :<|> loginHandler + :<|> discoverHandler + :<|> chooseExperienceHandler + +jsonHandlers :: Database.ComicDB -> Server JsonApi +jsonHandlers db = Database.getComics db + +homeHandler :: Handler (HtmlPage (View Action)) +homeHandler = pure . HtmlPage . home $ initModel homeLink + +comicCoverHandler :: ComicId -> Handler (HtmlPage (View Action)) +comicCoverHandler id = + pure . HtmlPage . comicCover id . initModel $ comicLink id + +comicPageHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) +comicPageHandler id n = + pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerSpreadLink id n + +comicPageFullHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) +comicPageFullHandler id n = + pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerFullLink id n + +comicVideoHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) +comicVideoHandler id n = + pure . HtmlPage . comicPlayer id n . initModel $ comicVideoLink id n + +loginHandler :: Handler (HtmlPage (View Action)) +loginHandler = pure . HtmlPage . login $ initModel loginLink + +discoverHandler :: Handler (HtmlPage (View Action)) +discoverHandler = pure . HtmlPage . discover $ initModel discoverLink + +chooseExperienceHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) +chooseExperienceHandler id n = + pure . HtmlPage . comicPlayer id n . initModel $ chooseExperienceLink id n diff --git a/Hero/Service.nix b/Hero/Service.nix new file mode 100644 index 0000000..f0f4227 --- /dev/null +++ b/Hero/Service.nix @@ -0,0 +1,76 @@ +{ options +, lib +, config +, pkgs +, modulesPath +}: + +let + cfg = config.services.herocomics; +in +{ + options.services.herocomics = { + enable = lib.mkEnableOption "Enable the herocomics service"; + port = lib.mkOption { + type = lib.types.int; + default = 3000; + description = '' + The port on which herocomics-server will listen for incoming HTTP traffic. + ''; + }; + server = lib.mkOption { + type = lib.types.package; + description = "herocomics-server package to use"; + }; + client = lib.mkOption { + type = lib.types.package; + description = "herocomics-client package to use"; + }; + domain = lib.mkOption { + type = lib.types.str; + default = "herocomics.app"; + description = '' + Domain on which to bind herocomics-server. This is passed + to services.nginx.virtualHosts. directly. + ''; + }; + }; + config = lib.mkIf cfg.enable { + systemd.services.herocomics = { + path = [ cfg.server ]; + wantedBy = [ "multi-user.target" ]; + script = '' + ${cfg.server}/bin/mmc + ''; + description = '' + Hero Comics app server + ''; + serviceConfig = { + KillSignal = "INT"; + Environment = [ + "HERO_CLIENT=${cfg.client}/static" + "HERO_PORT=${toString cfg.port}" + ]; + Type = "simple"; + Restart = "on-abort"; + RestartSec = "1"; + }; + }; + services.nginx = { + enable = cfg.enable; + recommendedGzipSettings = true; + recommendedOptimisation = true; + recommendedProxySettings = true; + recommendedTlsSettings = true; + virtualHosts = { + "${cfg.domain}" = { + forceSSL = true; + enableACME = true; + locations."/" = { + proxyPass = "http://localhost:${toString cfg.port}"; + }; + }; + }; + }; + }; +} diff --git a/Network/RemoteData.hs b/Network/RemoteData.hs new file mode 100644 index 0000000..2fe6557 --- /dev/null +++ b/Network/RemoteData.hs @@ -0,0 +1,31 @@ +-- | A port of Kris Jenkins' RemoteData Elm module +-- . +-- +module Network.RemoteData where + +data RemoteData a b + = NotAsked + | Loading + | Failure a + | Success b + deriving (Eq, Show) + +-- TODO figure out Http.Error +-- type WebData a = RemoteData Http.Error a + +instance Functor (RemoteData a) where + fmap _ NotAsked = NotAsked + fmap _ Loading = Loading + fmap _ (Failure a) = Failure a + fmap f (Success a) = Success (f a) + +instance Applicative (RemoteData e) where + pure = Success + NotAsked <*> _ = NotAsked + Loading <*> _ = Loading + Failure a <*> _ = Failure a + Success a <*> b = fmap a b + +fromEither :: Either a b -> RemoteData a b +fromEither (Left a) = Failure a +fromEither (Right a) = Success a diff --git a/Que/Prod.nix b/Que/Prod.nix new file mode 100644 index 0000000..97749c8 --- /dev/null +++ b/Que/Prod.nix @@ -0,0 +1,44 @@ +{ config, pkgs, lib, ... }: +{ + imports = [ ]; + boot.loader.grub.device = "/dev/vda"; + fileSystems."/" = { device = "/dev/vda1"; fsType = "ext4"; }; + networking.firewall.allowedTCPPorts = [ 22 80 443 ]; + services.que-server = { + enable = true; + port = 80; + package = pkgs.que-server; + }; + services.que-website = { + enable = true; + namespace = "_"; + package = pkgs.que-website; + }; + networking = { + nameservers = [ + "67.207.67.2" + "67.207.67.3" + ]; + defaultGateway = "157.245.224.1"; + defaultGateway6 = "2604:a880:2:d1::1"; + dhcpcd.enable = false; + usePredictableInterfaceNames = lib.mkForce true; + interfaces = { + eth0 = { + ipv4.addresses = [ + { address="157.245.236.44"; prefixLength=20; } + { address="10.46.0.5"; prefixLength=16; } + ]; + ipv6.addresses = [ + { address="2604:a880:2:d1::a2:5001"; prefixLength=64; } + { address="fe80::7892:a5ff:fec6:dbc3"; prefixLength=64; } + ]; + ipv4.routes = [ { address = "157.245.224.1"; prefixLength = 32; } ]; + ipv6.routes = [ { address = "2604:a880:2:d1::1"; prefixLength = 32; } ]; + }; + }; + }; + services.udev.extraRules = '' + ATTR{address}=="7a:92:a5:c6:db:c3", NAME="eth0" + ''; +} diff --git a/Que/Server.hs b/Que/Server.hs new file mode 100644 index 0000000..841cbfa --- /dev/null +++ b/Que/Server.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveGeneric #-} + +-- | Interprocess communication +-- +-- Prior art: +-- - +-- - +-- - +-- - sorta: and +-- +-- : exe que-server +-- +-- : dep async +-- : dep envy +-- : dep protolude +-- : dep scotty +-- : dep stm +-- : dep unagi-chan +-- : dep unordered-containers +module Que.Server + ( main + ) +where + +import Alpha hiding ( Text + , get + , gets + , modify + , poll + ) +import qualified Control.Concurrent.Go as Go +import qualified Control.Concurrent.STM as STM +import qualified Control.Exception as Exception +import Control.Monad.Reader ( MonadTrans ) +import qualified Data.ByteString.Builder.Extra as Builder +import qualified Data.ByteString.Lazy as BSL +import Data.HashMap.Lazy ( HashMap ) +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.Text.Encoding as Encoding +import Data.Text.Lazy ( Text + , fromStrict + ) +import qualified Data.Text.Lazy.IO as Text +import qualified Network.HTTP.Types.Status as Http +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp +import Network.Wai.Middleware.RequestLogger + ( logStdout ) +import qualified System.Envy as Envy +import qualified System.Exit as Exit +import qualified Web.Scotty.Trans as Scotty + +main :: IO () +main = Exception.bracket startup shutdown <| uncurry Warp.run + where + startup = Envy.decodeEnv >>= \case + Left e -> Exit.die e + Right c -> do + sync <- STM.newTVarIO initialAppState + let runActionToIO m = runReaderT (runApp m) sync + waiapp <- Scotty.scottyAppT runActionToIO routes + putText <| "port:" <> (show <| quePort c) + return (quePort c, waiapp) + shutdown :: a -> IO a + shutdown = pure . identity + +newtype App a = App + { runApp :: ReaderT (STM.TVar AppState) IO a + } + deriving (Applicative, Functor, Monad, MonadIO, MonadReader + (STM.TVar AppState)) + +data AppState = AppState + { ques :: HashMap Namespace Quebase + } + +initialAppState :: AppState +initialAppState = AppState { ques = mempty } + +data Config = Config + { quePort :: Warp.Port -- ^ QUE_PORT + } deriving (Generic, Show) + +instance Envy.DefConfig Config where + defConfig = Config 3000 + +instance Envy.FromEnv Config + +routes :: Scotty.ScottyT Text App () +routes = do + Scotty.middleware logStdout + + let quepath = "^\\/([[:alnum:]_]+)\\/([[:alnum:]._/]*)$" + let namespace = "^\\/([[:alnum:]_]+)\\/?$" -- matches '/ns' and '/ns/' but not '/ns/path' + + -- | GET /index.html + Scotty.get (Scotty.literal "/index.html") <| Scotty.redirect "/_/index" + Scotty.get (Scotty.literal "/") <| Scotty.redirect "/_/index" + + -- | GET /_/dash + Scotty.get (Scotty.literal "/_/dash") <| do + authkey <- fromMaybe "" Scotty.stream $ streamQue q + _ -> do + r <- liftIO <| Go.read q + Scotty.html <| fromStrict <| Encoding.decodeUtf8 r + + -- | POST que + -- + -- Put a value on a que. Returns immediately. + Scotty.post (Scotty.regex quepath) <| do + authkey <- fromMaybe "" > Scotty.text "not allowed: _ is a reserved namespace" + >> Scotty.finish + guardNs ns ["pub", "_"] + -- passed all auth checks + app . modify <| upsertNamespace ns + q <- app <| que ns qp + qdata <- Scotty.body + _ <- liftIO <| Go.write q <| BSL.toStrict qdata + return () + +-- | Given `guardNs ns whitelist`, if `ns` is not in the `whitelist` +-- list, return a 405 error. +guardNs :: Text -> [Text] -> Scotty.ActionT Text App () +guardNs ns whitelist = when (not <| ns `elem` whitelist) <| do + Scotty.status Http.methodNotAllowed405 + Scotty.text + <| "not allowed: use 'pub' namespace or signup to protect '" + <> ns + <> "' at https://que.run" + Scotty.finish + +-- | recover from a scotty-thrown exception. +(!:) + :: Scotty.ActionT Text App a -- ^ action that might throw + -> (Text -> Scotty.ActionT Text App a) -- ^ a function providing a default response instead + -> Scotty.ActionT Text App a +(!:) = Scotty.rescue + +-- | Forever write the data from 'Que' to 'Wai.StreamingBody'. +streamQue :: Que -> Wai.StreamingBody +streamQue q write _ = Go.mult q >>= loop + where + loop c = + Go.tap c + >>= (write . Builder.byteStringInsert) + >> (write <| Builder.byteStringInsert "\n") + >> loop c + +-- | Gets the thing from the Hashmap. Call's 'error' if key doesn't exist. +grab :: (Eq k, Hashable k) => k -> HashMap k v -> v +grab = flip (HashMap.!) + +-- | Inserts the namespace in 'AppState' if it doesn't exist. +upsertNamespace :: Namespace -> AppState -> AppState +upsertNamespace ns as = if HashMap.member ns (ques as) + then as + else as { ques = HashMap.insert ns mempty (ques as) } + +-- | Inserts the que at the proper 'Namespace' and 'Quepath'. +insertQue :: Namespace -> Quepath -> Que -> AppState -> AppState +insertQue ns qp q as = as { ques = newQues } + where + newQues = HashMap.insert ns newQbase (ques as) + newQbase = HashMap.insert qp q <| grab ns <| ques as + +extract :: Scotty.ActionT Text App (Namespace, Quepath) +extract = do + ns <- Scotty.param "1" + path <- Scotty.param "2" + return (ns, path) + +-- | A synonym for 'lift' in order to be explicit about when we are +-- operating at the 'App' layer. +app :: MonadTrans t => App a -> t App a +app = lift + +-- | Get something from the app state +gets :: (AppState -> b) -> App b +gets f = ask >>= liftIO . STM.readTVarIO >>= return . f + +-- | Apply a function to the app state +modify :: (AppState -> AppState) -> App () +modify f = ask >>= liftIO . atomically . flip STM.modifyTVar' f + +type Namespace = Text -- ^ housing for a set of que paths +type Que = Go.Channel Message -- ^ a que is just a channel of bytes +type Quepath = Text -- ^ any path can serve as an identifier for a que +type Message = ByteString -- ^ any opaque data +type Quebase = HashMap Quepath Que -- ^ a collection of ques + +-- | Lookup or create a que +que :: Namespace -> Quepath -> App Que +que ns qp = do + _ques <- gets ques + let qbase = grab ns _ques + queExists = HashMap.member qp qbase + if queExists + then return <| grab qp qbase + else do + c <- liftIO <| Go.chan 1 + modify (insertQue ns qp c) + gets ques /> grab ns /> grab qp diff --git a/Que/Server.nix b/Que/Server.nix new file mode 100644 index 0000000..e326483 --- /dev/null +++ b/Que/Server.nix @@ -0,0 +1,46 @@ +{ options +, lib +, config +, pkgs +, modulesPath +}: + +let + cfg = config.services.que-server; +in +{ + options.services.que-server = { + enable = lib.mkEnableOption "Enable the que-server service"; + port = lib.mkOption { + type = lib.types.int; + default = 3000; + description = '' + The port on which que-server will listen for + incoming HTTP traffic. + ''; + }; + package = lib.mkOption { + type = lib.types.package; + description = "que-server package to use"; + }; + }; + config = lib.mkIf cfg.enable { + systemd.services.que-server = { + path = [ cfg.package ]; + wantedBy = [ "multi-user.target" ]; + script = '' + ${cfg.package}/bin/que-server + ''; + description = '' + Que server + ''; + serviceConfig = { + Environment = ["QUE_PORT=${toString cfg.port}"]; + KillSignal = "INT"; + Type = "simple"; + Restart = "on-abort"; + RestartSec = "1"; + }; + }; + }; +} diff --git a/Que/Website.hs b/Que/Website.hs new file mode 100644 index 0000000..e75f2bd --- /dev/null +++ b/Que/Website.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} + +-- | spawns a few processes that serve the que.run website +-- +-- : exe que-website +-- +-- : dep async +-- : dep config-ini +-- : dep process +-- : dep protolude +-- : dep req +module Que.Website + ( main + ) +where + +import Alpha +import qualified Control.Concurrent.Async as Async +import qualified Data.ByteString.Char8 as BS +import qualified Data.Ini.Config as Config +import qualified Data.Text as Text +import Data.Text.Encoding ( encodeUtf8 ) +import qualified Data.Text.IO as Text +import Network.HTTP.Req +import qualified System.Directory as Directory +import System.Environment as Environment +import qualified System.Exit as Exit +import System.FilePath ( () ) +import qualified System.Process as Process + +main :: IO () +main = do + (src, ns) <- Environment.getArgs >>= \case + [src] -> return (src, "_") -- default to _ ns which is special + [src, ns] -> return (src, Text.pack ns) + _ -> Exit.die "usage: que-website [namespace]" + mKey <- getKey ns + putText $ "serving " <> Text.pack src <> " at " <> ns + run mKey ns $ Sources { index = src "index.md" + , client = src "client.py" + , quescripts = src "quescripts.md" + , style = src "style.css" + , apidocs = src "apidocs.md" + , tutorial = src "tutorial.md" + } + +getKey :: Namespace -> IO (Maybe Key) +getKey ns = do + home <- Directory.getHomeDirectory + let file = home ".config" "que.conf" + exists <- (Directory.doesFileExist file) + unless exists <| panic <| "not found: " <> Text.pack file + conf <- Text.readFile file + print (home ".config" "que.conf") + auth ns + |> Config.parseIniFile conf + |> either errorParsingConf identity + |> return + +errorParsingConf :: error +errorParsingConf = panic "could not parse ~/.config/que.conf" + +data Sources = Sources + { index :: FilePath + , quescripts :: FilePath + , client :: FilePath + , style :: FilePath + , tutorial :: FilePath + , apidocs :: FilePath + } + +type Namespace = Text +type Key = Text + +auth :: Namespace -> Config.IniParser (Maybe Key) +auth "pub" = pure Nothing +auth ns = Config.sectionMb ns <| Config.field "key" + +run :: Maybe Key -> Text -> Sources -> IO () +run key ns Sources {..} = Async.runConcurrently actions >> return () + where + actions = traverse + Async.Concurrently + [ forever <| toHtml index >>= serve key ns "index" + , forever <| toHtml quescripts >>= serve key ns "quescripts" + , forever <| BS.readFile client >>= serve key ns "client" + , forever <| toHtml tutorial >>= serve key ns "tutorial" + , forever <| toHtml apidocs >>= serve key ns "apidocs" + ] + toHtml :: FilePath -> IO ByteString + toHtml md = + BS.pack + <$> Process.readProcess + "pandoc" + [ "--include-in-header" + , style + , "-i" + , md + , "--from" + , "markdown" + , "--to" + , "html" + ] + [] + +serve :: Maybe Key -> Namespace -> Text -> ByteString -> IO () +serve Nothing "pub" path content = runReq defaultHttpConfig $ do + _ <- req POST + (http "que.run" /: "pub" /: path) + (ReqBodyBs content) + ignoreResponse + mempty + liftIO $ return () +serve Nothing p _ _ = panic <| "no auth key provided for ns: " <> p +serve (Just key) ns path content = runReq defaultHttpConfig $ do + let options = + header "Authorization" (encodeUtf8 key) <> responseTimeout maxBound + _ <- req POST + (http "que.run" /: ns /: path) + (ReqBodyBs content) + ignoreResponse + options + liftIO $ return () diff --git a/Que/Website.nix b/Que/Website.nix new file mode 100644 index 0000000..6a24d9d --- /dev/null +++ b/Que/Website.nix @@ -0,0 +1,59 @@ +{ options +, lib +, config +, pkgs +, modulesPath +}: + +let + cfg = config.services.que-website; + static = pkgs.stdenv.mkDerivation { + src = ./.; + name = "que-website-static"; + installPhase = '' + mkdir -p $out + cp ${./apidocs.md} $out/apidocs.md + cp ${./index.md} $out/index.md + cp ${./quescripts.md} $out/quescripts.md + cp ${./style.css} $out/style.css + cp ${./tutorial.md} $out/tutorial.md + cp ${./client.py} $out/client.py + ''; + }; +in +{ + options.services.que-website = { + enable = lib.mkEnableOption "Enable the que-website service"; + namespace = lib.mkOption { + type = lib.types.str; + default = "_"; + description = '' + The que namespace on which que-website will broadcast. + ''; + }; + package = lib.mkOption { + type = lib.types.package; + description = "que-website package to use"; + }; + }; + config = lib.mkIf cfg.enable { + systemd.services.que-website = { + path = [ cfg.package pkgs.pandoc ]; + wantedBy = [ "multi-user.target" ]; + script = '' + ${cfg.package}/bin/que-website ${static} ${cfg.namespace} + ''; + description = '' + Que website server + ''; + serviceConfig = { + User = "root"; + Environment = "HOME=/root"; + KillSignal = "INT"; + Type = "simple"; + Restart = "on-abort"; + RestartSec = "1"; + }; + }; + }; +} diff --git a/Que/apidocs.md b/Que/apidocs.md new file mode 100644 index 0000000..f400889 --- /dev/null +++ b/Que/apidocs.md @@ -0,0 +1,3 @@ +% que.run Api Docs + +coming soon diff --git a/Que/client.py b/Que/client.py new file mode 100755 index 0000000..3d9291d --- /dev/null +++ b/Que/client.py @@ -0,0 +1,149 @@ +#!/usr/bin/env python3 +""" +simple client for que.run +""" + +import argparse +import configparser +import http.client +import os +import subprocess +import sys +import time +import urllib.parse +import urllib.request as request + +MAX_TIMEOUT = 99999999 # basically never timeout + + +def auth(args): + ns = args.target.split("/")[0] + if ns == "pub": + return None + else: + conf_file = os.path.expanduser("~/.config/que.conf") + if not os.path.exists(conf_file): + sys.exit("you need a ~/.config/que.conf") + cfg = configparser.ConfigParser() + cfg.read(conf_file) + return cfg[ns]["key"] + + +def send(args): + "Send a message to the que." + key = auth(args) + data = args.infile + req = request.Request(f"{args.host}/{args.target}") + req.add_header("User-AgenT", "Que/Client") + if key: + req.add_header("Authorization", key) + if args.serve: + while not time.sleep(1): + request.urlopen(req, data=data, timeout=MAX_TIMEOUT) + + else: + request.urlopen(req, data=data, timeout=MAX_TIMEOUT) + + +def recv(args): + "Receive a message from the que." + + def _recv(_req): + msg = autodecode(_req.read()) + print(msg) + if args.then: + subprocess.run( + args.then.replace("\msg", msg).replace("\que", args.target), shell=True + ) + + params = urllib.parse.urlencode({"poll": args.poll}) + req = request.Request(f"{args.host}/{args.target}?{params}") + req.add_header("User-Agent", "Que/Client") + key = auth(args) + if key: + req.add_header("Authorization", key) + with request.urlopen(req) as _req: + if args.poll: + while not time.sleep(1): + _recv(_req) + else: + _recv(_req) + + +def autodecode(b): + """Attempt to decode bytes `b` into common codecs, preferably utf-8. If + no decoding is available, just return the raw bytes. + + For all available codecs, see: + + + """ + codecs = ["utf-8", "ascii"] + for codec in codecs: + try: + return b.decode(codec) + except UnicodeDecodeError: + pass + return b + + +def get_args(): + cli = argparse.ArgumentParser(description=__doc__) + cli.add_argument( + "--host", default="http://que.run", help="where que-server is running" + ) + cli.add_argument( + "--poll", default=False, action="store_true", help="stream data from the que" + ) + cli.add_argument( + "--then", + help=" ".join( + [ + "when polling, run this shell command after each response,", + "presumably for side effects," + "replacing '\que' with the target and '\msg' with the body of the response", + ] + ), + ) + cli.add_argument( + "--serve", + default=False, + action="store_true", + help=" ".join( + [ + "when posting to the que, do so continuously in a loop.", + "this can be used for serving a webpage or other file continuously", + ] + ), + ) + cli.add_argument( + "target", help="namespace and path of the que, like 'ns/path/subpath'" + ) + cli.add_argument( + "infile", + nargs="?", + type=argparse.FileType("rb"), + help="data to put on the que. Use '-' for stdin, otherwise should be a readable file", + ) + return cli.parse_args() + + +if __name__ == "__main__": + args = get_args() + try: + if args.infile: + send(args) + else: + recv(args) + except KeyboardInterrupt: + sys.exit(0) + except urllib.error.HTTPError as e: + print(e) + sys.exit(1) + except http.client.RemoteDisconnected as e: + print("disconnected... retrying in 5 seconds") + time.sleep(5) + if args.infile: + send(args) + else: + recv(args) diff --git a/Que/index.md b/Que/index.md new file mode 100644 index 0000000..a9db12e --- /dev/null +++ b/Que/index.md @@ -0,0 +1,73 @@ +% que.run + +que.run is the concurrent, async runtime in the cloud + + - runtime concurrency anywhere you have a network connection + - multilanguage communicating sequential processes + - add Go-like channels to any language + - connect your microservices together with the simplest possible + plumbing + - async programming as easy as running two terminal commands + +HTTP routes on `que.run` are Golang-like channels with a namespace and a +path. For example: `https://que.run/pub/path/subpath`. + +## Quickstart + +There is a simple script `que` that acts as a client you can use to +interact with the `que.run` service. + +Download it to somewhere on your `$PATH` and make it executable: + + curl https://que.run/_/client > ~/bin/que + chmod +x ~/bin/que + que --help + +The client requires a recent version of Python 3. + +## Powerup + +que.run is free for limited use, but the real power of an asynchronous, +concurrent runtime in the cloud is unlocked with some extra power-user +features. + +- Free + - security by obscurity + - all protocols and data formats supported + - bandwidth and message sizes limited + - concurrent connections limited + - request rate limited +- Power + - protect your data with private namespaces + - remove bandwidth and size limits + - private dashboard to see all of your active ques + - 99.999% uptime +- Pro + - add durability to your ques so messages are never lost + - powerful batch api + - incredible query api + - Linux FUSE filesystem integration +- Enterprise + - all of the Power & Pro features + - on-prem deployment + - advanced que performance monitoring + - SLA for support from que.run experts + +Email `ben@bsima.me` if you want to sign up for the Power, Pro, or +Enterprise packages. + +## Quescripts + +We are collecting a repository of scripts that make awesome use of que: + +- remote desktop notifications +- two-way communication with your phone +- ephemeral, serverless chat rooms +- collaborative jukebox + +See the scripts + +## Docs + +- [tutorial](/_/tutorial) +- [api docs](/_/apidocs) diff --git a/Que/quescripts.md b/Que/quescripts.md new file mode 100644 index 0000000..9a2e6e0 --- /dev/null +++ b/Que/quescripts.md @@ -0,0 +1,50 @@ +% Quescripts + +## Remote desktop notifications + +Lets say we are running a job that takes a long time, maybe we are +compiling or running a large test suite. Instead of watching the +terminal until it completes, or flipping back to check on it every so +often, we can create a listener that displays a popup notification when +the job finishes. + +In one terminal run the listener: + + que pub/notify --then "notify-send '\que' '\msg'" + +In some other terminal run the job that takes forever: + + runtests ; echo "tests are done" | que pub/notify - + +When terminal 2 succeeds, terminal 1 will print "tests are done", then +call the `notify-send` command, which displays a notification toast in +Linux with title "`pub/notify`" and content "`tests are done`". + +Que paths are multi-producer and multi-consumer, so you can add as many +terminals as you want. + +On macOS you could use: + + osascript -e 'display notification "\msg" with title "\que"' + +in place of notify-send. + +## Ephemeral, serverless chat rooms + +coming soon + +## Collaborative jukebox + +It's surprisingly easy to make a collaborative jukebox. + +First start up a music player: + + que --poll pub/music --then "playsong '\msg'" + +where `playsong` is a script that plays a file from data streaming to +`stdin`. For example [vlc](https://www.videolan.org/vlc/) does this when +you run it like `vlc -`. + +Then, anyone can submit songs with: + + que pub/music song.mp3 diff --git a/Que/style.css b/Que/style.css new file mode 100644 index 0000000..f8d1ca4 --- /dev/null +++ b/Que/style.css @@ -0,0 +1,136 @@ + + diff --git a/Que/tutorial.md b/Que/tutorial.md new file mode 100644 index 0000000..66ecd3c --- /dev/null +++ b/Que/tutorial.md @@ -0,0 +1,53 @@ +% que.run Tutorial + +## Ques + +A que is a multi-consumer, multi-producer channel available anywhere you +have a network connection. If you are familiar with Go channels, they +are pretty much the same thing. Put some values in one end, and take +them out the other end at a different time, or in a different process. + +Ques are created dynamically for every HTTP request you make. Here we +use the `que` client to create a new que at the path `pub/new-que`: + + que pub/new-que + +The `que` client is useful, but you can use anything to make the HTTP +request, for example here's the same thing with curl: + + curl https://que.run/pub/new-que + +These requests will block until a value is placed on the other +end. Let's do that now. In a separate terminal: + + echo "hello world" | que pub/new-que - + +This tells the `que` client to read the value from `stdin` and then send +it to `example/new-que`. Or with curl: + + curl https://que.run/pub/new-que -d "hello world" + +This will succeed immediately and send the string "`hello world`" over +the channel, which will be received and printed by the listener in the +other terminal. + +You can have as many producers and consumers attached to a channel as +you want. + +## Namespaces + +Ques are organized into namespaces, identified by the first fragment of +the path. In the above commands we used `pub` as the namespace, which is +a special publically-writable namespace. The other special namespace is +`_` which is reserved for internal use only. You can't write to the `_` +namespace. + +To use other namespaces and add authentication/access controls, you can +[sign up for the Power package](/_/index). + +## Events + +Just reading and writing data isn't very exciting, so let's throw in +some events. We can very quickly put together a job processor. + + que pub/new-que --then "./worker.sh '\msg'" diff --git a/README.md b/README.md index f8b92bd..ea5469c 100644 --- a/README.md +++ b/README.md @@ -26,10 +26,10 @@ what code we write, not just how we write it; that is by design. ## Layout -The source tree maps to the DNS namespace that we own. The purpose of -this mapping is to keep things organized hierarchically in how they are -deployed on the Internet. The main 'common' space is `Com.Simatime`, -other namespaces should be related to their application. +The source tree maps to the module namespace, and roughly follows the +Haskell namespace hierarchy (although nothing is enforced). The main +'common' space is `Biz`, other namespaces should be related to their +application. Development aspects should be localized to their sub-namespaces as much as possible. Only after sufficient iteration such that interfaces are diff --git a/Run/Que/Prod.nix b/Run/Que/Prod.nix deleted file mode 100644 index 97749c8..0000000 --- a/Run/Que/Prod.nix +++ /dev/null @@ -1,44 +0,0 @@ -{ config, pkgs, lib, ... }: -{ - imports = [ ]; - boot.loader.grub.device = "/dev/vda"; - fileSystems."/" = { device = "/dev/vda1"; fsType = "ext4"; }; - networking.firewall.allowedTCPPorts = [ 22 80 443 ]; - services.que-server = { - enable = true; - port = 80; - package = pkgs.que-server; - }; - services.que-website = { - enable = true; - namespace = "_"; - package = pkgs.que-website; - }; - networking = { - nameservers = [ - "67.207.67.2" - "67.207.67.3" - ]; - defaultGateway = "157.245.224.1"; - defaultGateway6 = "2604:a880:2:d1::1"; - dhcpcd.enable = false; - usePredictableInterfaceNames = lib.mkForce true; - interfaces = { - eth0 = { - ipv4.addresses = [ - { address="157.245.236.44"; prefixLength=20; } - { address="10.46.0.5"; prefixLength=16; } - ]; - ipv6.addresses = [ - { address="2604:a880:2:d1::a2:5001"; prefixLength=64; } - { address="fe80::7892:a5ff:fec6:dbc3"; prefixLength=64; } - ]; - ipv4.routes = [ { address = "157.245.224.1"; prefixLength = 32; } ]; - ipv6.routes = [ { address = "2604:a880:2:d1::1"; prefixLength = 32; } ]; - }; - }; - }; - services.udev.extraRules = '' - ATTR{address}=="7a:92:a5:c6:db:c3", NAME="eth0" - ''; -} diff --git a/Run/Que/Server.hs b/Run/Que/Server.hs deleted file mode 100644 index 0fc9fd1..0000000 --- a/Run/Que/Server.hs +++ /dev/null @@ -1,240 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE DeriveGeneric #-} - --- | Interprocess communication --- --- Prior art: --- - --- - --- - --- - sorta: and --- --- : exe que-server --- --- : dep async --- : dep envy --- : dep protolude --- : dep scotty --- : dep stm --- : dep unagi-chan --- : dep unordered-containers -module Run.Que.Server - ( main - ) -where - -import Alpha hiding ( Text - , get - , gets - , modify - , poll - ) -import qualified Control.Concurrent.Go as Go -import qualified Control.Concurrent.STM as STM -import qualified Control.Exception as Exception -import Control.Monad.Reader ( MonadTrans ) -import qualified Data.ByteString.Builder.Extra as Builder -import qualified Data.ByteString.Lazy as BSL -import Data.HashMap.Lazy ( HashMap ) -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.Text.Encoding as Encoding -import Data.Text.Lazy ( Text - , fromStrict - ) -import qualified Data.Text.Lazy.IO as Text -import qualified Network.HTTP.Types.Status as Http -import qualified Network.Wai as Wai -import qualified Network.Wai.Handler.Warp as Warp -import Network.Wai.Middleware.RequestLogger - ( logStdout ) -import qualified System.Envy as Envy -import qualified System.Exit as Exit -import qualified Web.Scotty.Trans as Scotty - -main :: IO () -main = Exception.bracket startup shutdown <| uncurry Warp.run - where - startup = Envy.decodeEnv >>= \case - Left e -> Exit.die e - Right c -> do - sync <- STM.newTVarIO initialAppState - let runActionToIO m = runReaderT (runApp m) sync - waiapp <- Scotty.scottyAppT runActionToIO routes - putText <| "port:" <> (show <| quePort c) - return (quePort c, waiapp) - shutdown :: a -> IO a - shutdown = pure . identity - -newtype App a = App - { runApp :: ReaderT (STM.TVar AppState) IO a - } - deriving (Applicative, Functor, Monad, MonadIO, MonadReader - (STM.TVar AppState)) - -data AppState = AppState - { ques :: HashMap Namespace Quebase - } - -initialAppState :: AppState -initialAppState = AppState { ques = mempty } - -data Config = Config - { quePort :: Warp.Port -- ^ QUE_PORT - } deriving (Generic, Show) - -instance Envy.DefConfig Config where - defConfig = Config 3000 - -instance Envy.FromEnv Config - -routes :: Scotty.ScottyT Text App () -routes = do - Scotty.middleware logStdout - - let quepath = "^\\/([[:alnum:]_]+)\\/([[:alnum:]._/]*)$" - let namespace = "^\\/([[:alnum:]_]+)\\/?$" -- matches '/ns' and '/ns/' but not '/ns/path' - - -- | GET /index.html - Scotty.get (Scotty.literal "/index.html") <| Scotty.redirect "/_/index" - Scotty.get (Scotty.literal "/") <| Scotty.redirect "/_/index" - - -- | GET /_/dash - Scotty.get (Scotty.literal "/_/dash") <| do - authkey <- fromMaybe "" Scotty.stream $ streamQue q - _ -> do - r <- liftIO <| Go.read q - Scotty.html <| fromStrict <| Encoding.decodeUtf8 r - - -- | POST que - -- - -- Put a value on a que. Returns immediately. - Scotty.post (Scotty.regex quepath) <| do - authkey <- fromMaybe "" > Scotty.text "not allowed: _ is a reserved namespace" - >> Scotty.finish - guardNs ns ["pub", "_"] - -- passed all auth checks - app . modify <| upsertNamespace ns - q <- app <| que ns qp - qdata <- Scotty.body - _ <- liftIO <| Go.write q <| BSL.toStrict qdata - return () - --- | Given `guardNs ns whitelist`, if `ns` is not in the `whitelist` --- list, return a 405 error. -guardNs :: Text -> [Text] -> Scotty.ActionT Text App () -guardNs ns whitelist = when (not <| ns `elem` whitelist) <| do - Scotty.status Http.methodNotAllowed405 - Scotty.text - <| "not allowed: use 'pub' namespace or signup to protect '" - <> ns - <> "' at https://que.run" - Scotty.finish - --- | recover from a scotty-thrown exception. -(!:) - :: Scotty.ActionT Text App a -- ^ action that might throw - -> (Text -> Scotty.ActionT Text App a) -- ^ a function providing a default response instead - -> Scotty.ActionT Text App a -(!:) = Scotty.rescue - --- | Forever write the data from 'Que' to 'Wai.StreamingBody'. -streamQue :: Que -> Wai.StreamingBody -streamQue q write _ = Go.mult q >>= loop - where - loop c = - Go.tap c - >>= (write . Builder.byteStringInsert) - >> (write <| Builder.byteStringInsert "\n") - >> loop c - --- | Gets the thing from the Hashmap. Call's 'error' if key doesn't exist. -grab :: (Eq k, Hashable k) => k -> HashMap k v -> v -grab = flip (HashMap.!) - --- | Inserts the namespace in 'AppState' if it doesn't exist. -upsertNamespace :: Namespace -> AppState -> AppState -upsertNamespace ns as = if HashMap.member ns (ques as) - then as - else as { ques = HashMap.insert ns mempty (ques as) } - --- | Inserts the que at the proper 'Namespace' and 'Quepath'. -insertQue :: Namespace -> Quepath -> Que -> AppState -> AppState -insertQue ns qp q as = as { ques = newQues } - where - newQues = HashMap.insert ns newQbase (ques as) - newQbase = HashMap.insert qp q <| grab ns <| ques as - -extract :: Scotty.ActionT Text App (Namespace, Quepath) -extract = do - ns <- Scotty.param "1" - path <- Scotty.param "2" - return (ns, path) - --- | A synonym for 'lift' in order to be explicit about when we are --- operating at the 'App' layer. -app :: MonadTrans t => App a -> t App a -app = lift - --- | Get something from the app state -gets :: (AppState -> b) -> App b -gets f = ask >>= liftIO . STM.readTVarIO >>= return . f - --- | Apply a function to the app state -modify :: (AppState -> AppState) -> App () -modify f = ask >>= liftIO . atomically . flip STM.modifyTVar' f - -type Namespace = Text -- ^ housing for a set of que paths -type Que = Go.Channel Message -- ^ a que is just a channel of bytes -type Quepath = Text -- ^ any path can serve as an identifier for a que -type Message = ByteString -- ^ any opaque data -type Quebase = HashMap Quepath Que -- ^ a collection of ques - --- | Lookup or create a que -que :: Namespace -> Quepath -> App Que -que ns qp = do - _ques <- gets ques - let qbase = grab ns _ques - queExists = HashMap.member qp qbase - if queExists - then return <| grab qp qbase - else do - c <- liftIO <| Go.chan 1 - modify (insertQue ns qp c) - gets ques /> grab ns /> grab qp diff --git a/Run/Que/Server.nix b/Run/Que/Server.nix deleted file mode 100644 index e326483..0000000 --- a/Run/Que/Server.nix +++ /dev/null @@ -1,46 +0,0 @@ -{ options -, lib -, config -, pkgs -, modulesPath -}: - -let - cfg = config.services.que-server; -in -{ - options.services.que-server = { - enable = lib.mkEnableOption "Enable the que-server service"; - port = lib.mkOption { - type = lib.types.int; - default = 3000; - description = '' - The port on which que-server will listen for - incoming HTTP traffic. - ''; - }; - package = lib.mkOption { - type = lib.types.package; - description = "que-server package to use"; - }; - }; - config = lib.mkIf cfg.enable { - systemd.services.que-server = { - path = [ cfg.package ]; - wantedBy = [ "multi-user.target" ]; - script = '' - ${cfg.package}/bin/que-server - ''; - description = '' - Que server - ''; - serviceConfig = { - Environment = ["QUE_PORT=${toString cfg.port}"]; - KillSignal = "INT"; - Type = "simple"; - Restart = "on-abort"; - RestartSec = "1"; - }; - }; - }; -} diff --git a/Run/Que/Website.hs b/Run/Que/Website.hs deleted file mode 100644 index 52e46f9..0000000 --- a/Run/Que/Website.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE LambdaCase #-} - --- | spawns a few processes that serve the que.run website --- --- : exe que-website --- --- : dep async --- : dep config-ini --- : dep process --- : dep protolude --- : dep req -module Run.Que.Website - ( main - ) -where - -import Alpha -import qualified Control.Concurrent.Async as Async -import qualified Data.ByteString.Char8 as BS -import qualified Data.Ini.Config as Config -import qualified Data.Text as Text -import Data.Text.Encoding ( encodeUtf8 ) -import qualified Data.Text.IO as Text -import Network.HTTP.Req -import qualified System.Directory as Directory -import System.Environment as Environment -import qualified System.Exit as Exit -import System.FilePath ( () ) -import qualified System.Process as Process - -main :: IO () -main = do - (src, ns) <- Environment.getArgs >>= \case - [src] -> return (src, "_") -- default to _ ns which is special - [src, ns] -> return (src, Text.pack ns) - _ -> Exit.die "usage: que-website [namespace]" - mKey <- getKey ns - putText $ "serving " <> Text.pack src <> " at " <> ns - run mKey ns $ Sources { index = src "index.md" - , client = src "client.py" - , quescripts = src "quescripts.md" - , style = src "style.css" - , apidocs = src "apidocs.md" - , tutorial = src "tutorial.md" - } - -getKey :: Namespace -> IO (Maybe Key) -getKey ns = do - home <- Directory.getHomeDirectory - let file = home ".config" "que.conf" - exists <- (Directory.doesFileExist file) - unless exists <| panic <| "not found: " <> Text.pack file - conf <- Text.readFile file - print (home ".config" "que.conf") - auth ns - |> Config.parseIniFile conf - |> either errorParsingConf identity - |> return - -errorParsingConf :: error -errorParsingConf = panic "could not parse ~/.config/que.conf" - -data Sources = Sources - { index :: FilePath - , quescripts :: FilePath - , client :: FilePath - , style :: FilePath - , tutorial :: FilePath - , apidocs :: FilePath - } - -type Namespace = Text -type Key = Text - -auth :: Namespace -> Config.IniParser (Maybe Key) -auth "pub" = pure Nothing -auth ns = Config.sectionMb ns <| Config.field "key" - -run :: Maybe Key -> Text -> Sources -> IO () -run key ns Sources {..} = Async.runConcurrently actions >> return () - where - actions = traverse - Async.Concurrently - [ forever <| toHtml index >>= serve key ns "index" - , forever <| toHtml quescripts >>= serve key ns "quescripts" - , forever <| BS.readFile client >>= serve key ns "client" - , forever <| toHtml tutorial >>= serve key ns "tutorial" - , forever <| toHtml apidocs >>= serve key ns "apidocs" - ] - toHtml :: FilePath -> IO ByteString - toHtml md = - BS.pack - <$> Process.readProcess - "pandoc" - [ "--include-in-header" - , style - , "-i" - , md - , "--from" - , "markdown" - , "--to" - , "html" - ] - [] - -serve :: Maybe Key -> Namespace -> Text -> ByteString -> IO () -serve Nothing "pub" path content = runReq defaultHttpConfig $ do - _ <- req POST - (http "que.run" /: "pub" /: path) - (ReqBodyBs content) - ignoreResponse - mempty - liftIO $ return () -serve Nothing p _ _ = panic <| "no auth key provided for ns: " <> p -serve (Just key) ns path content = runReq defaultHttpConfig $ do - let options = - header "Authorization" (encodeUtf8 key) <> responseTimeout maxBound - _ <- req POST - (http "que.run" /: ns /: path) - (ReqBodyBs content) - ignoreResponse - options - liftIO $ return () diff --git a/Run/Que/Website.nix b/Run/Que/Website.nix deleted file mode 100644 index 6a24d9d..0000000 --- a/Run/Que/Website.nix +++ /dev/null @@ -1,59 +0,0 @@ -{ options -, lib -, config -, pkgs -, modulesPath -}: - -let - cfg = config.services.que-website; - static = pkgs.stdenv.mkDerivation { - src = ./.; - name = "que-website-static"; - installPhase = '' - mkdir -p $out - cp ${./apidocs.md} $out/apidocs.md - cp ${./index.md} $out/index.md - cp ${./quescripts.md} $out/quescripts.md - cp ${./style.css} $out/style.css - cp ${./tutorial.md} $out/tutorial.md - cp ${./client.py} $out/client.py - ''; - }; -in -{ - options.services.que-website = { - enable = lib.mkEnableOption "Enable the que-website service"; - namespace = lib.mkOption { - type = lib.types.str; - default = "_"; - description = '' - The que namespace on which que-website will broadcast. - ''; - }; - package = lib.mkOption { - type = lib.types.package; - description = "que-website package to use"; - }; - }; - config = lib.mkIf cfg.enable { - systemd.services.que-website = { - path = [ cfg.package pkgs.pandoc ]; - wantedBy = [ "multi-user.target" ]; - script = '' - ${cfg.package}/bin/que-website ${static} ${cfg.namespace} - ''; - description = '' - Que website server - ''; - serviceConfig = { - User = "root"; - Environment = "HOME=/root"; - KillSignal = "INT"; - Type = "simple"; - Restart = "on-abort"; - RestartSec = "1"; - }; - }; - }; -} diff --git a/Run/Que/apidocs.md b/Run/Que/apidocs.md deleted file mode 100644 index f400889..0000000 --- a/Run/Que/apidocs.md +++ /dev/null @@ -1,3 +0,0 @@ -% que.run Api Docs - -coming soon diff --git a/Run/Que/client.py b/Run/Que/client.py deleted file mode 100755 index 3d9291d..0000000 --- a/Run/Que/client.py +++ /dev/null @@ -1,149 +0,0 @@ -#!/usr/bin/env python3 -""" -simple client for que.run -""" - -import argparse -import configparser -import http.client -import os -import subprocess -import sys -import time -import urllib.parse -import urllib.request as request - -MAX_TIMEOUT = 99999999 # basically never timeout - - -def auth(args): - ns = args.target.split("/")[0] - if ns == "pub": - return None - else: - conf_file = os.path.expanduser("~/.config/que.conf") - if not os.path.exists(conf_file): - sys.exit("you need a ~/.config/que.conf") - cfg = configparser.ConfigParser() - cfg.read(conf_file) - return cfg[ns]["key"] - - -def send(args): - "Send a message to the que." - key = auth(args) - data = args.infile - req = request.Request(f"{args.host}/{args.target}") - req.add_header("User-AgenT", "Que/Client") - if key: - req.add_header("Authorization", key) - if args.serve: - while not time.sleep(1): - request.urlopen(req, data=data, timeout=MAX_TIMEOUT) - - else: - request.urlopen(req, data=data, timeout=MAX_TIMEOUT) - - -def recv(args): - "Receive a message from the que." - - def _recv(_req): - msg = autodecode(_req.read()) - print(msg) - if args.then: - subprocess.run( - args.then.replace("\msg", msg).replace("\que", args.target), shell=True - ) - - params = urllib.parse.urlencode({"poll": args.poll}) - req = request.Request(f"{args.host}/{args.target}?{params}") - req.add_header("User-Agent", "Que/Client") - key = auth(args) - if key: - req.add_header("Authorization", key) - with request.urlopen(req) as _req: - if args.poll: - while not time.sleep(1): - _recv(_req) - else: - _recv(_req) - - -def autodecode(b): - """Attempt to decode bytes `b` into common codecs, preferably utf-8. If - no decoding is available, just return the raw bytes. - - For all available codecs, see: - - - """ - codecs = ["utf-8", "ascii"] - for codec in codecs: - try: - return b.decode(codec) - except UnicodeDecodeError: - pass - return b - - -def get_args(): - cli = argparse.ArgumentParser(description=__doc__) - cli.add_argument( - "--host", default="http://que.run", help="where que-server is running" - ) - cli.add_argument( - "--poll", default=False, action="store_true", help="stream data from the que" - ) - cli.add_argument( - "--then", - help=" ".join( - [ - "when polling, run this shell command after each response,", - "presumably for side effects," - "replacing '\que' with the target and '\msg' with the body of the response", - ] - ), - ) - cli.add_argument( - "--serve", - default=False, - action="store_true", - help=" ".join( - [ - "when posting to the que, do so continuously in a loop.", - "this can be used for serving a webpage or other file continuously", - ] - ), - ) - cli.add_argument( - "target", help="namespace and path of the que, like 'ns/path/subpath'" - ) - cli.add_argument( - "infile", - nargs="?", - type=argparse.FileType("rb"), - help="data to put on the que. Use '-' for stdin, otherwise should be a readable file", - ) - return cli.parse_args() - - -if __name__ == "__main__": - args = get_args() - try: - if args.infile: - send(args) - else: - recv(args) - except KeyboardInterrupt: - sys.exit(0) - except urllib.error.HTTPError as e: - print(e) - sys.exit(1) - except http.client.RemoteDisconnected as e: - print("disconnected... retrying in 5 seconds") - time.sleep(5) - if args.infile: - send(args) - else: - recv(args) diff --git a/Run/Que/index.md b/Run/Que/index.md deleted file mode 100644 index a9db12e..0000000 --- a/Run/Que/index.md +++ /dev/null @@ -1,73 +0,0 @@ -% que.run - -que.run is the concurrent, async runtime in the cloud - - - runtime concurrency anywhere you have a network connection - - multilanguage communicating sequential processes - - add Go-like channels to any language - - connect your microservices together with the simplest possible - plumbing - - async programming as easy as running two terminal commands - -HTTP routes on `que.run` are Golang-like channels with a namespace and a -path. For example: `https://que.run/pub/path/subpath`. - -## Quickstart - -There is a simple script `que` that acts as a client you can use to -interact with the `que.run` service. - -Download it to somewhere on your `$PATH` and make it executable: - - curl https://que.run/_/client > ~/bin/que - chmod +x ~/bin/que - que --help - -The client requires a recent version of Python 3. - -## Powerup - -que.run is free for limited use, but the real power of an asynchronous, -concurrent runtime in the cloud is unlocked with some extra power-user -features. - -- Free - - security by obscurity - - all protocols and data formats supported - - bandwidth and message sizes limited - - concurrent connections limited - - request rate limited -- Power - - protect your data with private namespaces - - remove bandwidth and size limits - - private dashboard to see all of your active ques - - 99.999% uptime -- Pro - - add durability to your ques so messages are never lost - - powerful batch api - - incredible query api - - Linux FUSE filesystem integration -- Enterprise - - all of the Power & Pro features - - on-prem deployment - - advanced que performance monitoring - - SLA for support from que.run experts - -Email `ben@bsima.me` if you want to sign up for the Power, Pro, or -Enterprise packages. - -## Quescripts - -We are collecting a repository of scripts that make awesome use of que: - -- remote desktop notifications -- two-way communication with your phone -- ephemeral, serverless chat rooms -- collaborative jukebox - -See the scripts - -## Docs - -- [tutorial](/_/tutorial) -- [api docs](/_/apidocs) diff --git a/Run/Que/quescripts.md b/Run/Que/quescripts.md deleted file mode 100644 index 9a2e6e0..0000000 --- a/Run/Que/quescripts.md +++ /dev/null @@ -1,50 +0,0 @@ -% Quescripts - -## Remote desktop notifications - -Lets say we are running a job that takes a long time, maybe we are -compiling or running a large test suite. Instead of watching the -terminal until it completes, or flipping back to check on it every so -often, we can create a listener that displays a popup notification when -the job finishes. - -In one terminal run the listener: - - que pub/notify --then "notify-send '\que' '\msg'" - -In some other terminal run the job that takes forever: - - runtests ; echo "tests are done" | que pub/notify - - -When terminal 2 succeeds, terminal 1 will print "tests are done", then -call the `notify-send` command, which displays a notification toast in -Linux with title "`pub/notify`" and content "`tests are done`". - -Que paths are multi-producer and multi-consumer, so you can add as many -terminals as you want. - -On macOS you could use: - - osascript -e 'display notification "\msg" with title "\que"' - -in place of notify-send. - -## Ephemeral, serverless chat rooms - -coming soon - -## Collaborative jukebox - -It's surprisingly easy to make a collaborative jukebox. - -First start up a music player: - - que --poll pub/music --then "playsong '\msg'" - -where `playsong` is a script that plays a file from data streaming to -`stdin`. For example [vlc](https://www.videolan.org/vlc/) does this when -you run it like `vlc -`. - -Then, anyone can submit songs with: - - que pub/music song.mp3 diff --git a/Run/Que/style.css b/Run/Que/style.css deleted file mode 100644 index f8d1ca4..0000000 --- a/Run/Que/style.css +++ /dev/null @@ -1,136 +0,0 @@ - - diff --git a/Run/Que/tutorial.md b/Run/Que/tutorial.md deleted file mode 100644 index 66ecd3c..0000000 --- a/Run/Que/tutorial.md +++ /dev/null @@ -1,53 +0,0 @@ -% que.run Tutorial - -## Ques - -A que is a multi-consumer, multi-producer channel available anywhere you -have a network connection. If you are familiar with Go channels, they -are pretty much the same thing. Put some values in one end, and take -them out the other end at a different time, or in a different process. - -Ques are created dynamically for every HTTP request you make. Here we -use the `que` client to create a new que at the path `pub/new-que`: - - que pub/new-que - -The `que` client is useful, but you can use anything to make the HTTP -request, for example here's the same thing with curl: - - curl https://que.run/pub/new-que - -These requests will block until a value is placed on the other -end. Let's do that now. In a separate terminal: - - echo "hello world" | que pub/new-que - - -This tells the `que` client to read the value from `stdin` and then send -it to `example/new-que`. Or with curl: - - curl https://que.run/pub/new-que -d "hello world" - -This will succeed immediately and send the string "`hello world`" over -the channel, which will be received and printed by the listener in the -other terminal. - -You can have as many producers and consumers attached to a channel as -you want. - -## Namespaces - -Ques are organized into namespaces, identified by the first fragment of -the path. In the above commands we used `pub` as the namespace, which is -a special publically-writable namespace. The other special namespace is -`_` which is reserved for internal use only. You can't write to the `_` -namespace. - -To use other namespaces and add authentication/access controls, you can -[sign up for the Power package](/_/index). - -## Events - -Just reading and writing data isn't very exciting, so let's throw in -some events. We can very quickly put together a job processor. - - que pub/new-que --then "./worker.sh '\msg'" diff --git a/System/Random/Shuffle.hs b/System/Random/Shuffle.hs new file mode 100644 index 0000000..02cd3e0 --- /dev/null +++ b/System/Random/Shuffle.hs @@ -0,0 +1,122 @@ +{- | +Module : System.Random.Shuffle +Copyright : (c) 2009 Oleg Kiselyov, Manlio Perillo +License : BSD3 (see LICENSE file) + + + + +Example: + + import System.Random (newStdGen) + import System.Random.Shuffle (shuffle') + + main = do + rng <- newStdGen + let xs = [1,2,3,4,5] + print $ shuffle' xs (length xs) rng +-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + +module System.Random.Shuffle + ( shuffle + , shuffle' + , shuffleM + ) +where + +import Data.Function ( fix ) +import System.Random ( RandomGen + , randomR + ) +import Control.Monad ( liftM + , liftM2 + ) +import Control.Monad.Random ( MonadRandom + , getRandomR + ) + + +-- | A complete binary tree, of leaves and internal nodes. +-- Internal node: Node card l r +-- where card is the number of leaves under the node. +-- Invariant: card >=2. All internal tree nodes are always full. +data Tree a = Leaf !a + | Node !Int !(Tree a) !(Tree a) + deriving Show + + +-- | Convert a sequence (e1...en) to a complete binary tree +buildTree :: [a] -> Tree a +buildTree = (fix growLevel) . (map Leaf) + where + growLevel _ [node] = node + growLevel self l = self $ inner l + + inner [] = [] + inner [e ] = [e] + inner (e1 : e2 : es) = e1 `seq` e2 `seq` (join e1 e2) : inner es + + join l@(Leaf _ ) r@(Leaf _ ) = Node 2 l r + join l@(Node ct _ _ ) r@(Leaf _ ) = Node (ct + 1) l r + join l@(Leaf _ ) r@(Node ct _ _) = Node (ct + 1) l r + join l@(Node ctl _ _) r@(Node ctr _ _) = Node (ctl + ctr) l r + + +-- |Given a sequence (e1,...en) to shuffle, and a sequence +-- (r1,...r[n-1]) of numbers such that r[i] is an independent sample +-- from a uniform random distribution [0..n-i], compute the +-- corresponding permutation of the input sequence. +shuffle :: [a] -> [Int] -> [a] +shuffle elements = shuffleTree (buildTree elements) + where + shuffleTree (Leaf e) [] = [e] + shuffleTree tree (r : rs) = + let (b, rest) = extractTree r tree in b : (shuffleTree rest rs) + shuffleTree _ _ = error "[shuffle] called with lists of different lengths" + + -- Extracts the n-th element from the tree and returns + -- that element, paired with a tree with the element + -- deleted. + -- The function maintains the invariant of the completeness + -- of the tree: all internal nodes are always full. + extractTree 0 (Node _ (Leaf e) r ) = (e, r) + extractTree 1 (Node 2 (Leaf l) (Leaf r)) = (r, Leaf l) + extractTree n (Node c (Leaf l) r) = + let (e, r') = extractTree (n - 1) r in (e, Node (c - 1) (Leaf l) r') + + extractTree n (Node n' l (Leaf e)) | n + 1 == n' = (e, l) + + extractTree n (Node c l@(Node cl _ _) r) + | n < cl + = let (e, l') = extractTree n l in (e, Node (c - 1) l' r) + | otherwise + = let (e, r') = extractTree (n - cl) r in (e, Node (c - 1) l r') + extractTree _ _ = error "[extractTree] impossible" + +-- |Given a sequence (e1,...en) to shuffle, its length, and a random +-- generator, compute the corresponding permutation of the input +-- sequence. +shuffle' :: RandomGen gen => [a] -> Int -> gen -> [a] +shuffle' elements len = shuffle elements . rseq len + where + -- The sequence (r1,...r[n-1]) of numbers such that r[i] is an + -- independent sample from a uniform random distribution + -- [0..n-i] + rseq :: RandomGen gen => Int -> gen -> [Int] + rseq n = fst . unzip . rseq' (n - 1) + where + rseq' :: RandomGen gen => Int -> gen -> [(Int, gen)] + rseq' 0 _ = [] + rseq' i gen = (j, gen) : rseq' (i - 1) gen' + where (j, gen') = randomR (0, i) gen + +-- |shuffle' wrapped in a random monad +shuffleM :: (MonadRandom m) => [a] -> m [a] +shuffleM elements + | null elements = return [] + | otherwise = liftM (shuffle elements) (rseqM (length elements - 1)) + where + rseqM :: (MonadRandom m) => Int -> m [Int] + rseqM 0 = return [] + rseqM i = liftM2 (:) (getRandomR (0, i)) (rseqM (i - 1)) diff --git a/default.nix b/default.nix index 86d584f..0463bc0 100644 --- a/default.nix +++ b/default.nix @@ -4,7 +4,7 @@ let bizpkgs = import "${nixpkgs-tar}" { overlays = [ overlay ]; }; nixos = import "${nixpkgs-tar}/nixos"; biz = import ./biz.nix { nixpkgs = bizpkgs; }; - buildOS = import ./Com/Simatime/buildOS.nix nixos; + buildOS = import ./Biz/buildOS.nix nixos; nixos-mailserver = let ver = "v2.3.0"; in builtins.fetchTarball { url = "https://gitlab.com/simple-nixos-mailserver/nixos-mailserver/-/archive/${ver}/nixos-mailserver-${ver}.tar.gz"; sha256 = "0lpz08qviccvpfws2nm83n7m2r8add2wvfg9bljx9yxx8107r919"; @@ -13,20 +13,20 @@ in rec { # Cloud infrastructure, always online. Mostly for messaging-related # stuff. # - Com.Simatime.Cloud = buildOS { + Biz.Cloud = buildOS { enableVpn = true; ipAddress = "159.89.128.69"; configuration = { imports = [ - ./Com/Simatime/packages.nix - ./Com/Simatime/users.nix - ./Com/Simatime/Cloud/chat.nix - ./Com/Simatime/Cloud/git.nix - ./Com/Simatime/Cloud/hardware.nix - ./Com/Simatime/Cloud/mail.nix - ./Com/Simatime/Cloud/networking.nix - ./Com/Simatime/Cloud/web.nix - ./Com/Simatime/Cloud/znc.nix + ./Biz/packages.nix + ./Biz/users.nix + ./Biz/Cloud/chat.nix + ./Biz/Cloud/git.nix + ./Biz/Cloud/hardware.nix + ./Biz/Cloud/mail.nix + ./Biz/Cloud/networking.nix + ./Biz/Cloud/web.nix + ./Biz/Cloud/znc.nix nixos-mailserver ]; networking.hostName = "simatime"; @@ -35,7 +35,7 @@ in rec { }; # Dev machine for work and building stuff. # - Com.Simatime.Dev = buildOS { + Biz.Dev = buildOS { enableVpn = true; ipAddress = "73.222.221.63"; deps = { @@ -43,10 +43,10 @@ in rec { }; configuration = { imports = [ - ./Com/Simatime/packages.nix - ./Com/Simatime/users.nix - ./Com/Simatime/Dev/configuration.nix - ./Com/Simatime/Dev/hardware.nix + ./Biz/packages.nix + ./Biz/users.nix + ./Biz/Dev/configuration.nix + ./Biz/Dev/hardware.nix ]; networking.hostName = "lithium"; networking.domain = "dev.simatime.com"; @@ -54,35 +54,35 @@ in rec { }; # The production server for que.run # - Run.Que.Prod = buildOS { + Que.Prod = buildOS { deps = { - que-server = Run.Que.Server; - que-website = Run.Que.Website; + que-server = Que.Server; + que-website = Que.Website; }; configuration = { imports = [ - ./Com/Simatime/packages.nix - ./Com/Simatime/users.nix - ./Run/Que/Server.nix - ./Run/Que/Website.nix - ./Run/Que/Prod.nix + ./Biz/packages.nix + ./Biz/users.nix + ./Que/Server.nix + ./Que/Website.nix + ./Que/Prod.nix ]; networking.hostName = "prod.que.run"; networking.domain = "que.run"; }; }; # Production server for musicmeetscomics.com - Com.MusicMeetsComics.Prod = buildOS { + Hero.Prod = buildOS { deps = { - herocomics-server = Com.MusicMeetsComics.Server; - herocomics-client = Com.MusicMeetsComics.Client; + herocomics-server = Hero.Server; + herocomics-client = Hero.Client; }; configuration = { imports = [ - ./Com/Simatime/packages.nix - ./Com/Simatime/users.nix - ./Com/MusicMeetsComics/Service.nix - ./Com/MusicMeetsComics/Prod.nix + ./Biz/packages.nix + ./Biz/users.nix + ./Hero/Service.nix + ./Hero/Prod.nix ]; networking.hostName = "prod.herocomics.app"; networking.domain = "herocomcis.app"; @@ -90,12 +90,12 @@ in rec { }; # Haskell targets # - Com.InfluencedByBooks.Server = biz.buildGhc Com/InfluencedByBooks/Server.hs; - Com.InfluencedByBooks.Client = biz.buildGhcjs Com/InfluencedByBooks/Client.hs; - Com.MusicMeetsComics.Server = biz.buildGhc Com/MusicMeetsComics/Server.hs; - Com.MusicMeetsComics.Client = biz.buildGhcjs Com/MusicMeetsComics/Client.hs; - Run.Que.Server = biz.buildGhc ./Run/Que/Server.hs; - Run.Que.Website = biz.buildGhc ./Run/Que/Website.hs; + Biz.Ibb.Server = biz.buildGhc Biz/Ibb/Server.hs; + Biz.Ibb.Client = biz.buildGhcjs Biz/Ibb/Client.hs; + Hero.Server = biz.buildGhc Hero/Server.hs; + Hero.Client = biz.buildGhcjs Hero/Client.hs; + Que.Server = biz.buildGhc ./Que/Server.hs; + Que.Website = biz.buildGhc ./Que/Website.hs; # Development environment repl = biz.globalGhc; # Fall through to any of our overlay packages diff --git a/push-all b/push-all index dcc4df2..8c33d91 100755 --- a/push-all +++ b/push-all @@ -1,11 +1,11 @@ #!/usr/bin/env bash set -ex -bild Com.Simatime.Cloud -push Com.Simatime.Cloud simatime.com +bild Biz.Cloud +push Biz.Cloud simatime.com -bild Com.Simatime.Dev -push Com.Simatime.Dev dev.simatime.com +bild Biz.Dev +push Biz.Dev dev.simatime.com -bild Run.Que.Prod -push Run.Que.Prod que.run +bild Que.Prod +push Que.Prod que.run -- cgit v1.2.3