module RzPipe (RzContext(), open, cmd, cmdj) where
import Data.Char
import Data.Word
import Network.HTTP
import System.IO
import System.Process
import System.Environment (getEnv)
import GHC.IO.Handle.FD
import System.Posix.Internals (FD)
import qualified Data.Aeson as JSON
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.UTF8 as U

withPipes :: CreateProcess -> CreateProcess
withPipes CreateProcess
p = CreateProcess
p { std_in :: StdStream
std_in = StdStream
CreatePipe, std_out :: StdStream
std_out = StdStream
CreatePipe, std_err :: StdStream
std_err = StdStream
CreatePipe }

createProcess' :: CreateProcess -> IO (Handle, Handle, Handle, ProcessHandle)
createProcess' CreateProcess
args = ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> (Handle, Handle, Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Handle, Handle, Handle, ProcessHandle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> (Handle, Handle, Handle, ProcessHandle)
forall a b c d. (Maybe a, Maybe b, Maybe c, d) -> (a, b, c, d)
f (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> IO (Handle, Handle, Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Handle, Handle, Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess -> CreateProcess
withPipes CreateProcess
args) where
    f :: (Maybe a, Maybe b, Maybe c, d) -> (a, b, c, d)
f (Just a
i, Just b
o, Just c
e, d
h) = (a
i, b
o, c
e, d
h)
    f (Maybe a, Maybe b, Maybe c, d)
_ = [Char] -> (a, b, c, d)
forall a. HasCallStack => [Char] -> a
error [Char]
"createProcess': Failed to open pipes to the subprocess."

lHTakeWhile :: (Word8 -> Bool) -> Handle -> IO B.ByteString
lHTakeWhile :: (Word8 -> Bool) -> Handle -> IO ByteString
lHTakeWhile Word8 -> Bool
p Handle
h = do
    Word8
c <- (ByteString -> Word8) -> IO ByteString -> IO Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Word8
B.head (IO ByteString -> IO Word8) -> IO ByteString -> IO Word8
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
B.hGet Handle
h Int
1
    if Word8 -> Bool
p Word8
c
        then (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word8
c Word8 -> ByteString -> ByteString
`B.cons`) (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> Handle -> IO ByteString
lHTakeWhile Word8 -> Bool
p Handle
h
        else ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty

data RzContext = HttpCtx String
               | PipeCtx Handle Handle

open :: Maybe String -> IO RzContext
open :: Maybe [Char] -> IO RzContext
open (Just url :: [Char]
url@(Char
'h':Char
't':Char
't':Char
'p':[Char]
_)) = RzContext -> IO RzContext
forall (m :: * -> *) a. Monad m => a -> m a
return (RzContext -> IO RzContext) -> RzContext -> IO RzContext
forall a b. (a -> b) -> a -> b
$ [Char] -> RzContext
HttpCtx ([Char]
url [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/cmd/")
open (Just [Char]
filename) = do
    (Handle
hIn, Handle
hOut, Handle
_, ProcessHandle
_) <- CreateProcess -> IO (Handle, Handle, Handle, ProcessHandle)
createProcess' (CreateProcess -> IO (Handle, Handle, Handle, ProcessHandle))
-> CreateProcess -> IO (Handle, Handle, Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> CreateProcess
proc [Char]
"rizin" [[Char]
"-q0", [Char]
filename]
    (Word8 -> Bool) -> Handle -> IO ByteString
lHTakeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) Handle
hOut -- drop the inital null that rizin emits
    RzContext -> IO RzContext
forall (m :: * -> *) a. Monad m => a -> m a
return (RzContext -> IO RzContext) -> RzContext -> IO RzContext
forall a b. (a -> b) -> a -> b
$ Handle -> Handle -> RzContext
PipeCtx Handle
hIn Handle
hOut
open Maybe [Char]
Nothing = do
    Handle
hIn <- FD -> IO Handle
fdToHandle (FD -> IO Handle) -> IO FD -> IO Handle
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ([Char] -> FD
forall a. Read a => [Char] -> a
read::(String -> FD)) ([Char] -> FD) -> IO [Char] -> IO FD
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
getEnv [Char]
"RZ_PIPE_OUT"
    Handle
hOut <- FD -> IO Handle
fdToHandle (FD -> IO Handle) -> IO FD -> IO Handle
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ([Char] -> FD
forall a. Read a => [Char] -> a
read::(String -> FD)) ([Char] -> FD) -> IO [Char] -> IO FD
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
getEnv [Char]
"RZ_PIPE_IN"
    RzContext -> IO RzContext
forall (m :: * -> *) a. Monad m => a -> m a
return (RzContext -> IO RzContext) -> RzContext -> IO RzContext
forall a b. (a -> b) -> a -> b
$ Handle -> Handle -> RzContext
PipeCtx Handle
hIn Handle
hOut

cmdHttp :: String -> String -> IO String
cmdHttp :: [Char] -> [Char] -> IO [Char]
cmdHttp [Char]
url [Char]
cmd = Result (Response [Char]) -> IO [Char]
forall ty. Result (Response ty) -> IO ty
getResponseBody (Result (Response [Char]) -> IO [Char])
-> IO (Result (Response [Char])) -> IO [Char]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Request [Char] -> IO (Result (Response [Char]))
forall ty. HStream ty => Request ty -> IO (Result (Response ty))
simpleHTTP ([Char] -> Request [Char]
getRequest ([Char]
url [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
urlEncode [Char]
cmd))

cmdPipe :: Handle -> Handle -> String -> IO B.ByteString
cmdPipe :: Handle -> Handle -> [Char] -> IO ByteString
cmdPipe Handle
hIn Handle
hOut [Char]
cmd = Handle -> [Char] -> IO ()
hPutStrLn Handle
hIn [Char]
cmd IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
hIn IO () -> IO ByteString -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Word8 -> Bool) -> Handle -> IO ByteString
lHTakeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) Handle
hOut

cmdB :: RzContext -> String -> IO B.ByteString
cmdB :: RzContext -> [Char] -> IO ByteString
cmdB (HttpCtx [Char]
url) [Char]
cmd = [Char] -> ByteString
U.fromString ([Char] -> ByteString) -> IO [Char] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [Char] -> IO [Char]
cmdHttp [Char]
url [Char]
cmd
cmdB (PipeCtx Handle
hIn Handle
hOut) [Char]
cmd = Handle -> Handle -> [Char] -> IO ByteString
cmdPipe Handle
hIn Handle
hOut [Char]
cmd

cmd :: RzContext -> String -> IO String
cmd :: RzContext -> [Char] -> IO [Char]
cmd (HttpCtx [Char]
url) [Char]
cmd = [Char] -> [Char] -> IO [Char]
cmdHttp [Char]
url [Char]
cmd
cmd (PipeCtx Handle
hIn Handle
hOut) [Char]
cmd = ByteString -> [Char]
U.toString (ByteString -> [Char]) -> IO ByteString -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> Handle -> [Char] -> IO ByteString
cmdPipe Handle
hIn Handle
hOut [Char]
cmd

cmdj :: JSON.FromJSON a => RzContext -> String -> IO (Maybe a)
cmdj :: RzContext -> [Char] -> IO (Maybe a)
cmdj = ((ByteString -> Maybe a) -> IO ByteString -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Maybe a
forall a. FromJSON a => ByteString -> Maybe a
JSON.decode (IO ByteString -> IO (Maybe a))
-> ([Char] -> IO ByteString) -> [Char] -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([Char] -> IO ByteString) -> [Char] -> IO (Maybe a))
-> (RzContext -> [Char] -> IO ByteString)
-> RzContext
-> [Char]
-> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RzContext -> [Char] -> IO ByteString
cmdB