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