Server.hs

{-# LANGUAGE OverloadedStrings #-}

module Network.YAML.Server where

import Control.Monad 
import Control.Monad.State
import Control.Concurrent
import Control.Exception
import Network
import System.IO
import qualified Data.ByteString.Char8 as BS
import Data.Object.Yaml

import Network.YAML.Types
import Network.YAML.Base
import Network.YAML.Instances

-- | Run each IO action in separate thread and return all results
forkA :: [IO a] -> IO [a]
forkA lst = do
    let n = length lst
    vars <- replicateM n newEmptyMVar
    mapM (forkIO . run) $ zip lst vars
    mapM takeMVar vars
  where
    run (x,v) = do
      r <- x
      putMVar v r

-- | Read lines from Handle
readHandle :: Handle
           -> [BS.ByteString]       -- ^ Already read lines
           -> IO [BS.ByteString]
readHandle h acc = do
  eof <- hIsEOF h
  if eof
    then return acc
    else do
      line <- BS.hGetLine h
      let line' = if BS.null line
                    then line
                    else if (BS.last line)=='\r'
                            then BS.init line
                            else line
  --           print $ "read line:"++line'
      if BS.null line'
        then return acc
        else readHandle h (acc ++ [line'])

-- | Start server and wait for connections.
-- This server closes connection after each query.
-- So, each call is processed in another thread.
server ::
      Int                              -- ^ Port number
   -> Worker
   -> IO ()
server port callOut = do
--        installHandler sigPIPE Ignore Nothing    
      sock  <- listenOn (PortNumber $ fromIntegral port)
      (forever $ loop sock) `finally` sClose sock
  where
    loop :: Socket -> IO ThreadId
    loop sock =
         do (h,_nm,_port) <- accept sock
            forkIO
              (do 
                hSetBuffering h NoBuffering
                lns <- readHandle h []
                let text = BS.unlines lns
                case unserialize text of
                  Nothing -> hClose h
                  Just ob -> do
--                     print ob
                    res <- callOut ob
                    BS.hPutStrLn h $ serialize res
                    hClose h)

-- | Start server and wait for connections.
-- This server does not close connection after query.
-- So, new thread is created only per-client, not per-query.
persistentServer :: 
      Int 
   -> Worker
   -> IO ()
persistentServer port callOut = do
--        installHandler sigPIPE Ignore Nothing    
      sock  <- listenOn (PortNumber $ fromIntegral port)
      (forever $ loop sock) `finally` sClose sock
  where
    loop :: Socket -> IO ThreadId
    loop sock =
         do (h,_nm,_port) <- accept sock
            forkIO (worker h)

    worker :: Handle -> IO ()
    worker h = do 
      hSetBuffering h NoBuffering
      lns <- readHandle h []
      let text = BS.unlines lns
      if BS.null text
        then hClose h
        else
          case unserialize text of
            Nothing -> hClose h
            Just ob -> do
              res <- callOut ob
              BS.hPutStrLn h $ serialize res
              if getScalarAttr "connection" ob == Just ("close" :: BS.ByteString)
                then hClose h
                else worker h