socket.sls

(library (socket ffi) 
  (export
    AF_UNSPEC
    AF_UNIX
    AF_INET
    SOCK_STREAM     
    SOCK_DGRAM      
    SOCK_RAW      
    SOCK_RDM        
    SOCK_SEQPACKET
    SOCK_PACKET
    INADDR_ANY
    SOL_SOCKET
    SO_REUSEADDR
    SO_REUSEPORT
    SO_SNDBUF
    SO_RCVBUF
    SO_SNDLOWAT
    SO_RCVLOWAT
    SO_SNDTIMEO
    SO_RCVTIMEO
    SO_ERROR
    SO_TYPE
    IPPROTO_IP
    IPPROTO_TCP
    IPPROTO_UDP
    SOCKET_ERROR

    wsadata
    
    c-read
    c-write
    c-recv
    c-send
    socket
    bind
    connect
    listen
    accept
    shutdown
    close
    closesocket
    wsastartup
    wsacleanup
    makeword
    check)
  (import
    (scheme)
    (libc libc))

  (define lib-name
    (case (machine-type)
      ((i3nt ti3nt a6nt ta6nt) "ws2_32.dll")
      ((a6osx i3osx ta6osx ti3osx)  "libc.dylib")
      ((a6le i3le ta6le ti3le) "libc.so.6")
      (else "libc.so")))

  (define lib (load-shared-object lib-name))

  (define-syntax def-function
    (syntax-rules ()
      ((_ name sym args ret)
       (define name
          (if (foreign-entry? sym)
            (foreign-procedure sym args ret)
            (lambda x (printf "error: ~a not found in ~a\n" sym lib-name)))))))


  (define AF_UNSPEC       0)  
  (define AF_UNIX         1)
  (define AF_INET         2)

  (define SOCK_STREAM      1)
  (define SOCK_DGRAM       2)
  (define SOCK_RAW         3)
  (define SOCK_RDM         4)
  (define SOCK_SEQPACKET   5)
  (define SOCK_PACKET      10)
  (define INADDR_ANY 0)

  (define SOL_SOCKET 0 )
  (define SO_REUSEADDR   #x0004)
  (define SO_REUSEPORT   #x0200)
  (define SO_SNDBUF	#x1001)
  (define SO_RCVBUF	#x1002)
  (define SO_SNDLOWAT	#x1003)
  (define SO_RCVLOWAT	#x1004)
  (define SO_SNDTIMEO	#x1005)
  (define SO_RCVTIMEO	#x1006)
  (define SO_ERROR	#x1007)
  (define SO_TYPE	#x1008)
  
  (define IPPROTO_IP 0)
  (define IPPROTO_TCP 6)
  (define IPPROTO_UDP 22)

  (define SOCKET_ERROR -1)


  (define-ftype wsadata
    (struct
      (wVersion unsigned-short)
      (wHighVersion unsigned-short)
      (szDescription (array 257 char))
      (szSystemStatus (array 129 char))
      (iMaxSockets unsigned-short)
      (iMaxUdpDg unsigned-short)
      (lpVendorInfo (* char))))


  (def-function socket
    "socket" (int int int) int)
  
  (def-function bind
    "bind" (int (* sockaddr-in) int) int)

  (def-function listen
    "listen" (int int) int)

  (def-function accept
    "accept" (int (* sockaddr-in) (* socklen-t)) int)

  (def-function connect
    "connect" (int (* sockaddr-in) int) int)

  (def-function c-read
    "read" (int u8* int) int)

  (def-function c-write
    "write" (int u8* int) int)

  (def-function c-recv
    "recv" (int u8* int int) int)

  (def-function c-send
    "send" (int u8* int int) int)
    
  (def-function shutdown
    "shutdown" (int int) int)

  (def-function close
    "close" (int) int)

  (def-function closesocket
    "closesocket" (int) int)
  
  (def-function wsastartup
    "WSAStartup" (unsigned-short (* wsadata)) int)

  (def-function wsacleanup
    "WSACleanup" () int)

  (define makeword
    (lambda (low high)
      (bitwise-ior low (bitwise-arithmetic-shift-left high 8))))
  
  (define check
    (lambda (who x)
      (if (< x 0)
        (error who (format "return ~a" x))
          x))) 
  )

(library (socket syntax) 
  (export
    socket:socket
    socket:bind
    socket:connect
    socket:listen
    socket:accept
    socket:write
    socket:read
    socket:close
    socket:shutdown
    socket:cleanup)
  (import 
    (scheme)
    (libc libc)
    (socket ffi))

  (define os
    (let ([type (machine-type)])
      (case type
        ((i3nt ti3nt a6nt ta6nt) "nt")
        ((a6osx i3osx ta6osx ti3osx)  "osx")
        ((a6le i3le ta6le ti3le) "le")
        (else (symbol->string type)))))

  (define nt? (string=? os "nt"))
  
  (define-syntax socket:socket
    (syntax-rules ()
      [(_ family type)
        (socket:socket family type IPPROTO_IP)]
      [(_ family type protocol)
        (begin
          (when nt?
            (let ([was (make-ftype-pointer wsadata
                          (foreign-alloc (ftype-sizeof wsadata)))])
              (wsastartup (makeword 2 2) was)))
          (check 'socket (socket family type protocol)))]))
  
  (define-syntax socket:bind
    (syntax-rules ()
      [(_ socket family ip port)
        (let* ([addr-size (ftype-sizeof sockaddr-in)]
               [serv-addr (make-ftype-pointer sockaddr-in
                            (foreign-alloc addr-size))])
          (ftype-set! sockaddr-in (sin-family) serv-addr family)
          (ftype-set! sockaddr-in (sin-addr s-addr) serv-addr (c-inet-addr ip))
          (ftype-set! sockaddr-in (sin-port) serv-addr (c-htons port))
          (socket:bind socket serv-addr addr-size))]
      [(_ socket addr size)
        (check 'bind (bind socket addr size))]))
  
  (define-syntax socket:connect
    (syntax-rules ()
      [(_ socket family ip port)
        (let* ([addr-size (ftype-sizeof sockaddr-in)]
               [serv-addr (make-ftype-pointer sockaddr-in
                            (foreign-alloc addr-size))])
          (ftype-set! sockaddr-in (sin-family) serv-addr family)
          (ftype-set! sockaddr-in (sin-addr s-addr) serv-addr (c-inet-addr ip))
          (ftype-set! sockaddr-in (sin-port) serv-addr (c-htons port))
          (socket:connect socket serv-addr addr-size))]
      [(_ socket addr size)
        (check 'connect (connect socket addr size))]))

  (define-syntax socket:listen
    (syntax-rules ()
      [(_ socket)
        (socket:listen socket 10)]
      [(_ socket back-log)
        (check 'listen (listen socket back-log))]))

  (define-syntax socket:accept
    (syntax-rules ()
      [(_ socket)
        (let* ([addr-size (ftype-sizeof sockaddr-in)]
               [clnt-addr (make-ftype-pointer sockaddr-in
                            (foreign-alloc addr-size))]
               [clnt-addr-size (make-ftype-pointer socklen-t
                            (foreign-alloc
                              (ftype-sizeof socklen-t)))])
        (ftype-set! socklen-t () clnt-addr-size addr-size)
        (socket:accept socket clnt-addr clnt-addr-size))]
      [(_ socket addr socklen)
        (check 'accept (accept socket addr socklen))]))

  (define socket:write
    (lambda (socket bv)
      (let* ([len (bytevector-length bv)])
        (check 's-write (if nt? (c-send socket bv len 0) (c-write socket bv len))))))

  (define socket:read 
    (case-lambda
      ([socket]
        (socket:read socket 1024))
      ([socket len]
        (socket:read socket len (make-bytevector 0)))
      ([socket len rbv]
        (let* ([buff (make-bytevector len)]
               [len (bytevector-length buff)]
               [n (check 's-read (if nt? (c-recv socket buff len 0) (c-read socket buff len)))]
               [bv (make-bytevector n)])
          (bytevector-copy! buff 0 bv 0 n)
          (cond
            ([= n 0] rbv)
            ([< n len] (bytevector-append rbv bv))
            (else (socket:read socket len (bytevector-append rbv bv))))))))

  (define-syntax socket:shutdown
    (syntax-rules ()
      [(_ socket howto)
        (check 'shutdown (shutdown socket howto))]))

  (define-syntax socket:close
    (syntax-rules ()
      [(_ socket)
        (check 'close ((if nt? closesocket close) socket))]))

  (define-syntax socket:cleanup
    (syntax-rules ()
      [(_)
        (check 'cleanup (if nt? (wsacleanup) 0))]))

  (define bytevector-append
    (lambda (bv1 bv2)
      (let* ([len1 (bytevector-length bv1)]
             [len2 (bytevector-length bv2)]
             [bv (make-bytevector (+ len1 len2))])
        (bytevector-copy! bv1 0 bv 0 len1)
        (bytevector-copy! bv2 0 bv len1 len2)
        bv)))
)

(library (socket socket)
  (export
    AF_UNSPEC
    AF_UNIX
    AF_INET
    SOCK_STREAM     
    SOCK_DGRAM      
    SOCK_RAW      
    SOCK_RDM        
    SOCK_SEQPACKET
    SOCK_PACKET
    INADDR_ANY
    SOL_SOCKET
    SO_REUSEADDR
    SO_REUSEPORT
    SO_SNDBUF
    SO_RCVBUF
    SO_SNDLOWAT
    SO_RCVLOWAT
    SO_SNDTIMEO
    SO_RCVTIMEO
    SO_ERROR
    SO_TYPE
    IPPROTO_IP
    IPPROTO_TCP
    IPPROTO_UDP
    SOCKET_ERROR
    wsadata
    c-read
    c-write
    c-recv
    c-send
    socket
    bind
    connect
    listen
    accept
    shutdown
    close
    closesocket
    wsastartup
    wsacleanup
    makeword
    check

    socket:socket
    socket:bind
    socket:connect
    socket:listen
    socket:accept
    socket:write
    socket:read
    socket:close
    socket:shutdown
    socket:cleanup)
  (import 
    (scheme)
    (socket ffi)
    (socket syntax)))