extra/gemini/cli/cli.factor

   1 ! Copyright (C) 2021 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors arrays assocs combinators
   5 combinators.short-circuit command-loop formatting gemini
   6 gemini.private io io.directories io.encodings.string
   7 io.encodings.utf8 io.files io.files.temp io.launcher io.pipes
   8 kernel math math.parser namespaces present sequences splitting
   9 system urls webbrowser ;
  10
  11 IN: gemini.cli
  12
  13 CONSTANT: DEFAULT-URL "gemini://gemini.circumlunar.space"
  14
  15 CONSTANT: HISTORY V{ }
  16 CONSTANT: LINKS V{ }
  17 CONSTANT: STACK V{ }
  18 CONSTANT: PAGE V{ }
  19 CONSTANT: URL V{ }
  20
  21 ! XXX: page titles and urls in history
  22
  23 : add-stack ( args -- )
  24     dup STACK index [ drop ] [
  25         URL ?first STACK index [
  26             over PAGE keys index [
  27                 1 + dup STACK ?nth pick = [ 2drop ] [
  28                     STACK [ length ] [ delete-slice ] bi
  29                     STACK push
  30                     STACK length 10 > [
  31                         0 STACK remove-nth! drop
  32                     ] when
  33                 ] if
  34             ] [
  35                 drop STACK push
  36             ] if
  37         ] [
  38             STACK delete-all
  39             STACK push
  40         ] if*
  41     ] if ;
  42
  43 : add-history ( args -- )
  44     HISTORY dup length 10 > [
  45         0 swap remove-nth!
  46     ] when dupd remove! push ;
  47
  48 : gemini-history ( -- )
  49     HISTORY [ 1 + swap "[%d] %s\n" printf ] each-index
  50     LINKS delete-all HISTORY LINKS push-all ;
  51
  52 : gemini-print ( url body meta -- )
  53     f pre [
  54         PAGE delete-all
  55         gemini-charset decode string-lines [
  56             { [ pre get not ] [ "=>" ?head ] } 0&& [
  57                 swap gemini-link present over 2array PAGE push
  58                 PAGE length swap "[%s] %s\n" printf
  59             ] [
  60                 gemini-line.
  61             ] if
  62         ] with each
  63         LINKS delete-all PAGE keys LINKS push-all
  64     ] with-variable ;
  65
  66 : gemini-get ( args -- )
  67     dup URL set-first
  68     >url dup gemini [ drop ] 2dip swap "text/" ?head [
  69         "gemini.txt" temp-file
  70         [ utf8 [ gemini-print ] with-file-writer ]
  71         [ utf8 file-contents print ] bi
  72     ] [
  73         "ERROR: Cannot display '" "'" surround print 2drop
  74     ] if ;
  75
  76 : gemini-go ( args -- )
  77     present [ DEFAULT-URL ] when-empty
  78     { [ "://" over subseq? ] [ "gemini://" head? ] } 1||
  79     [ "gemini://" prepend ] unless
  80     dup "gemini://" head? [
  81         [ add-history ] [ add-stack ] [ gemini-get ] tri
  82     ] [ open-url ] if ;
  83
  84 : gemini-reload ( -- )
  85     HISTORY ?last gemini-go ;
  86
  87 : gemini-back ( -- )
  88     URL ?first STACK index [
  89         1 - STACK ?nth [ gemini-get ] when*
  90     ] when* ;
  91
  92 : gemini-forward ( -- )
  93     URL ?first STACK index [
  94         1 + STACK ?nth [ gemini-get ] when*
  95     ] when* ;
  96
  97 : gemini-up ( -- )
  98     URL ?first [
  99         >url f >>query f >>anchor
 100         [ "/" ?tail drop "/" split1-last drop "/" append ] change-path
 101         gemini-go
 102     ] when* ;
 103
 104 : gemini-less ( -- )
 105     "gemini.txt" temp-file dup exists? [
 106         "less" swap 2array try-process
 107     ] [ drop ] if ;
 108
 109  : gemini-ls ( args -- )
 110     PAGE swap "-l" = '[
 111         1 + swap first2 swap
 112         _ [ " (" ")" surround ] [ drop f ] if
 113         "[%d] %s%s\n" printf
 114     ] each-index
 115     LINKS delete-all PAGE keys LINKS push-all ;
 116
 117 : gemini-quit ( -- )
 118     "gemini.txt" temp-file ?delete-file 0 exit ;
 119
 120 : gemini-url ( -- )
 121     URL ?first [ print ] when* ;
 122
 123 : gemini-root ( -- )
 124     URL ?first [ >url "/" >>path gemini-go ] when* ;
 125
 126 : gemini-shell ( args -- )
 127     "|" split "gemini.txt" temp-file dup exists? [
 128         "cat" swap 2array prefix run-pipeline drop
 129     ] [ 2drop ] if ;
 130
 131 : gemini-stack ( -- )
 132     STACK [
 133         1 + swap dup URL ?first = " (*)" f ?
 134         "[%d] %s%s\n" printf
 135     ] each-index
 136     LINKS delete-all STACK LINKS push-all ;
 137
 138 CONSTANT: COMMANDS {
 139     T{ command
 140         { name "back" }
 141         { quot [ drop gemini-back ] }
 142         { help "Go back to the previous Gemini URL." }
 143         { abbrevs { "b" } } }
 144     T{ command
 145         { name "forward" }
 146         { quot [ drop gemini-forward ] }
 147         { help "Go forward to the next Gemini URL." }
 148         { abbrevs { "f" } } }
 149     T{ command
 150         { name "history" }
 151         { quot [ drop gemini-history ] }
 152         { help "Display recently viewed Gemini URLs." }
 153         { abbrevs { "h" "hist" } } }
 154     T{ command
 155         { name "less" }
 156         { quot [ drop gemini-less ] }
 157         { help "View the most recent Gemini URL in a pager." }
 158         { abbrevs { "l" } } }
 159     T{ command
 160         { name "ls" }
 161         { quot [ gemini-ls ] }
 162         { help "List the currently available links." }
 163         { abbrevs f } }
 164     T{ command
 165         { name "go" }
 166         { quot [ gemini-go ] }
 167         { help "Go to a Gemini URL" }
 168         { abbrevs { "g" } } }
 169     T{ command
 170         { name "gus" }
 171         { quot [ drop "gemini://gus.guru/search" gemini-go ] }
 172         { help "Submit a query to the GUS search engine." }
 173         { abbrevs f } }
 174     T{ command
 175         { name "up" }
 176         { quot [ drop gemini-up ] }
 177         { help "Go up one directory from the recent Gemini URL." }
 178         { abbrevs { "u" } } }
 179     T{ command
 180         { name "url" }
 181         { quot [ drop gemini-url ] }
 182         { help "Print the most recent Gemini URL." }
 183         { abbrevs f } }
 184     T{ command
 185         { name "reload" }
 186         { quot [ drop gemini-reload ] }
 187         { help "Reload the most recent Gemini URL." }
 188         { abbrevs { "r" } } }
 189     T{ command
 190         { name "root" }
 191         { quot [ drop gemini-root ] }
 192         { help "Navigate to the most recent Gemini URL's root." }
 193         { abbrevs f } }
 194     T{ command
 195         { name "shell" }
 196         { quot [ gemini-shell ] }
 197         { help "'cat' the most recent Gemini URL through a shell." }
 198         { abbrevs { "!" } } }
 199     T{ command
 200         { name "stack" }
 201         { quot [ drop gemini-stack ] }
 202         { help "Display the current navigation stack." }
 203         { abbrevs f } }
 204     T{ command
 205         { name "quit" }
 206         { quot [ drop gemini-quit ] }
 207         { help "Quit the program." }
 208         { abbrevs { "q" "exit" } } }
 209 }
 210
 211 TUPLE: gemini-command-loop < command-loop ;
 212
 213 M: gemini-command-loop missing-command
 214     over string>number [ 1 - LINKS ?nth ] [ f ] if* [
 215         gemini-go 3drop
 216     ] [
 217         call-next-method
 218     ] if* ;
 219
 220 : gemini-main ( -- )
 221     "Welcome to Project Gemini!" "GEMINI>"
 222     gemini-command-loop new-command-loop
 223     COMMANDS [ over add-command ] each
 224     run-command-loop ;
 225
 226 MAIN: gemini-main