Server-side IPC emulation

IPC.hs

{-# LANGUAGE DataKinds, TypeOperators, TypeApplications #-}
module Main where

import Control.Concurrent (threadDelay, forkIO)
import Control.Monad (when, mapM_)

import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSLC

import Data.HashMap.Strict (HashMap, singleton)
import Data.Binary
import Data.Binary.Instances.UnorderedContainers ()

import System.Exit (ExitCode(..))
import System.IO
import System.Process (createPipe)
import System.Posix.Process (forkProcess, getProcessStatus, ProcessStatus(..))

bigBytestring :: BSL.ByteString
bigBytestring = encode $ singleton "str" (Just "strstrstr!strrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr\
\rrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr\
\rrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr\
\rrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr")

action :: Int -> IO ()
action arg = do
  (readHandle, writeHandle) <- createPipe
  hSetBinaryMode readHandle True
  hSetBinaryMode writeHandle True
  pid <- forkProcess $ do
    hIsOpen readHandle >>= \flag -> when flag (hClose readHandle)
    BSL.hPutStr writeHandle $ bigBytestring
    hIsOpen writeHandle >>= \flag -> when flag (hClose writeHandle)
  Just (Exited ExitSuccess) <- getProcessStatus True False pid
  hIsOpen writeHandle >>= \flag -> when flag (hClose writeHandle)
  let typedDecode = decode @(HashMap String (Maybe String))
  BSL.hGetContents readHandle >>= \b -> (print (show arg ++ ": accepted") >> print (typedDecode b))
  hIsOpen readHandle >>= \flag -> when flag (hClose readHandle)

run :: Int -> IO ()
run n = threadDelay 20000 >> forkIO (action n)

main :: IO ()
main = mapM_ run [1..]