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

module App.IPC (toIPC, fromIPC) where

import Prelude

import Effect (Effect)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Class.Console as Console

import Data.Maybe
import Data.UInt (UInt, fromInt, toInt)
import Data.Array (drop, cons)
import Data.ArrayBuffer.ArrayBuffer as ArrayBuffer
import Data.ArrayBuffer.Types (DataView, ArrayBuffer(..))
import Data.ArrayBuffer.Typed (buffer)
import Data.ArrayBuffer.ArrayBuffer as AB
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 (ParserT(..), ParseError(..), runParserT)

import Data.String.CodeUnits as CU

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

import Data.Char (fromCharCode)

import Data.ArrayBuffer.DataView as DV
import Effect.Unsafe
import Data.Either (Either(Left, Right), either, note, hush)
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

-- TODO: make sure the String length is correct.
fromIPC :: ArrayBuffer -> Effect String
fromIPC ab = arrayBufferToUtf8 ab >>= case _ of
    Left parseError -> do
      pure $ show parseError
    Right string -> do
      pure string

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