server.hs

{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.ListT
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B (unsafeUseAsCStringLen)
import Data.Iteratee
import Data.Iteratee.IO.Fd
import Data.Iteratee.WrappedByteString
import Data.List.Class
import Data.Text (Text)
import qualified Data.Text as T
import Network
import System.IO
import System.Posix.IO (handleToFd, fdWriteBuf, closeFd)
import System.Posix.Types (Fd)
import Text.XML.Expat.Chunked
import Text.XML.Expat.Format
import Foreign.Ptr


main :: IO ()
main = do
    let port = 6333
    putStrLn $ "listening on port "++show port
    ls <- listenOn $ PortNumber port
    forever $ do
        (h, _, _) <- accept ls
        forkIO $ handleToFd h >>= \fd -> do
            iter <- parse defaultParserOptions (session fd)
            result <- enumFd fd iter >>= run
            print result
          `finally`
            closeFd fd

fdPutStrBS :: Fd -> B.ByteString -> IO ()
fdPutStrBS fd bs = B.unsafeUseAsCStringLen bs $ \(buf, len) ->
        writeFully (castPtr buf) (fromIntegral len)
  where
    writeFully _ len | len == 0 = return ()
    writeFully buf len = do
        written <- fdWriteBuf fd buf len
        if written < 0
            then fail "write failed"
            else writeFully (buf `plusPtr` fromIntegral written) (len - written)

session :: Fd                      -- ^ Socket for writing output to
        -> ListOf (UNode IO Text)  -- ^ Input XML document
        -> XMLT IO ()
session fd inputXML = do
    let outputXML = formatG $ indent 2 $ Element "server" [] (processRoot inputXML)
    execute $ liftIO . fdPutStrBS fd =<< outputXML
    return ()

processRoot :: ListOf (UNode IO Text) -> ListOf (UNode IO Text)
processRoot root = do
    Element _ _ children <- root
    child <- children
    extractElements child
  where
    extractElements :: UNode IO Text -> UNodes IO Text
    extractElements elt | isElement elt = processCommand elt `cons` mzero
    extractElements _                   = mzero

processCommand :: UNode IO Text -> UNode IO Text
processCommand (Element "hello" _ _) = Element "hello-back" [] mzero
processCommand (Element cmd _ _) = Element "unknown" [("command", cmd)] mzero