halogen-websocket-ipc-playzone/src/App/IPC.purs

module App.IPC (toIPC, fromIPC) where

import Prelude (bind, discard, ($), (>>>))

import Effect (Effect)
import Effect.Class (liftEffect)

import Data.UInt (fromInt)
import Data.ArrayBuffer.ArrayBuffer as ArrayBuffer
import Data.ArrayBuffer.Types (ArrayBuffer, DataView)
import Data.ArrayBuffer.Builder as Builder

import Data.ArrayBuffer.Cast as Cast

import Control.Monad.Trans.Class (lift)
import Control.Monad.Except (ExceptT(ExceptT), withExceptT)
import Data.ArrayBuffer.Typed as Typed
import Data.ArrayBuffer.DataView as DataView
import Parsing.DataView as Parsing.DataView
import Parsing as Parsing
import Parsing (ParseError, ParserT, runParserT)

import Web.Encoding.TextEncoder as TextEncoder
import Web.Encoding.TextDecoder as TextDecoder
import Web.Encoding.UtfLabel as UtfLabel

import Data.Either (Either)
import Effect.Exception as Exception

utf8ToArrayBuffer :: String -> Effect ArrayBuffer
utf8ToArrayBuffer s = Builder.execPutM do
  textEncoder <- liftEffect TextEncoder.new
  let stringbuf = Typed.buffer $ TextEncoder.encode s textEncoder
  -- Put a 32-bit big-endian length for the utf8 string, in bytes.
  Builder.putUint32be $ fromInt $ ArrayBuffer.byteLength stringbuf
  Builder.putArrayBuffer stringbuf

toIPC :: String -> Effect ArrayBuffer
toIPC = utf8ToArrayBuffer

fromIPC :: ArrayBuffer -> Effect (Either ParseError String)
fromIPC = arrayBufferToUtf8

-- TODO: this code doesn't verify the actual length of the message.
-- An inconsistent length would be an error sign, message should be discarded
-- and the connection should be closed.
arrayBufferToUtf8 :: ArrayBuffer -> Effect (Either ParseError String)
arrayBufferToUtf8 arrayBuffer = do
  textDecoder <- TextDecoder.new UtfLabel.utf8
  let dataView = DataView.whole arrayBuffer
  runParserT dataView do
    -- First parse a 32-bit big-endian length prefix for the length
    -- of the UTF-8 string in bytes.
    length <- Parsing.DataView.anyInt32be
    stringview <- Parsing.DataView.takeN length
    stringarray <- lift $ liftEffect $ Cast.toUint8Array stringview
    hoistEffectParserT $ TextDecoder.decode stringarray textDecoder

hoistEffectParserT
  :: forall a
   . Effect a
  -> ParserT DataView Effect a
hoistEffectParserT
  = Exception.try
  >>> ExceptT
  >>> withExceptT Exception.message
  >>> Parsing.liftExceptT