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