
   0 | module RacketTCP
   1 | 
   2 | import Data.Buffer as Buffer
   3 | 
   4 | export
   5 | data Listener: Type where [external]
   6 | 
   7 | export
   8 | data InputPort : Type where [external]
   9 | 
  10 | export
  11 | data OutputPort : Type where [external]
  12 | 
  13 | data PortPair : Type where [external]
  14 | 
  15 | export
  16 | data ReadSyncEvt : Type where [external]
  17 | 
  18 | data EOFOrBuffer : Type where [external]
  19 | 
  20 | data NilOrPortPair : Type where [external]
  21 | 
  22 | data NilOrListener : Type where [external]
  23 | 
  24 | data NilOrBits64 : Type where [external]
  25 | 
  26 | data SSLServerContext : Type where [external]
  27 | 
  28 | public export
  29 | data EOF = MkEOF
  30 | 
  31 | public export
  32 | data Couldn'tConnect = MkCouldn'tConnect
  33 | 
  34 | public export
  35 | data Couldn'tSetUpTLS = MkCouldn'tSetUpTLS
  36 | 
  37 | public export
  38 | data WriteError = MkWriteError
  39 | 
  40 | %foreign "scheme,racket:car"
  41 | prim__rfst : PortPair -> PrimIO InputPort
  42 | 
  43 | %foreign "scheme,racket:(lambda (x) (car (cdr x)))"
  44 | prim__rsnd : PortPair -> PrimIO OutputPort
  45 | 
  46 | rfst : HasIO io => PortPair -> io InputPort
  47 | rfst = primIO . prim__rfst
  48 | 
  49 | rsnd : HasIO io => PortPair -> io OutputPort
  50 | rsnd = primIO . prim__rsnd
  51 | 
  52 | %foreign "scheme,racket:(lambda (port) (with-handlers ([exn:fail:network? (lambda (x) '())]) (tcp-listen port))),racket/tcp"
  53 | prim__tcpListen : Bits16 -> PrimIO NilOrListener
  54 | 
  55 | %foreign "scheme,racket:(lambda (x) (if (eof-object? x) 1 0))"
  56 | prim__isEOF : EOFOrBuffer -> PrimIO Bool
  57 | 
  58 | %foreign "scheme,racket:blodwen-is-nil"
  59 | prim__isNil : NilOrPortPair -> PrimIO Bool
  60 | 
  61 | %foreign "scheme,racket:blodwen-is-nil"
  62 | prim__isNilListener : NilOrListener -> PrimIO Bool
  63 | 
  64 | %foreign "scheme,racket:blodwen-is-nil"
  65 | prim__isNilWriteResult : NilOrBits64 -> PrimIO Bool
  66 | 
  67 | assertIsBuffer : EOFOrBuffer -> Buffer
  68 | assertIsBuffer = believe_me
  69 | 
  70 | assertIsPortPair : NilOrPortPair -> PortPair
  71 | assertIsPortPair = believe_me
  72 | 
  73 | assertIsListener : NilOrListener -> Listener
  74 | assertIsListener = believe_me
  75 | 
  76 | assertIsBits64 : NilOrBits64 -> Bits64
  77 | assertIsBits64 = believe_me
  78 | 
  79 | public export
  80 | data ErrListen = MkListenErr
  81 | 
  82 | export
  83 | tcpListen : HasIO io => Bits16 -> io (Either ErrListen Listener)
  84 | tcpListen port = do
  85 |   errOrListener <- primIO (prim__tcpListen port)
  86 |   nil <- primIO (prim__isNilListener errOrListener)
  87 |   if nil
  88 |      then pure (Left MkListenErr)
  89 |      else pure (Right $ assertIsListener errOrListener)
  90 | 
  91 | 
  92 | %foreign "scheme,racket:(lambda (listener) (let-values ([(in-port out-port) (tcp-accept listener)]) (list in-port out-port))),racket/tcp"
  93 | prim__tcpAccept : Listener -> PrimIO PortPair
  94 | 
  95 | portPairToIdrisPair : HasIO io => PortPair -> io (Pair InputPort OutputPort)
  96 | portPairToIdrisPair portPair = do
  97 |   inputPort <- rfst portPair
  98 |   outputPort <- rsnd portPair
  99 |   pure $ MkPair inputPort outputPort
 100 | 
 101 | -- Due to a bug in Racket <= 8.10, we need to disable buffering to be able to trust
 102 | -- that synchronization on a write event means that the data has actually been written
 103 | -- https://racket.discourse.group/t/why-does-write-bytes-avail-evt-not-return-an-error/2230/4
 104 | %foreign "scheme,racket:(lambda (x unit-token) (begin (file-stream-buffer-mode x 'none) unit-token))"
 105 | prim__setBufferModeNone : OutputPort -> Unit -> PrimIO Unit
 106 | 
 107 | export
 108 | tcpAccept : HasIO io => Listener -> io (Pair InputPort OutputPort)
 109 | tcpAccept listener = do
 110 |   portPair <- primIO (prim__tcpAccept listener)
 111 |   (inputPort, outputPort) <- portPairToIdrisPair portPair
 112 |   MkUnit <- primIO (prim__setBufferModeNone outputPort MkUnit)
 113 |   pure (inputPort, outputPort)
 114 | 
 115 | %foreign "scheme,racket:(lambda (inp out ctx) (with-handlers ([exn:fail? (lambda (x) '())]) (let-values ([(in-port out-port) (ports->ssl-ports inp out #:mode 'accept #:context ctx)]) (list in-port out-port)))),openssl"
 116 | prim__portsToSslPorts : InputPort -> OutputPort -> SSLServerContext -> PrimIO NilOrPortPair
 117 | 
 118 | %foreign "scheme,racket:(lambda (key cert alpn-protocol) (let ([ctx (ssl-make-server-context 'tls13 #:private-key (list 'pem (string->path key)) #:certificate-chain (string->path cert))]) (begin (ssl-set-server-alpn! ctx (list alpn-protocol) #f) ctx))),openssl"
 119 | prim__sslMakeServerContext : String -> String -> Buffer -> PrimIO SSLServerContext
 120 | 
 121 | export
 122 | portsToSslPorts : HasIO io => InputPort -> OutputPort -> String -> String -> Buffer -> io (Either Couldn'tSetUpTLS (Pair InputPort OutputPort))
 123 | portsToSslPorts inputPort outputPort keyPath certPath alpnProtocol = do
 124 |   ctx <- primIO (prim__sslMakeServerContext keyPath certPath alpnProtocol)
 125 |   nilOrPortPair <- primIO (prim__portsToSslPorts inputPort outputPort ctx)
 126 |   nil <- primIO (prim__isNil nilOrPortPair)
 127 |   if nil
 128 |      then pure (Left MkCouldn'tSetUpTLS)
 129 |      else do
 130 |        (inputPort, outputPort) <- portPairToIdrisPair (assertIsPortPair nilOrPortPair)
 131 |        MkUnit <- primIO (prim__setBufferModeNone outputPort MkUnit)
 132 |        pure (Right (inputPort, outputPort))
 133 | 
 134 | %foreign "scheme,racket:(lambda (hostname port) (with-handlers ([exn:fail:network? (lambda (x) '())]) (let-values ([(in-port out-port) (tcp-connect hostname port)]) (list in-port out-port)))),racket/tcp"
 135 | prim__tcpConnect : String -> Bits16 -> PrimIO NilOrPortPair
 136 | 
 137 | export
 138 | tcpConnect : HasIO io => String -> Bits16 -> io (Either Couldn'tConnect (Pair InputPort OutputPort))
 139 | tcpConnect hostname port = do
 140 |   nilOrPortPair <- primIO (prim__tcpConnect hostname port)
 141 |   nil <- primIO (prim__isNil nilOrPortPair)
 142 |   if nil
 143 |      then pure (Left MkCouldn'tConnect)
 144 |      else do
 145 |        (inputPort, outputPort) <- portPairToIdrisPair (assertIsPortPair nilOrPortPair)
 146 |        MkUnit <- primIO (prim__setBufferModeNone outputPort MkUnit)
 147 |        pure (Right (inputPort, outputPort))
 148 | 
 149 | %foreign "scheme,racket:read-bytes-evt,racket/port"
 150 | prim__readBytesEvt : Bits16 -> InputPort -> PrimIO ReadSyncEvt
 151 | 
 152 | export
 153 | readBytesEvt : HasIO io => Bits16 -> InputPort -> io ReadSyncEvt
 154 | readBytesEvt count inPort = primIO $ prim__readBytesEvt count inPort
 155 | 
 156 | %foreign "scheme,racket:sync"
 157 | prim__readSync : ReadSyncEvt -> PrimIO EOFOrBuffer
 158 | 
 159 | %foreign "scheme,racket:(lambda (bytes output-port) (with-handlers ([exn:fail:network? (lambda (x) '())]) (write-bytes bytes output-port)))"
 160 | prim__writeBytes : Buffer -> OutputPort -> PrimIO NilOrBits64
 161 | 
 162 | export
 163 | readSync : HasIO io => ReadSyncEvt -> io (Either EOF Buffer)
 164 | readSync readSyncEvt = do
 165 |   evt <- primIO (prim__readSync readSyncEvt)
 166 |   isEOF <- primIO (prim__isEOF evt)
 167 |   if isEOF
 168 |      then pure (Left MkEOF)
 169 |      else pure (Right (assertIsBuffer evt))
 170 | 
 171 | export
 172 | writeBytes : HasIO io => Buffer -> OutputPort -> io (Either WriteError Bits64)
 173 | writeBytes buf outputPort = do
 174 |   writeRes <- primIO (prim__writeBytes buf outputPort)
 175 |   nil <- primIO (prim__isNilWriteResult writeRes)
 176 |   if nil
 177 |      then pure (Left MkWriteError)
 178 |      else pure (Right (assertIsBits64 writeRes))
 179 |