SCGI.hs

module Network.SCGI (
    runOnceSCGI
  , runSCGI

  , module Network.CGI
  ) where

import Control.Exception    (bracket)
import Control.Monad.Fix    (fix)
import Data.ByteString.Lazy.Char8 (ByteString)
import Network
import Network.CGI
import Network.CGI.Monad    (runCGIT)
import Network.CGI.Protocol (runCGIEnvFPS)
import System.IO            (Handle)

import qualified Data.ByteString.Lazy.Char8 as B

runSCGI        :: PortID -> CGI CGIResult -> IO ()
runSCGI port f = listen port $ fix $ \loop socket -> do
    (handle, _, _) <- accept socket
    doSCGI f handle
    loop socket

runOnceSCGI        :: PortID -> CGI CGIResult -> IO ()
runOnceSCGI port f = listen port $ \socket -> do
    (handle, _, _) <- accept socket
    doSCGI f handle

doSCGI          :: CGI CGIResult -> Handle -> IO ()
doSCGI f handle = do
    (hdrs, body) <- fmap request $ B.hGetContents handle
    output       <- runCGIEnvFPS hdrs body (runCGIT f)
    B.hPut handle output

listen           :: PortID -> (Socket -> IO ()) -> IO ()
listen port loop = withSocketsDo $
    bracket (listenOn port) sClose loop

request     :: ByteString -> ([(String, String)], ByteString)
request str = (headers hdrs, body)
  where
    (hdrs, body) = netstring str

netstring    :: ByteString -> (String, ByteString)
netstring cs =
    let (len, rest) = B.span (/= ':') cs
        (str, body) = B.splitAt (read $ B.unpack len) (B.tail rest)
    in (B.unpack str, B.tail body)

headers :: String -> [(String, String)]
headers = pairs . split '\NUL'

pairs           :: [a] -> [(a, a)]
pairs (x:y:xys) = (x, y) : pairs xys
pairs _         = []

split            :: Eq a => a -> [a] -> [[a]]
split delim str
    | [] <- rest = [token]
    | otherwise  = token : split delim (tail rest)
  where
    (token, rest) = span (/= delim) str