|
@@ -0,0 +1,107 @@
|
|
|
+{-# LANGUAGE OverloadedStrings #-}
|
|
|
+
|
|
|
+module Walrus.Backend (
|
|
|
+ parseBackend,
|
|
|
+ runBackend
|
|
|
+ ) where
|
|
|
+
|
|
|
+import qualified Data.Attoparsec.ByteString.Char8 as A
|
|
|
+import qualified Data.Attoparsec.ByteString.Lazy as LA
|
|
|
+import Data.Attoparsec.ByteString.Char8.Extras
|
|
|
+import qualified Data.ByteString.Lazy as LBS
|
|
|
+import qualified Data.Char as C
|
|
|
+import Encoding
|
|
|
+
|
|
|
+import Walrus.Backend.Metadata
|
|
|
+import Walrus.Backend.Request
|
|
|
+
|
|
|
+import Control.Applicative
|
|
|
+
|
|
|
+import Network
|
|
|
+import System.IO
|
|
|
+import qualified System.Process as P
|
|
|
+
|
|
|
+data Backend = TCPBackend String Int | UnixSocketBackend String | ExecBackend String [String]
|
|
|
+
|
|
|
+parseBackend :: A.Parser Backend
|
|
|
+parseBackend = do
|
|
|
+ A.choice [
|
|
|
+ do
|
|
|
+ tp "tcp"
|
|
|
+ h <- tillSpace
|
|
|
+ p <- A.decimal
|
|
|
+ return $ TCPBackend h p,
|
|
|
+ do
|
|
|
+ tp "unix"
|
|
|
+ tp "socket"
|
|
|
+ p <- qStr
|
|
|
+ return $ UnixSocketBackend p,
|
|
|
+ do
|
|
|
+ tp "exec"
|
|
|
+ f <- qStr
|
|
|
+ pp <- parseParameters
|
|
|
+ return $ ExecBackend f pp
|
|
|
+ ]
|
|
|
+ where
|
|
|
+ tp t = do
|
|
|
+ skipHorizontalSpace
|
|
|
+ A.stringCI t
|
|
|
+ skipHorizontalSpace
|
|
|
+ tillSpace :: A.Parser String
|
|
|
+ tillSpace = bsutf8 <$> A.takeTill C.isSpace
|
|
|
+ qStr :: A.Parser String
|
|
|
+ qStr = bsutf8 <$> quotedString '\\' " " ""
|
|
|
+ parseParameters = A.many' $ do
|
|
|
+ p <- qStr
|
|
|
+ skipHorizontalSpace
|
|
|
+ return p
|
|
|
+
|
|
|
+runBackend :: Backend -> (Request, Metadata, LBS.ByteString) -> IO (Either String (Metadata, LBS.ByteString))
|
|
|
+runBackend b (req, m, qdt) = case renderMetadata m of
|
|
|
+ Nothing -> return $ Left "Metadata error"
|
|
|
+ Just rm -> do
|
|
|
+ edt' <- intBk b $ LBS.concat [
|
|
|
+ LBS.fromStrict . utf8bs . show $ req,
|
|
|
+ LBS.fromStrict rm,
|
|
|
+ "\r\n",
|
|
|
+ qdt]
|
|
|
+ case LA.parse repParse edt' of
|
|
|
+ LA.Fail _ _ e -> return $ Left e
|
|
|
+ LA.Done edt m' -> return $ Right (m', edt)
|
|
|
+ where
|
|
|
+ intBk :: Backend -> LBS.ByteString -> IO LBS.ByteString
|
|
|
+ intBk (TCPBackend h p) = runTcp h p
|
|
|
+ intBk (UnixSocketBackend f) = runUnix f
|
|
|
+ intBk (ExecBackend f aa) = runExec f aa
|
|
|
+ repParse = do
|
|
|
+ m' <- parseMetadata
|
|
|
+ A.endOfLine
|
|
|
+ return m'
|
|
|
+
|
|
|
+runTcp :: String -> Int -> LBS.ByteString -> IO LBS.ByteString
|
|
|
+runTcp host port dt = do
|
|
|
+ h <- connectTo host (PortNumber . fromIntegral $ port)
|
|
|
+ bkgTrans h dt
|
|
|
+
|
|
|
+runUnix :: String -> LBS.ByteString -> IO LBS.ByteString
|
|
|
+runUnix path dt = do
|
|
|
+ h <- connectTo "localhost" (UnixSocket path)
|
|
|
+ bkgTrans h dt
|
|
|
+
|
|
|
+bkgTrans :: Handle -> LBS.ByteString -> IO LBS.ByteString
|
|
|
+bkgTrans h dt = do
|
|
|
+ hSetNewlineMode h noNewlineTranslation
|
|
|
+ LBS.hPut h dt
|
|
|
+ hFlush h
|
|
|
+ LBS.hGetContents h
|
|
|
+
|
|
|
+runExec :: String -> [String] -> LBS.ByteString -> IO LBS.ByteString
|
|
|
+runExec f args dt = do
|
|
|
+ (Just i, Just o, _, _) <- P.createProcess (
|
|
|
+ (P.proc f args){P.std_in=P.CreatePipe}{
|
|
|
+ P.std_out=P.CreatePipe}{P.std_err=P.Inherit}
|
|
|
+ )
|
|
|
+ mapM (\h -> hSetNewlineMode h noNewlineTranslation) [i, o]
|
|
|
+ LBS.hPut i dt
|
|
|
+ hFlush i
|
|
|
+ LBS.hGetContents o
|