clone url: git://git.m455.casa/sp
src/main.scm
| 1 | (import utf8 |
| 2 | (chicken file) |
| 3 | (chicken file posix) |
| 4 | (chicken format) |
| 5 | (chicken io) |
| 6 | (chicken pathname) |
| 7 | (chicken process) |
| 8 | (chicken process-context) |
| 9 | (chicken string)) |
| 10 | |
| 11 | (include "src/config.scm") |
| 12 | (include "src/ansi.scm") |
| 13 | (include "src/messages.scm") |
| 14 | |
| 15 | (define config-file (make-pathname (get-environment-variable "HOME") ".sp")) |
| 16 | |
| 17 | (define (displayln str) |
| 18 | (display str) |
| 19 | (newline)) |
| 20 | |
| 21 | (define-syntax displayln-format |
| 22 | (syntax-rules () |
| 23 | ((_ str v ...) |
| 24 | (displayln (format str v ...))))) |
| 25 | |
| 26 | ;; use pair? here, instead of list?, because list? returns #t if alist is |
| 27 | ;; '() |
| 28 | (define (get alist key) |
| 29 | (if (and (pair? alist) |
| 30 | (pair? (car alist)) |
| 31 | (symbol? key)) |
| 32 | (cadr (assq key alist)) |
| 33 | alist)) |
| 34 | |
| 35 | (define (keys alist) |
| 36 | (map car alist)) |
| 37 | |
| 38 | (define (vals alist) |
| 39 | (map cadr alist)) |
| 40 | |
| 41 | (define (file->sexp f) |
| 42 | (if (file-exists? f) |
| 43 | (with-input-from-file f (lambda () (read))) |
| 44 | '())) |
| 45 | |
| 46 | (define (expand-path-home path) |
| 47 | (if (equal? "~" (substring path 0 1)) |
| 48 | (make-pathname (get-environment-variable "HOME") (substring path 1)) |
| 49 | path)) |
| 50 | |
| 51 | (define (has-trailing-slash? str) |
| 52 | (eq? #\/ (string-ref str (- (string-length str) 1)))) |
| 53 | |
| 54 | (define (config-fix-value str) |
| 55 | (if (has-trailing-slash? str) |
| 56 | str |
| 57 | (string-append str "/"))) |
| 58 | |
| 59 | (define config-alist (if (file-exists? config-file) |
| 60 | (file->sexp config-file) |
| 61 | '())) |
| 62 | |
| 63 | (define (config-get key) |
| 64 | (case key |
| 65 | ('url (config-fix-value (get config-alist key))) |
| 66 | ((remote-paste-directory local-paste-directory) |
| 67 | (expand-path-home (config-fix-value (get config-alist key)))) |
| 68 | (else (get config-alist key)))) |
| 69 | |
| 70 | ;; this seems unnecessary, but i was using (get messages ...) so often that i |
| 71 | ;; just needed this |
| 72 | (define (message key) |
| 73 | (get messages key)) |
| 74 | |
| 75 | ;; TODO maybe remove this? |
| 76 | (define (run-shell-command str) |
| 77 | (define-values (in out process-id) (process str))) |
| 78 | |
| 79 | (define (conditional-paint str color-key) |
| 80 | (if (equal? (config-get 'color) "yes") |
| 81 | (paint str color-key) |
| 82 | str)) |
| 83 | |
| 84 | (define (displayln-to-file path contents) |
| 85 | (if (file-exists? path) |
| 86 | (displayln-format (message 'file-already-exists) |
| 87 | (conditional-paint path 'red)) |
| 88 | (with-output-to-file path (lambda () (displayln contents))))) |
| 89 | |
| 90 | (define (string-lowercase s) |
| 91 | (string-translate s "ABCDEFGHIJKLMNOPQRSTUVWXYZ" |
| 92 | "abcdefghijklmnopqrstuvwxyz")) |
| 93 | |
| 94 | (define (init-prompt) |
| 95 | (displayln-format (message 'init-prompt) |
| 96 | (conditional-paint config-file 'blue)) |
| 97 | (display "> ") |
| 98 | (let ((input (string-lowercase (read-line)))) |
| 99 | (if (equal? "y" input) |
| 100 | (begin (displayln-format (message 'file-creating) |
| 101 | (conditional-paint config-file 'blue)) |
| 102 | (displayln-to-file config-file config-file-contents) |
| 103 | (displayln-format (message 'file-creating-finished) |
| 104 | (conditional-paint config-file 'blue))) |
| 105 | (displayln (message 'init-cancelled))))) |
| 106 | |
| 107 | (define (file-fix-extension path) |
| 108 | (let* ((file (pathname-strip-directory path)) |
| 109 | (file-extension (pathname-extension file))) |
| 110 | (if (member file-extension (config-get 'preserved-extensions)) |
| 111 | file |
| 112 | (string-append file ".txt")))) |
| 113 | |
| 114 | (define (path->paste-url path) |
| 115 | (let ((url (config-get 'url)) |
| 116 | (file (file-fix-extension path))) |
| 117 | (if (member (pathname-extension file) (config-get 'preserved-extensions)) |
| 118 | (string-append url file) |
| 119 | (string-append url file ".txt")))) |
| 120 | |
| 121 | (define (file-backup path) |
| 122 | (let* ((file (file-fix-extension path)) |
| 123 | (paste-directory (config-get 'local-paste-directory)) |
| 124 | (destination (make-pathname paste-directory file))) |
| 125 | ;; #t here overwrites the file if it exists |
| 126 | (copy-file path destination #t) |
| 127 | ;; 420 is 644 permissions (-rw-r--r--) |
| 128 | (set-file-permissions! destination 420))) |
| 129 | |
| 130 | (define (file-upload path) |
| 131 | (let* ((file (file-fix-extension path)) |
| 132 | (source (make-pathname (config-get 'local-paste-directory) file)) |
| 133 | (destination (config-get 'remote-paste-directory))) |
| 134 | (call-with-input-pipe |
| 135 | (format "rsync -a --delete ~a ~a" source destination) read))) |
| 136 | |
| 137 | (define (copy-to-clipboard path) |
| 138 | (let ((paste-url (path->paste-url path))) |
| 139 | (system (format "echo \"~a\" | tr -d '\n' | xclip -selection clipboard" paste-url)) |
| 140 | (displayln-format (message 'copied-to-clipboard) |
| 141 | (conditional-paint paste-url 'green)))) |
| 142 | |
| 143 | (define (paste-file arg) |
| 144 | (let ((path (expand-path-home arg))) |
| 145 | (if (file-exists? config-file) |
| 146 | (if (file-exists? path) |
| 147 | (begin (displayln-format (message 'file-uploading) |
| 148 | (conditional-paint path 'yellow)) |
| 149 | (file-backup path) |
| 150 | (file-upload path) |
| 151 | (displayln-format (message 'file-uploaded) |
| 152 | (conditional-paint path 'green)) |
| 153 | (copy-to-clipboard path)) |
| 154 | (displayln-format (message 'file-doesnt-exist) |
| 155 | (conditional-paint path 'red))) |
| 156 | (begin (displayln-format (message 'file-doesnt-exist) |
| 157 | (conditional-paint config-file 'red)) |
| 158 | (displayln-format (message 'try-running) |
| 159 | (conditional-paint "sp init" 'green)))))) |
| 160 | |
| 161 | (define (sync verbose?) |
| 162 | (if (file-exists? config-file) |
| 163 | (let* ((local-paste-directory (config-get 'local-paste-directory)) |
| 164 | (remote-paste-directory (config-get 'remote-paste-directory))) |
| 165 | (call-with-input-pipe |
| 166 | (format "rsync -a --delete ~a ~a" local-paste-directory remote-paste-directory) read-line) |
| 167 | (when verbose? |
| 168 | (displayln-format (message 'synced) |
| 169 | (conditional-paint local-paste-directory 'blue) |
| 170 | (conditional-paint remote-paste-directory 'blue)))) |
| 171 | (begin (displayln-format (message 'file-doesnt-exist) |
| 172 | (conditional-paint config-file 'red)) |
| 173 | (displayln-format (message 'try-running) |
| 174 | (conditional-paint "sp init" 'green))))) |
| 175 | |
| 176 | (define (rm file) |
| 177 | (let* ((path (expand-path-home file)) |
| 178 | (local-paste-directory (config-get 'local-paste-directory)) |
| 179 | ;; so we don't error out on dotfiles |
| 180 | ;; for example, (pathname-extension ".profile") returns false |
| 181 | (file-extension (let ((ext (pathname-extension path))) |
| 182 | (if ext |
| 183 | (string-append "." ext) |
| 184 | "")))) |
| 185 | (if (file-exists? path) |
| 186 | (let ((path-file (string-append (pathname-file path) file-extension))) |
| 187 | (if (or (equal? (string-append local-paste-directory path-file) path) |
| 188 | (equal? (string-append local-paste-directory path-file) |
| 189 | (expand-path-home (string-append "~/" path)))) |
| 190 | (begin (displayln-format (message 'file-deleting-both) |
| 191 | (conditional-paint path-file 'yellow)) |
| 192 | (delete-file* path) |
| 193 | (sync #f) |
| 194 | (displayln-format (message 'file-deleted-both) |
| 195 | (conditional-paint path-file 'green))) |
| 196 | (displayln-format (message 'file-not-in-local-paste-directory) |
| 197 | (conditional-paint path 'red) |
| 198 | (conditional-paint local-paste-directory 'blue)))) |
| 199 | (displayln-format (message 'file-doesnt-exist) |
| 200 | (conditional-paint file 'red))))) |
| 201 | |
| 202 | (define (help) |
| 203 | (displayln |
| 204 | #<<STRING |
| 205 | sp - A tool for sharing uploaded files with people. |
| 206 | |
| 207 | Usage: |
| 208 | sp help - Display this help message. |
| 209 | sp init - Create a config file at '~/.sp'. |
| 210 | sp <path/to/file> - Upload a file to your remote paste directory. You can change your remote paste directory by editing your '~/.sp' configuration file. |
| 211 | sp rm <path/to/file> - Deletes a file from your remote paste directory, where '<path/to/file>' should be a file in the 'local-paste-directory' that is specified in your '~/.sp' configuration file. |
| 212 | sp sync - WARNING: This command deletes files in your remote paste directory if they don't exist in your local paste directory. Synchronize the files in your local paste directory with the files in your remote paste directory. |
| 213 | STRING |
| 214 | )) |
| 215 | |
| 216 | (define (init) |
| 217 | (if (file-exists? config-file) |
| 218 | (displayln-format (message 'file-already-exists) |
| 219 | (conditional-paint config-file 'red)) |
| 220 | (init-prompt))) |
| 221 | |
| 222 | (define (main args) |
| 223 | (if (null? args) |
| 224 | (displayln-format (message 'for-help) |
| 225 | (conditional-paint "sp help" 'green)) |
| 226 | (let ((first-arg (car args)) |
| 227 | (second-arg (if (> (length args) 1) |
| 228 | (cadr args) |
| 229 | #f))) |
| 230 | (case (string->symbol first-arg) |
| 231 | ('init (init)) |
| 232 | ('sync (sync #t)) |
| 233 | ('rm (if second-arg |
| 234 | (rm second-arg) |
| 235 | (begin (displayln-format (message 'argument-not-provided)) |
| 236 | (displayln-format (message 'try-running) |
| 237 | (conditional-paint "sp rm <path/to/file>" 'green))))) |
| 238 | ((--help -help help -h) (help)) |
| 239 | (else (paste-file first-arg)))))) |
| 240 | |
| 241 | (main (command-line-arguments)) |
| 242 | |