extra/gopher/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 gopher gopher.private io io.directories
   6 io.encodings.utf8 io.files io.files.temp io.launcher io.pipes
   7 kernel literals math math.parser namespaces present sequences
   8 splitting system urls webbrowser ;
   9
  10 IN: gopher.cli
  11
  12 CONSTANT: DEFAULT-URL "gopher://gopher.quux.org"
  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 : gopher-history ( -- )
  75     HISTORY t print-links ;
  76
  77 : gopher-print ( item-type body -- )
  78     PAGE delete-all
  79     gopher-text swap ${ A_MENU A_INDEX } member?
  80     [ [ dup empty? [ <gopher-link> ] unless ] map ] when
  81     [
  82         dup gopher-link? [
  83             dup type>> CHAR: i = [
  84                 name>> print
  85             ] [
  86                 [ name>> ] [ >url present ] bi
  87                 over 2array PAGE push
  88                 PAGE length swap "[%s] %s\n" printf
  89             ] if
  90         ] [
  91             print
  92         ] if
  93     ] each
  94     LINKS delete-all PAGE LINKS push-all ;
  95
  96 : gopher-get ( args -- )
  97     dup array? [ first ] when dup URL set-first
  98     >url gopher over ${ A_TEXT A_MENU A_INDEX } member? [
  99         "gopher.txt" temp-file
 100         [ utf8 [ gopher-print ] with-file-writer ]
 101         [ utf8 file-contents print ] bi
 102     ] [
 103         "ERROR: Cannot display '" "'" surround print drop
 104     ] if ;
 105
 106 : gopher-go ( args -- )
 107     dup array? [ first ] when present [ DEFAULT-URL ] when-empty
 108     { [ "://" over subseq? ] [ "gopher://" head? ] } 1||
 109     [ "gopher://" prepend ] unless
 110     dup "gopher://" head? [
 111         [ add-history ] [ add-stack ] [ gopher-get ] tri
 112     ] [ open-url ] if ;
 113
 114 : gopher-reload ( -- )
 115     URL ?first gopher-go ;
 116
 117 : gopher-back ( -- )
 118     -1 stack-url [ gopher-get ] when* ;
 119
 120 : gopher-forward ( -- )
 121     1 stack-url [ gopher-get ] when* ;
 122
 123 : gopher-less ( -- )
 124     "gopher.txt" temp-file dup file-exists? [
 125         utf8 [
 126             <process>
 127                 "PAGER" os-env [ "less" ] unless* >>command
 128                 input-stream get >>stdin
 129             try-process
 130         ] with-file-reader
 131     ] [ drop ] if ;
 132
 133  : gopher-ls ( args -- )
 134     [ PAGE ] [ "-l" = ] bi* print-links ;
 135
 136 : gopher-quit ( -- )
 137     "gopher.txt" temp-file ?delete-file 0 exit ;
 138
 139 : gopher-url ( -- )
 140     URL ?first [ print ] when* ;
 141
 142 : gopher-root ( -- )
 143     URL ?first [ >url "/" >>path gopher-go ] when* ;
 144
 145 : gopher-shell ( args -- )
 146     "|" split "gopher.txt" temp-file dup file-exists? [
 147         "cat" swap 2array prefix run-pipeline drop
 148     ] [ 2drop ] if ;
 149
 150 CONSTANT: COMMANDS {
 151     T{ command
 152         { name "back" }
 153         { quot [ drop gopher-back ] }
 154         { help "Go back to the previous gopher URL." }
 155         { abbrevs { "b" } } }
 156     T{ command
 157         { name "forward" }
 158         { quot [ drop gopher-forward ] }
 159         { help "Go forward to the next gopher URL." }
 160         { abbrevs { "f" } } }
 161     T{ command
 162         { name "history" }
 163         { quot [ drop gopher-history ] }
 164         { help "Display recently viewed gopher URLs." }
 165         { abbrevs { "h" "hist" } } }
 166     T{ command
 167         { name "less" }
 168         { quot [ drop gopher-less ] }
 169         { help "View the most recent gopher URL in a pager." }
 170         { abbrevs { "l" } } }
 171     T{ command
 172         { name "ls" }
 173         { quot [ gopher-ls ] }
 174         { help "List the currently available links." }
 175         { abbrevs f } }
 176     T{ command
 177         { name "go" }
 178         { quot [ gopher-go ] }
 179         { help "Go to a gopher URL" }
 180         { abbrevs { "g" } } }
 181     T{ command
 182         { name "url" }
 183         { quot [ drop gopher-url ] }
 184         { help "Print the most recent gopher URL." }
 185         { abbrevs f } }
 186     T{ command
 187         { name "reload" }
 188         { quot [ drop gopher-reload ] }
 189         { help "Reload the most recent gopher URL." }
 190         { abbrevs { "r" } } }
 191     T{ command
 192         { name "root" }
 193         { quot [ drop gopher-root ] }
 194         { help "Navigate to the most recent gopher URL's root." }
 195         { abbrevs f } }
 196     T{ command
 197         { name "shell" }
 198         { quot [ gopher-shell ] }
 199         { help "'cat' the most recent gopher URL through a shell." }
 200         { abbrevs { "!" } } }
 201     T{ command
 202         { name "home" }
 203         { quot [ drop DEFAULT-URL gopher-go ] }
 204         { help "Go to the default gopher URL" }
 205         { abbrevs f } }
 206     T{ command
 207         { name "quit" }
 208         { quot [ drop gopher-quit ] }
 209         { help "Quit the program." }
 210         { abbrevs { "q" "exit" } } }
 211 }
 212
 213 TUPLE: gopher-command-loop < command-loop ;
 214
 215 M: gopher-command-loop missing-command
 216     over string>number [ 1 - LINKS ?nth ] [ f ] if* [
 217         gopher-go 3drop
 218     ] [
 219         call-next-method
 220     ] if* ;
 221
 222 : gopher-main ( -- )
 223     "Welcome to Gopher!" "GOPHER>"
 224     gopher-command-loop new-command-loop
 225     COMMANDS [ over add-command ] each
 226     run-command-loop ;
 227
 228 MAIN: gopher-main