1 ! Copyright (C) 2021 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license
4 USING: accessors ascii assocs colors.constants 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 ;
15 ! "Speculative specification"
16 ! v0.14.3, November 29, 2020
18 ! https://gemini.circumlunar.space/docs/specification.gmi
20 ! URL" gemini://gemini.circumlunar.space"
22 ERROR: too-many-redirects ;
25 max-redirects [ 5 ] initialize
29 CONSTANT: STATUS-CATEGORIES H{
33 { 40 "Temporary Failure" }
34 { 50 "Permanent Failure" }
35 { 60 "Client Certificate Required" }
38 CONSTANT: STATUS-CODES H{
40 { 11 "Sensitive Input" }
42 { 30 "Redirect - Temporary" }
43 { 31 "Redirect - Permanent" }
44 { 40 "Temporary Failure" }
45 { 41 "Server Unavailable" }
49 { 50 "Permanent Failure" }
52 { 53 "Proxy Request Refused" }
54 { 60 "Client Certificate Requested" }
55 { 61 "Certificate Not Authorized" }
56 { 62 "Certificate Not Valid" }
59 : read-body ( -- body )
60 [ 1024 read ] loop>array concat ;
62 ERROR: invalid-status value ;
64 : check-status ( status -- status )
65 dup length 1 > [ invalid-status ] unless ;
67 : ?read-body ( status -- body/f )
68 check-status ?first CHAR: 2 = [ read-body ] [ f ] if ;
70 : read-response ( -- status meta body/f )
71 readln utf8 decode "\r" ?tail drop [ blank? ] split1-when over ?read-body ;
73 : send-request ( url -- )
74 present utf8 encode write B{ CHAR: \r CHAR: \n } write flush ;
76 : gemini-addr ( url -- addr )
77 [ host>> ] [ port>> 1965 or ] bi <inet> ;
80 ! XXX: Implement Trust-On-First-Use
81 [ send-secure-handshake ] [ certificate-verify-error? ] ignore-error ;
87 : gemini-redirect ( status meta body/f -- status' meta' body'/f )
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 ;
95 : ?gemini-redirect ( status meta body/f -- status' meta' body'/f )
96 pick ?first CHAR: 3 = [ gemini-redirect ] when ;
98 : gemini-request ( url -- status meta body/f )
99 >url dup gemini-addr binary [
103 ] with-client ?gemini-redirect ;
107 : gemini ( url -- status meta body/f )
108 0 redirects [ gemini-request ] with-variable ;
110 ERROR: unsupported-charset charset ;
114 CONSTANT: gemini-encodings H{
115 { "iso-8859-1" latin1 }
120 : gemini-meta ( meta -- headers )
121 ";" split [ [ blank? ] trim "=" split1 [ >lower ] dip ] H{ } map>assoc ;
123 : gemini-charset ( text-mime -- charset )
124 gemini-meta "charset" of [
125 >lower gemini-encodings ?at
126 [ unsupported-charset ] unless
134 >url dup gemini [ drop ] 2dip swap {
135 { [ "text/" ?head ] [ gemini-charset decode gemtext. ] }
136 { [ "image/" ?head ] [ (image-class) load-image* image. drop ] }
142 :: gemini-link ( link-text base-url -- text url )
145 [ blank? ] split1-when
146 [ blank? ] trim-head [ dup ] when-empty swap >url
148 base-url clone f >>query f >>anchor swap derive-url
151 : gemini-link. ( link-text base-url -- )
154 COLOR: blue foreground ,,
155 ] H{ } make format nl ;
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 +
165 : gemini-quoted. ( text -- )
166 74 gemini-pad 74 wrap-lines [ "> " write print ] each ;
168 : gemini-text. ( text -- )
169 76 gemini-pad 76 wrap-string print ;
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 } }
178 :: gemini-line. ( base-url 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 ]
193 : gemtext. ( base-url body -- )
194 f pre [ lines [ gemini-line. ] with each ] with-variable ;