walrus-backend/src/Walrus/Backend.hs

{-# 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