extra/gemini/cli/cli.factor

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