~jojo/Carth

ecde8c35e265ce7fd96cfb47795bde8a6baf7980 — JoJo 27 days ago ff1fbb5
Update std lib with io & networking stuff and add gemini client ex.

Also some other updates to std, as prerequisites for the gemini
implementation. The gemini example uses some simple networking code
and works as a sort of regression test for the recent struct layout
fixes, since it was when I started working on this that FFI stuff
broke way back when xd.
A examples/gemini.carth => examples/gemini.carth +22 -0
@@ 0,0 1,22 @@
(import std)
(import net)

(define main
  (do io/bind
      (let ((host "gemini.circumlunar.space")
            (port (cast 1965))))
      (<- h (io/map unwrap! (tcp/connect-timeout host port (cast 2000))))
      (<- h (io/map unwrap! (tls/connect-without-validation host h)))
      (let1 query (apps str-append "gemini://" host "/\r\n"))
      (handle/write-str query h)
      (<- [h s] (io/map unwrap! (handle/read-to-str h)))
      (let1 [(Str header) body] (unwrap! (string/split-first-line s)))
      (let1 [code meta] (map-two (apps <o unwrap! parse-nat Str)
                                 (<o Str (array/skip 1))
                                 (unwrap! (array/split (cast 2) header))))
      (display (str-append "Code: " (show-nat code)))
      (display (str-append "Meta: " meta))
      (display "Body")
      (display "=================================================")
      (display body)
      (display "==================================================")))

A examples/read-self.carth => examples/read-self.carth +9 -0
@@ 0,0 1,9 @@
(import std)

(define main
  (do io/bind
      (<- s (io/map unwrap! (read-file "read-self.carth")))
      (display "Printing ourselves...")
      (display "==================================================")
      (display s)
      (display "==================================================")))

