    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Network.CGI.Compat
    -- Copyright   :  (c) The University of Glasgow 2001
    --                (c) Bjorn Bringert 2004-2006
    --                (c) Ian Lynagh 2005
    --                (c) Jeremy Shaw 2005
    -- License     :  BSD-style
    --
    -- Maintainer  :  bjorn@bringert.net
    -- Stability   :  experimental
    -- Portability :  non-portable (uses Control.Monad.State)
    --
    -- Compatibility functions for the old Network.CGI API.
    --
    -----------------------------------------------------------------------------

    module Network.CGI.Compat (
        Html, wrapper, pwrapper, connectToCGIScript
      ) where

    import Control.Concurrent (forkIO)
    import Control.Exception as Exception (Exception,throw,catch,finally)
    import Control.Monad (unless)
    import Control.Monad.Trans (MonadIO, liftIO)
    import qualified Data.Map as Map
    import Network (PortID, Socket, listenOn, connectTo)
    import Network.Socket as Socket (SockAddr(SockAddrInet), accept, socketToHandle)
    import System.IO (Handle, hPutStrLn, stdin, stdout,
                      hGetLine, hClose, IOMode(ReadWriteMode))
    import System.IO.Error (isEOFError)

    import qualified Data.ByteString.Lazy.Char8 as BS
    import Data.ByteString.Lazy.Char8 (ByteString)

    import Text.XHtml (Html, renderHtml)

    import Network.CGI.Protocol

    {-# DEPRECATED wrapper, pwrapper, connectToCGIScript "Use the new interface." #-}

    -- | Compatibility wrapper for the old CGI interface.
    --   Output the output from a function from CGI environment and
    --   input variables to an HTML document.
    wrapper :: ([(String,String)] -> IO Html) -> IO ()
    wrapper = run stdin stdout

    -- | Compatibility wrapper for the old CGI interface.
    --   Runs a simple CGI server.
    --   Note: if using Windows, you might need to wrap 'Network.withSocketsDo' around main.
    pwrapper :: PortID  -- ^ The port to run the server on.
             -> ([(String,String)] -> IO Html)
             -> IO ()
    pwrapper pid f = do sock <- listenOn pid
                        acceptConnections fn sock
     where fn h = run h h f

    acceptConnections :: (Handle -> IO ()) -> Socket -> IO ()
    acceptConnections fn sock = do
      (h, SockAddrInet _ _) <- accept' sock
      forkIO (fn h `finally` (hClose h))
      acceptConnections fn sock

    accept' :: Socket                 -- Listening Socket
           -> IO (Handle,SockAddr)        -- StdIO Handle for read/write
    accept' sock = do
     (sock', addr) <- Socket.accept sock
     handle        <- socketToHandle sock' ReadWriteMode
     return (handle,addr)

    run :: MonadIO m => Handle -> Handle -> ([(String,String)] -> IO Html) -> m ()
    run inh outh f =
        do env <- getCGIVars
           hRunCGI env inh outh f'
      where f' req = do let vs = Map.toList (cgiVars req)
                            is = [ (n,BS.unpack (inputValue i)) | (n,i) <- cgiInputs req ]
                        html <- liftIO (f (vs++is))
                        return ([], CGIOutput $ BS.pack $ renderHtml html)

    -- | Note: if using Windows, you might need to wrap 'Network.withSocketsDo' around main.
    connectToCGIScript :: String -> PortID -> IO ()
    connectToCGIScript host portId
         = do env <- getCGIVars
              input <- BS.hGetContents stdin
              let str = getRequestInput env input
              h <- connectTo host portId
                     `Exception.catch`
                       (\ e -> abort "Cannot connect to CGI daemon." e)
              BS.hPut h str >> hPutStrLn h ""
              (sendBack h `finally` hClose h)
                   `Prelude.catch` (\e -> unless (isEOFError e) (ioError e))

    -- | Returns the query string, or the request body if it is
    --   a POST request, or the empty string if there is an error.
    getRequestInput :: [(String,String)] -- ^ CGI environment variables.
                    -> ByteString            -- ^ Request body.
                    -> ByteString            -- ^ Query string.
    getRequestInput env req =
       case lookup "REQUEST_METHOD" env of
          Just "POST" -> takeInput env req
          _ -> maybe BS.empty BS.pack (lookup "QUERY_STRING" env)

    abort :: String -> Exception -> IO a
    abort msg e =
        do putStrLn ("Content-type: text/html\n\n" ++
                       "<html><body>" ++ msg ++ "</body></html>")
           throw e

    sendBack :: Handle -> IO ()
    sendBack h = do s <- hGetLine h
                    putStrLn s
                    sendBack h