extra/gemini/gemini.factor

   1 ! Copyright (C) 2021 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors ascii assocs colors combinators
   5 combinators.short-circuit continuations images.loader
   6 images.loader.private images.viewer io io.encodings.ascii
   7 io.encodings.binary io.encodings.latin1 io.encodings.string
   8 io.encodings.utf8 io.pathnames io.sockets io.sockets.secure
   9 io.styles kernel make math namespaces present sequences
  10 sequences.extras splitting urls wrap.strings ;
  11
  12 IN: gemini
  13
  14 ! Project Gemini
  15 ! "Speculative specification"
  16 ! v0.14.3, November 29, 2020
  17
  18 ! https://gemini.circumlunar.space/docs/specification.gmi
  19
  20 ! URL" gemini://gemini.circumlunar.space"
  21
  22 ERROR: too-many-redirects ;
  23
  24 SYMBOL: max-redirects
  25 max-redirects [ 5 ] initialize
  26
  27 <PRIVATE
  28
  29 CONSTANT: STATUS-CATEGORIES H{
  30     { 10 "Input" }
  31     { 20 "Success" }
  32     { 30 "Redirect" }
  33     { 40 "Temporary Failure" }
  34     { 50 "Permanent Failure" }
  35     { 60 "Client Certificate Required" }
  36 }
  37
  38 CONSTANT: STATUS-CODES H{
  39     { 10 "Input" }
  40     { 11 "Sensitive Input" }
  41     { 20 "Success" }
  42     { 30 "Redirect - Temporary" }
  43     { 31 "Redirect - Permanent" }
  44     { 40 "Temporary Failure" }
  45     { 41 "Server Unavailable" }
  46     { 42 "CGI Error" }
  47     { 43 "Proxy Error" }
  48     { 44 "Slow Down" }
  49     { 50 "Permanent Failure" }
  50     { 51 "Not Found" }
  51     { 52 "Gone" }
  52     { 53 "Proxy Request Refused" }
  53     { 59 "Bad Request" }
  54     { 60 "Client Certificate Requested" }
  55     { 61 "Certificate Not Authorized" }
  56     { 62 "Certificate Not Valid" }
  57 }
  58
  59 : read-body ( -- body )
  60     [ 1024 read ] loop>array concat ;
  61
  62 ERROR: invalid-status value ;
  63
  64 : check-status ( status -- status )
  65     dup length 1 > [ invalid-status ] unless ;
  66
  67 : ?read-body ( status -- body/f )
  68     check-status ?first CHAR: 2 = [ read-body ] [ f ] if ;
  69
  70 : read-response ( -- status meta body/f )
  71     readln utf8 decode "\r" ?tail drop [ blank? ] split1-when over ?read-body ;
  72
  73 : send-request ( url -- )
  74     present utf8 encode write B{ CHAR: \r CHAR: \n } write flush ;
  75
  76 : gemini-addr ( url -- addr )
  77     [ host>> ] [ port>> 1965 or ] bi <inet> ;
  78
  79 : gemini-tls ( -- )
  80     ! XXX: Implement Trust-On-First-Use
  81     [ send-secure-handshake ] [ certificate-verify-error? ] ignore-error ;
  82
  83 SYMBOL: redirects
  84
  85 DEFER: gemini-request
  86
  87 : gemini-redirect ( status meta body/f -- status' meta' body'/f )
  88     redirects inc
  89     redirects get max-redirects get < [
  90         ! XXX: detect cross-protocol redirects
  91         ! XXX: detect redirect to same link
  92         drop nip gemini-request
  93     ] [ too-many-redirects ] if ;
  94
  95 : ?gemini-redirect ( status meta body/f -- status' meta' body'/f )
  96     pick ?first CHAR: 3 = [ gemini-redirect ] when ;
  97
  98 : gemini-request ( url -- status meta body/f )
  99     >url dup gemini-addr binary [
 100         gemini-tls
 101         send-request
 102         read-response
 103     ] with-client ?gemini-redirect ;
 104
 105 PRIVATE>
 106
 107 : gemini ( url -- status meta body/f )
 108     0 redirects [ gemini-request ] with-variable ;
 109
 110 ERROR: unsupported-charset charset ;
 111
 112 <PRIVATE
 113
 114 CONSTANT: gemini-encodings H{
 115     { "iso-8859-1" latin1 }
 116     { "utf-8" utf8 }
 117     { "us-ascii" ascii }
 118 }
 119
 120 : gemini-meta ( meta -- headers )
 121     ";" split [ [ blank? ] trim "=" split1 [ >lower ] dip ] H{ } map>assoc ;
 122
 123 : gemini-charset ( text-mime -- charset )
 124     gemini-meta "charset" of [
 125         >lower gemini-encodings ?at
 126         [ unsupported-charset ] unless
 127     ] [ utf8 ] if* ;
 128
 129 PRIVATE>
 130
 131 DEFER: gemtext.
 132
 133 : gemini. ( url -- )
 134     >url dup gemini [ drop ] 2dip swap {
 135         { [ "text/" ?head ] [ gemini-charset decode gemtext. ] }
 136         { [ "image/" ?head ] [ (image-class) load-image* image. drop ] }
 137         [ 3drop ]
 138     } cond ;
 139
 140 <PRIVATE
 141
 142 :: gemini-link ( link-text base-url -- text url )
 143     link-text
 144     [ blank? ] trim-head
 145     [ blank? ] split1-when
 146     [ blank? ] trim-head [ dup ] when-empty swap >url
 147     dup protocol>> [
 148         base-url clone f >>query f >>anchor swap derive-url
 149     ] unless ;
 150
 151 : gemini-link. ( link-text base-url -- )
 152     gemini-link [
 153         presented ,,
 154         COLOR: blue foreground ,,
 155     ] H{ } make format nl ;
 156
 157 :: gemini-pad ( text n -- text' )
 158     ! XXX: break on dashes and soft-hyphens
 159     text n [ over length over > ] [
 160         dup pick [ blank? ] find-last-from drop
 161         dup [ 2dup - n >= [ drop f ] when ] when
 162         [ nip ] [ [ cut " " glue ] keep ] if* n + 1 +
 163     ] while drop ;
 164
 165 : gemini-quoted. ( text -- )
 166     74 gemini-pad 74 wrap-lines [ "> " write print ] each ;
 167
 168 : gemini-text. ( text -- )
 169     76 gemini-pad 76 wrap-string print ;
 170
 171 SYMBOL: pre
 172
 173 CONSTANT: h1-style H{ { font-size 16 } { font-style bold } }
 174 CONSTANT: h2-style H{ { font-size 14 } { font-style bold } }
 175 CONSTANT: h3-style H{ { font-size 12 } { font-style bold } }
 176 CONSTANT: text-style H{ { font-size 12 } { font-style plain } }
 177
 178 :: gemini-line. ( base-url line -- )
 179     line {
 180         { [ "```" ?head ] [ drop pre toggle ] }
 181         { [ pre get ] [ print ] }
 182         { [ "=>" ?head ] [ base-url gemini-link. ] }
 183         { [ "> " ?head ] [ gemini-quoted. ] }
 184         { [ "* " ?head ] [ "• " write gemini-text. ] }
 185         { [ "### " ?head ] [ h3-style [ gemini-text. ] with-style ] }
 186         { [ "## " ?head ] [ h2-style [ gemini-text. ] with-style ] }
 187         { [ "# " ?head ] [ h1-style [ gemini-text. ] with-style ] }
 188         [ text-style [ gemini-text. ] with-style ]
 189     } cond ;
 190
 191 PRIVATE>
 192
 193 : gemtext. ( base-url body -- )
 194     f pre [ split-lines [ gemini-line. ] with each ] with-variable ;