M std-rs/src/io.rs => std-rs/src/io.rs +12 -21
@@ 30,30 30,21 @@ pub unsafe extern "C" fn stdrs_close_handle(h: FfiHandle) {
pub unsafe extern "C" fn stdrs_read_handle(
    h: FfiHandle,
    mut buf: Array<u8>,
) -> Cons<Array<u8>, Maybe<usize>> {
) -> Maybe<Cons<Array<u8>, usize>> {
    let res = (*handle_from_ffi(h)).read(buf.as_slice_mut());
    Cons(
        buf,
        match res {
            Ok(n) => Maybe::Some(n),
            Err(ref e) if e.kind() == io::ErrorKind::Interrupted => Maybe::Some(0),
            Err(_) => Maybe::None,
        },
    )
    match res {
        Ok(n) => Maybe::Some(Cons(buf, n)),
        Err(ref e) if e.kind() == io::ErrorKind::Interrupted => stdrs_read_handle(h, buf),
        Err(_) => Maybe::None,
    }
}

#[no_mangle]
pub unsafe extern "C" fn stdrs_write_handle(
    h: FfiHandle,
    buf: Array<u8>,
) -> Cons<Array<u8>, Maybe<usize>> {
pub unsafe extern "C" fn stdrs_write_handle(h: FfiHandle, buf: Array<u8>) -> Maybe<usize> {
    let res = (*handle_from_ffi(h)).write(buf.as_slice());
    Cons(
        buf,
        match res {
            Ok(n) => Maybe::Some(n),
            Err(ref e) if e.kind() == io::ErrorKind::Interrupted => Maybe::Some(0),
            Err(_) => Maybe::None,
        },
    )
    match res {
        Ok(n) => Maybe::Some(n),
        Err(ref e) if e.kind() == io::ErrorKind::Interrupted => Maybe::Some(0),
        Err(_) => Maybe::None,
    }
}

M std-rs/src/lib.rs => std-rs/src/lib.rs +16 -13
@@ 1,4 1,5 @@
#![feature(try_trait)]
#![feature(try_trait_v2)]
#![feature(control_flow_enum)]
#![allow(non_camel_case_types)]

mod ffi;


@@ 111,26 112,28 @@ impl<A> Maybe<A> {
    }
}

impl<A> std::ops::Try for Maybe<A> {
    type Ok = A;
    type Error = std::option::NoneError;

impl<A> std::ops::FromResidual for Maybe<A> {
    #[inline]
    fn into_result(self) -> Result<A, std::option::NoneError> {
        match self {
            Maybe::None => Err(std::option::NoneError),
            Maybe::Some(x) => Ok(x),
        }
    fn from_residual(_: <Self as std::ops::Try>::Residual) -> Self {
        Maybe::None
    }
}

impl<A> std::ops::Try for Maybe<A> {
    type Output = A;
    type Residual = Option<std::convert::Infallible>;

    #[inline]
    fn from_ok(v: A) -> Self {
    fn from_output(v: A) -> Self {
        Maybe::Some(v)
    }

    #[inline]
    fn from_error(_: std::option::NoneError) -> Self {
        Maybe::None
    fn branch(self) -> std::ops::ControlFlow<Self::Residual, Self::Output> {
        match self {
            Maybe::None => std::ops::ControlFlow::Break(None),
            Maybe::Some(x) => std::ops::ControlFlow::Continue(x),
        }
    }
}


M std-rs/src/net.rs => std-rs/src/net.rs +51 -15
@@ 7,51 7,87 @@ use std::time::Duration;

use crate::*;

#[repr(C)]
pub struct Certificate {
    pub host: Str,
    pub fingerprint: Str,
}

#[no_mangle]
pub extern "C" fn stdrs_tcp_connect(host: Str, port: u16) -> FfiHandle {
    handle_to_ffi(Box::into_raw(
        Box::new(TcpStream::connect((host.as_str(), port)).expect("socket")) as _,
    ))
pub extern "C" fn stdrs_tcp_connect(host: Str, port: u16) -> Maybe<FfiHandle> {
    Maybe::Some(handle_to_ffi(Box::into_raw(Box::new(
        TcpStream::connect((host.as_str(), port)).ok()?,
    ) as _)))
}

#[no_mangle]
pub extern "C" fn stdrs_tcp_connect_timeout(host: Str, port: u16, ms: u64) -> FfiHandle {
pub extern "C" fn stdrs_tcp_connect_timeout(host: Str, port: u16, ms: u64) -> Maybe<FfiHandle> {
    let timeout = Duration::from_millis(ms);
    let addrs = (host.as_str(), port)
        .to_socket_addrs()
        .unwrap()
        .ok()?
        .collect::<Vec<_>>();
    let (last, init) = addrs.split_last().unwrap();
    let con = init
        .iter()
        .filter_map(|addr| TcpStream::connect_timeout(addr, timeout).ok())
        .next()
        .unwrap_or_else(|| TcpStream::connect_timeout(last, timeout).unwrap());
    handle_to_ffi(Box::into_raw(Box::new(con) as _))
        .or_else(|| TcpStream::connect_timeout(last, timeout).ok())?;
    Maybe::Some(handle_to_ffi(Box::into_raw(Box::new(con) as _)))
}

/// Open a TLS connection over some transport channel (e.g. a TCP stream) without
/// performing any validation of the certificate. Dangerous!
#[no_mangle]
pub unsafe extern "C" fn stdrs_tls_connect_without_validation(
    domain: Str,
    transport: FfiHandle,
) -> Maybe<FfiHandle> {
    let domain = domain.as_str();
    let transport = Box::from_raw(handle_from_ffi(transport));
    let connector = native_tls::TlsConnector::builder()
        .danger_accept_invalid_certs(true)
        // Rust's native-tls does not yet provide Tlsv13 :(
        .min_protocol_version(Some(native_tls::Protocol::Tlsv12))
        .build()
        .ok()?;
    let tls = connector
        .connect(domain, transport)
        .map_err(show_tls_err)
        .ok()?;
    Maybe::Some(handle_to_ffi(Box::into_raw(Box::new(tls) as _)))
}

// Would have loved to use rustls for this, since it's rust, but there are problems that
// prevent it's effecient usage when using self signed certs as we do in gemini. See
// prevent it's efficent usage when using self signed certs as we do in gemini. See
// https://github.com/briansmith/webpki/issues/90.
//
/// Open a TLS connection over some transport channel (e.g. a TCP stream), validating the
/// certificate with TOFU. Useful for protocols like Gemini, which prefer decentralization
/// and self signing over relying on CAs.
#[no_mangle]
pub unsafe extern "C" fn stdrs_tls_connect(domain: Str, transport: FfiHandle) -> FfiHandle {
pub unsafe extern "C" fn stdrs_tls_connect_tofu(
    domain: Str,
    _known_hosts: Array<Certificate>,
    transport: FfiHandle,
) -> Maybe<FfiHandle> {
    let domain = domain.as_str();
    let transport = Box::from_raw(handle_from_ffi(transport));
    // We typically use self signed certs and TOFU in Gemini, but self signed certs are
    // considered "invalid" by default. Therefore, we accept invalid certs, but check for
    // expiration later.
    let connector = native_tls::TlsConnector::builder()
        // TODO: Check for cert expiration date and do TOFU.
        .danger_accept_invalid_certs(true)
        // Rust's native-tls does not yet provide Tlsv13 :(
        .min_protocol_version(Some(native_tls::Protocol::Tlsv12))
        .build()
        .unwrap();
    let tls = connector
        .ok()?;
    let _tls = connector
        .connect(domain, transport)
        .map_err(show_tls_err)
        .unwrap();
    handle_to_ffi(Box::into_raw(Box::new(tls) as _))
        .ok()?;
    // TODO: See https://github.com/jansc/ncgopher/blob/26762fdcec959cc847d055372269b948cbee6822/src/controller.rs#L270-L336
    todo!("Check for cert expiration date and do TOFU")
}

fn show_tls_err<S>(e: native_tls::HandshakeError<S>) -> String {

M std/array.carth => std/array.carth +37 -4
@@ 8,11 8,18 @@
  (map (<o deref (<o (ptr/+ ptr) cast))
       (xrange 0 (cast len))))

(define array/nil (Array mem/unsafe-null (cast 0)))

(define (array/nil? a) (= (cast 0) (array/length a)))

(define: (array/unsafe-uninit n) (forall (a) (Fun Nat (Array a)))
  (Array (cast-ptr (id@"GC_malloc" (* (sizeof a) n)))
         n))

(define: (array/collect xs) (forall (a) (Fun (Iter a) (Array a)))
  (let ((n (count xs))
        (ptr (: (transmute (id@"GC_malloc" (* (sizeof a) (cast n)))) (Box a))))
  (let1 n (count xs)
    (foldl (fun (v [i x]) (array/insert i x v))
           (Array ptr (cast n))
           (array/unsafe-uninit n)
           (enumerate xs))))

(define: (array/insert i x (Array ptr n))


@@ 22,6 29,22 @@
    (seq (store x (ptr/+ ptr i))
         (Array ptr n))))

(extern memcpy (Fun (Box Nat8) (Box Nat8) Nat (Box Nat8)))

(define (memcpy' dest src count)
  (: (transmute (memcpy (transmute (: dest (Box a)))
                        (transmute (: src (Box a)))
                        (* count (sizeof a))))
     (Box a)))

(define: (array/append (Array px nx) (Array py ny))
    (forall (a) (Fun (Array a) (Array a) (Array a)))
  (let1 (Array pz nz) (array/unsafe-uninit (nat/nowrap+ nx ny))
    (apps seq
          (memcpy' pz px nx)
          (memcpy' (ptr/+ pz nx) py ny)
          (Array pz nz))))

(define (array/lookup i (Array ptr n))
  (if (< i n)
      (Some (deref (ptr/+ ptr i)))


@@ 77,6 100,16 @@
  (go (cast 0) (array/length ys)))

(define (array/split i (Array ptr n))
  (if (< i n)
  (if (<= i n)
      (Some [(Array ptr i) (Array (ptr/+ ptr i) (- n i))])
    None))

(define (array/take-split i a)
  (match (array/split i a)
    (case (Some p) p)
    (case None [a array/nil])))

(define (array/split-last (Array ptr n))
  (if (= n (cast 0))
      None
    (Some [(Array ptr (- n (cast 1))) (deref (ptr/+ ptr (- n (cast 1))))])))

M std/io.carth => std/io.carth +43 -0
@@ 46,3 46,46 @@

(define (io/write-ref x ptr)
  (io/wrap (store x ptr)))

(data Handle' (Handle' (Box Nat8) (Box Nat8)))

(define (handle/new h') (Handle h' array/nil))

(extern stdrs_close_handle (Fun Handle' Unit))
(extern stdrs_read_handle  (Fun Handle' (Array Nat8) (Maybe (Cons (Array Nat8) Nat))))
(extern stdrs_write_handle (Fun Handle' (Array Nat8) (Maybe Nat)))

(define (close-handle' h) (io/wrap (stdrs_close_handle h)))
(define (read-handle' h buf) (io/wrap (stdrs_read_handle h buf)))
(define (write-handle' h buf) (io/wrap (stdrs_write_handle h buf)))

(data Handle (Handle Handle' (Array Nat8)))

(define (handle/close (Handle h _)) (close-handle' h))

(define: (handle/write buf (Handle h _)) (Fun (Array Nat8) Handle (IO (Maybe Nat)))
  (write-handle' h buf))

(define: (handle/read-max n (Handle h buf))
    (Fun Nat Handle (IO (Maybe [Handle (Array Nat8)])))
  (if (not (array/nil? buf))
      (let1 [out buf] (array/take-split n buf)
        (io/pure (Some [(Handle h buf) out])))
    (io/map (maybe/map (fun ([(Array p _) . m]) [(Handle h array/nil) (Array p m)]))
            (read-handle' h (array/unsafe-uninit n)))))

(define (handle/read-to-end h)
  (define bufsize (: (cast (* 8 1024)) Nat))
  (define (go [xs h])
    (io/bind (maybe (io/pure None)
                    (fun ([h ys])
                      (if (array/nil? ys)
                          (io/pure (Some [h xs]))
                        (go [(array/append xs ys) h]))))
             (handle/read-max bufsize h)))
  (go [array/nil h]))

(define (handle/read-to-str h)
  (io/map (maybe/map (map-cadr Str)) (handle/read-to-end h)))

(define (handle/write-str (Str a)) (handle/write a))

M std/math.carth => std/math.carth +13 -0
@@ 38,3 38,16 @@
  (go (cast 1) x y))

(define sum (foldl + (cast 0)))

(define: nat/maxval Nat (cast -1))

(define: (nat/checked+ x y)
    (Fun Nat Nat (Maybe Nat))
  (let1 z (+ x y)
    (if (< z x)
        None
      (Some z))))

(define (nat/nowrap+ x y)
  (unwrap-or-else (fun (Unit) (panic "nat/nowrap+: addition overflowed"))
                  (nat/checked+ x y)))

M std/maybe.carth => std/maybe.carth +4 -0
@@ 13,6 13,10 @@
  (fmatch (case (Some x) x)
          (case None (panic "unwrap! of None"))))

(define (unwrap-or-else f)
  (fmatch (case (Some x) x)
          (case None (f Unit))))

(define (maybe/map f)
  (fmatch (case (Some x) (Some (f x)))
          (case None None)))

M std/mem.carth => std/mem.carth +1 -2
@@ 9,6 9,5 @@
(define: (ptr/+ ptr x) (forall (a) (Fun (Box a) Nat (Box a)))
  (transmute (+ (transmute ptr) (* x (cast (sizeof a))))))

(define: (mem/unsafe-null Unit)
    (forall (a) (Fun Unit (Box a)))
(define: mem/unsafe-null (forall (a) (Box a))
  (transmute 0))

M std/std.carth => std/std.carth +1 -0
@@ 10,6 10,7 @@
(import string)
(import queue)
(import io)
(import net)

(define (car      [x . _])           x)
(define (cadr     [_ x . _])         x)

M std/string.carth => std/string.carth +18 -5
@@ 43,6 43,9 @@
(define (string/bytes (Str xs))
  (array/iter xs))

(define (string/collect-bytes it)
  (Str (array/collect it)))

;;? Show an integer in hexadecimal notation
(define: (show-hex n) (Fun Int Str)
  (define: (it n) (Fun Int (Iter Nat8))


@@ 57,15 60,25 @@
      "0x0"
    (str-append "0x" (Str (array/collect (reverse (it n)))))))

(define: (lines (Str s))
(define: (lines s)
    (Fun Str (Iter Str))
  (define (lines' s)
    (Iter (fun (Unit) (maybe/map (fun (i) (map-two Str
                                                   (<o lines' (array/skip 1))
                                                   (unwrap! (array/split i s))))
                                 (array/find (cast ascii-newline) s)))))
    (Iter (fun (Unit) (maybe/map (map-cadr lines') (string/split-first-line s)))))
  (lines' s))

(define (string/split-first-line (Str s))
  (define (trim-carriage xs)
    (match (array/split-last xs)
      (case None xs)
      (case (Some [ys y]) (if (= y ascii-carriage-return)
                              ys
                            xs))))
  (maybe/map (fun (i) (map-two (<o Str trim-carriage)
                               (<o Str (array/skip 1))
                               (unwrap! (array/split i s))))
             (array/find (cast ascii-newline) s)))

(define: ascii-carriage-return Nat8 (cast 0xD))
(define: ascii-newline Nat8 (cast 0xA))
(define: ascii-minus Nat8 (cast 0x2D))
(define: ascii-0 Nat8 (cast 0x30))

M std/sync.carth => std/sync.carth +1 -1
@@ 16,7 16,7 @@
(define: mutex/new
    (IO Mutex)
  (io/wrap (let ((mx (Mutex (cast-ptr (id@"GC_malloc" sizeof_pthread_mutex_t))))
                 (attrs (mem/unsafe-null Unit)))
                 (attrs mem/unsafe-null))
             (seq (pthread_mutex_init mx attrs)
                  mx))))