server.hs

{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
import Control.Applicative
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 as List
import Data.Maybe
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 qualified Text.XML.Expat.Chunked as Tree
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 defaultParseOptions (session (fdPutStrBS 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 :: (B.ByteString -> IO ())  -- ^ Write output data to socket
        -> ListOf (UNode s IO Text)   -- ^ Input XML document
        -> XMLT s IO ()
session writeOut inputXML = do
    let outputXML = formatG $ indent 2 $ Element "server" [] (processRoot inputXML)
    execute $ liftIO . writeOut =<< outputXML
    return ()

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

processCommand :: UNode s IO Text -> UNode s IO Text
processCommand elt@(Element "title" _ _) = Element "title" [] $ joinL $ do
    txt <- textContentM elt
    return $ search txt
processCommand (Element cmd _ _) = Element "unknown" [("command", cmd)] mzero

list2list :: (List l, List l') => l a -> ItemM l (l' a)
list2list l = fromList `liftM` toList l

search :: forall s . Text -> ListOf (UNode s IO Text)
search key = joinL $ do
    iter <- liftIO $ parse defaultParseOptions $ \root -> do
        let l = do
                elt@(Element _ _ children) <- root
                movie <- List.filter isElement children
                return movie
        fromNodeListContainer l
    eMovies <- liftIO $ fileDriver iter "movies.xml"
    case eMovies of
        Left err -> fail $ "failed to read 'movies.xml': "++show err
        Right movies -> return $ List.filter matches movies
  where
    matches elt = key `T.isInfixOf` fromMaybe "" (getAttribute elt "title")