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

module App.IPC (toIPC, fromIPC, toTypedIPC, fromTypedIPC) where

{-
  This file contains raw serialization and deserialization of IPC messages.
  An IPC message can contain either the payload length followed by the content,
  or a 'type number' can be added between those values.

  [payload length in bytes][payload]
  [payload length in bytes][message type][payload]

  The message type informs what format should be expected.
  For example: an authentication attempt, a page request, etc.
  Actual message formats can be found in the App.Messages folder.
-}

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

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

import Data.UInt (fromInt, UInt)
import Data.Tuple (Tuple(..))
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

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

toIPC :: String -> Effect ArrayBuffer
toIPC 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

toTypedIPC :: UInt -> String -> Effect ArrayBuffer
toTypedIPC n 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) + 1 -- 1 for message type
  Builder.putUint8 n
  Builder.putArrayBuffer stringbuf

-- 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.
fromIPC :: ArrayBuffer -> Effect (Either ParseError String)
fromIPC 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

-- 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.
fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
fromTypedIPC 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
    -- Second parse a 8-bit unsigned integer representing the type of
    -- the message to decode.
    messageTypeNumber <- Parsing.DataView.anyUint8
    stringview <- Parsing.DataView.takeN length
    stringarray <- lift $ liftEffect $ Cast.toUint8Array stringview
    hoistEffectParserT $ (Tuple messageTypeNumber) <$> TextDecoder.decode stringarray textDecoder