<commit_before>{-# LANGUAGE DeriveGeneric #-}

module UniversalLanguageInterface (

    exportAndStart',
    exportAndStart,
    callInterpreter,

) where


import System.Console.ArgParser
import Data.ByteString (hGetLine, hPutStr)
import Data.ByteString.Lazy (fromStrict, toStrict)
import GHC.Generics
import System.IO (openFile, hClose, IOMode(..))
import System.Directory (removeFile)
import Data.Aeson
import qualified Data.Map as M

-- caller

import System.IO.Temp (withSystemTempDirectory)
import System.Posix.Files (createNamedPipe, unionFileModes, ownerReadMode, ownerWriteMode)
import System.Process (waitForProcess, createProcess, proc)

exportAndStart' :: [(String, String -> IO String)] -> IO ()
exportAndStart' fs = exportAndStart $ M.fromList fs

data CommandLineOptions = CommandLineOptions {
    mode :: String,
    inputPipe :: String,
    outputPipe :: String } deriving (Show, Eq)

data InputFunctionCall = InputFunctionCall {
    name :: String,
    args :: String
} deriving (Show, Generic)

data NormalResult = NormalResult {
    ncode :: Int,
    return_val :: String
} deriving (Show, Generic)
    
data ErrorResult = ErrorResult {
    ecode :: Int,
    message :: String
} deriving (Show, Generic)

instance ToJSON NormalResult
instance ToJSON ErrorResult
instance FromJSON NormalResult
instance FromJSON ErrorResult

instance ToJSON InputFunctionCall
instance FromJSON InputFunctionCall
    
exportAndStart :: M.Map String (String -> IO String) -> IO ()
exportAndStart fs = 
    let parser :: ParserSpec CommandLineOptions
        parser = CommandLineOptions 
            `parsedBy` reqFlag "mode"
            `andBy` reqFlag "input-pipe"
            `andBy` reqFlag "output-pipe"
    in withParseResult parser (\options -> do
            hin <- openFile (inputPipe options) ReadMode
            hout <- openFile (outputPipe options) WriteMode
            inputLine <- hGetLine hin 
            case decode (fromStrict inputLine) of 
                Nothing -> error "Unable to parse input " -- TODO, throw 500 onto hout
                Just (InputFunctionCall name args) -> 
                    case M.lookup name fs of 
                        Nothing -> error "Function name does not exist" -- TODO throw 500 to hout
                        Just f -> do 
                            message <- f args
                            hPutStr hout $ toStrict $ encode (NormalResult 200 message)

            

            hClose hin
            hClose hout
    )
            

callInterpreter :: String -- interpreter name
                -> String -- program file path
                -> String -- function name
                -> String -- argument
                -> IO String -- result

callInterpreter intname progfile funname arg = 
    withSystemTempDirectory "haskellcallertemp" $ \tempDirPath -> do
        let callerToCalleePipe = tempDirPath ++ "/inp"
            calleeToCallerPipe = tempDirPath ++ "/outp"
        createNamedPipe callerToCalleePipe (ownerReadMode `unionFileModes` ownerWriteMode)
        createNamedPipe calleeToCallerPipe (ownerReadMode `unionFileModes` ownerWriteMode)
        (_, _, _, h) <- createProcess (proc intname [progfile, "--mode", "single", "--input-pipe", callerToCalleePipe, "--output-pipe", calleeToCallerPipe])
        hCallerToCallee <- openFile callerToCalleePipe WriteMode
        hPutStr hCallerToCallee $ toStrict $ encode (InputFunctionCall funname arg)
        hCalleeToCaller <- openFile calleeToCallerPipe ReadMode
        -- hClose hCallerToCallee
        waitForProcess h
        line <- hGetLine hCallerToCallee
         
        -- clean up
        hClose hCalleeToCaller
        hClose hCallerToCallee
        -- probably fine without this, temp directory will be deleted
        removeFile callerToCalleePipe
        removeFile calleeToCallerPipe

        case decode (fromStrict line) of 
            Nothing -> case decode (fromStrict line) of
                            Nothing -> error "Unable to parse return"
                            Just (ErrorResult _ message) -> error message
            Just (NormalResult _ returnVal) -> return returnVal


    
        

    

<commit_msg>Fixed Haskell Bug, caused by Lazy I/O with named pipes<commit_after>{-# LANGUAGE DeriveGeneric #-}

module UniversalLanguageInterface (

    exportAndStart',
    exportAndStart,
    callInterpreter,

) where


import System.Console.ArgParser
import Data.ByteString (hGetLine, hPutStr)
import Data.ByteString.Lazy (fromStrict, toStrict)
import Data.ByteString.Lazy.Char8 (unpack)
import GHC.Generics
import System.IO (openFile, hClose, IOMode(..))
import System.Posix.IO (openFd, closeFd, OpenFileFlags(..), fdRead, fdWrite, OpenMode(..))
import System.Directory (removeFile)
import Data.Aeson
import qualified Data.Map as M

-- caller

import System.IO.Temp (withSystemTempDirectory)
import System.Posix.Files (createNamedPipe, unionFileModes, ownerReadMode, ownerWriteMode)
import System.Process (waitForProcess, createProcess, proc)

exportAndStart' :: [(String, String -> IO String)] -> IO ()
exportAndStart' fs = exportAndStart $ M.fromList fs

data CommandLineOptions = CommandLineOptions {
    mode :: String,
    inputPipe :: String,
    outputPipe :: String } deriving (Show, Eq)

data InputFunctionCall = InputFunctionCall {
    name :: String,
    args :: String
} deriving (Show, Generic)

data NormalResult = NormalResult {
    ncode :: Int,
    return_val :: String
} deriving (Show, Generic)
    
data ErrorResult = ErrorResult {
    ecode :: Int,
    message :: String
} deriving (Show, Generic)

instance ToJSON NormalResult
instance ToJSON ErrorResult
instance FromJSON NormalResult
instance FromJSON ErrorResult

instance ToJSON InputFunctionCall
instance FromJSON InputFunctionCall

flags = OpenFileFlags False False False False False
    
exportAndStart :: M.Map String (String -> IO String) -> IO ()
exportAndStart fs = 
    let parser :: ParserSpec CommandLineOptions
        parser = CommandLineOptions 
            `parsedBy` reqFlag "mode"
            `andBy` reqFlag "input-pipe"
            `andBy` reqFlag "output-pipe"
    in withParseResult parser (\options -> do
            hin <- openFile (inputPipe options) ReadMode
            hout <- openFd (outputPipe options) WriteOnly Nothing flags
            inputLine <- hGetLine hin 
            case decode (fromStrict inputLine) of 
                Nothing -> error "Unable to parse input " -- TODO, throw 500 onto hout
                Just (InputFunctionCall name args) -> 
                    case M.lookup name fs of 
                        Nothing -> error "Function name does not exist" -- TODO throw 500 to hout
                        Just f -> do 
                            message <- f args
                            fdWrite hout $ (unpack $ encode (NormalResult 200 message)) ++ "\n"

            

            hClose hin
            closeFd hout
    )
            

callInterpreter :: String -- interpreter name
                -> String -- program file path
                -> String -- function name
                -> String -- argument
                -> IO String -- result

callInterpreter intname progfile funname arg = 
    withSystemTempDirectory "haskellcallertemp" $ \tempDirPath -> do
        let callerToCalleePipe = tempDirPath ++ "/inp"
            calleeToCallerPipe = tempDirPath ++ "/outp"
        createNamedPipe callerToCalleePipe (ownerReadMode `unionFileModes` ownerWriteMode)
        createNamedPipe calleeToCallerPipe (ownerReadMode `unionFileModes` ownerWriteMode)
        (_, _, _, h) <- createProcess (proc intname [progfile, "--mode", "single", "--input-pipe", callerToCalleePipe, "--output-pipe", calleeToCallerPipe])
        hCallerToCallee <- openFd callerToCalleePipe WriteOnly Nothing flags
        fdWrite hCallerToCallee $ (unpack $ encode (InputFunctionCall funname arg)) ++ "\n"
        hCalleeToCaller <- openFile calleeToCallerPipe ReadMode
        -- hClose hCallerToCallee
        waitForProcess h
        line <- hGetLine hCalleeToCaller
         
        -- clean up
        hClose hCalleeToCaller
        closeFd hCallerToCallee
        -- probably fine without this, temp directory will be deleted
        removeFile callerToCalleePipe
        removeFile calleeToCallerPipe

        case decode (fromStrict line) of 
            Nothing -> case decode (fromStrict line) of
                            Nothing -> error "Unable to parse return"
                            Just (ErrorResult _ message) -> error message
            Just (NormalResult _ returnVal) -> return returnVal


    
        

    


{'fraction_non_alphanumeric': 0.07668213457076566, 'fraction_numerical': 0.0022041763341067284, 'mean_word_length': 2.421031746031746, 'pattern_counts': {'":': 0, '<': 19, '<?xml version=': 0, '>': 39, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6744377', 'n_tokens_mistral': 2407, 'n_tokens_neox': 2280, 'n_words': 711}