content: -- ----------------------------------------------------------------------------
  
  {- |
    Module     : Holumbus.Network.DoWithServer
    Copyright  : Copyright (C) 2009 Sebastian Reese
    License    : MIT
  
    Maintainer : Sebastian Reese (str@holumbus.org)
    Stability  : experimental
    Portability: portable
    Version    : 0.1
  
    This module provides an interface to start a server listeing on a tcp socket.
    ( Module is based on simple tcp server found here http://sequence.complete.org/node/258 )
    
    You have to implement 2 functions
         type ServerAction  a = a -> Client a -> [Client a] -> IO [Client a]
      
      and
      
        type LineConverter a = String -> a
        
     to start a server use the
       doWithServer :: (Show a) => Int -> ServerAction a -> LineConverter a -> String -> IO ()
     function.
  
  -}
  
  -- ----------------------------------------------------------------------------
  module Holumbus.Network.DoWithServer
  {-# DEPRECATED "this module will be remove in the next release, please use the packages from Holumbus.Distribution.*" #-}
  (
      Client (..)
    , ServerAction
    , LineConverter
    , doWithServer
  )
   where 
  
  --import           Holumbus.Common.Logging
  import System.Log.Logger
  import System.IO
  import Control.Concurrent
  import Control.Concurrent.STM
  import Control.Monad (liftM)
  import Network
  import Holumbus.Common.Utils  ( handleAll )
  
  localLogger :: String
  localLogger = "Holumbus.Network.DoWithServer"
  
  ------------------------------------------------------------------------------------------------------
  -- Datatypes
  
  -- | the connecting client type
  data Client        a = Client (TChan a) Handle HostName PortNumber
  
  instance Show (Client a) where
    show (Client _ _ host port) = "Client " ++ host ++ ":"++show port
    
  instance Eq (Client a) where
    (==) (Client _ _ host1 port1) (Client _ _ host2 port2) = host1 == host2 && port1 == port2
    (/=) c1 c2 = not (c1 == c2)
    
  instance Ord (Client a) where
    compare (Client _ _ host1 port1) (Client _ _ host2 port2) = compare (host1,port1) (host2,port2)
  
  -- | type for call back function that is executed within server cycle
  type ServerAction  a = a -> Client a -> [Client a] -> IO [Client a]
  
  -- | converts the string read by hGetLine to your datatype
  type LineConverter a = String -> a
  ------------------------------------------------------------------------------------------------------
  
  -- | execute a ServerAction wrapped by the tcp server
  doWithServer :: (Show a) => Int -> ServerAction a -> LineConverter a -> String -> IO ()
  doWithServer port action converter prompt = 
    withSocketsDo $ do
      servSock <- listenOn . PortNumber . fromIntegral $ port
      handleAll (\_ -> sClose servSock) $ do
        acceptChan <- atomically newTChan
        _ <- forkIO $ acceptLoop servSock acceptChan converter prompt
        mainLoop servSock acceptChan [] action prompt --`finally` sClose servSock
  
  
  -- | the accept loop for new connections
  acceptLoop :: Socket -> TChan (Client a) -> LineConverter a -> String -> IO ()
  acceptLoop servSock chan convert prompt = do
    (handle, host, port) <- accept servSock
    hPrompt handle prompt
    ch <- atomically newTChan
    _ <- forkIO $ clientLoop (Client ch handle host port) convert
    atomically $ writeTChan chan (Client ch handle host port)
    acceptLoop servSock chan convert prompt
  
  -- | the listenerloops for getting the clients commands
  clientLoop :: Client a -> LineConverter a -> IO ()
  clientLoop client@(Client chan handle _ _) convert =
    handleAll (\_ -> do { infoM localLogger $ "Client disconnected: "++show client; hClose handle; return () }) $ do
      listenLoop (liftM convert $ hGetLine handle) chan
  
  -- | the listenerloops for getting the clients commands
  listenLoop :: IO a -> TChan a -> IO ()
  listenLoop act chan =
    sequence_ (repeat (act >>= atomically . writeTChan chan)) 
  
  -- | the main loop combines new client actions (Left) and new command actions (Right)
  mainLoop :: (Show a) => Socket -> TChan (Client a) -> [(Client a)] -> ServerAction a -> String-> IO ()
  mainLoop servSock acceptChan clients f prompt= do
    r <- atomically $ (Left `fmap` readTChan acceptChan)
                      `orElse`
                      (Right `fmap` tselect clients)
    case r of
      -- a new client
      Left sender -> do
        infoM localLogger $ "new client" ++ show sender
        mainLoop servSock acceptChan (sender:clients) f prompt
     
      -- a new command
      Right (line, sender) -> do
        debugM localLogger $ (show sender) ++ " [ " ++ show line ++ " ]"
        clients' <- f line sender clients
        debugM localLogger $ "Num of Clients: " ++ show (length clients')
        mainLoop servSock acceptChan (clients') f prompt
  
  
  hPrompt :: Handle -> String -> IO ()
  hPrompt h p = do
    openhandle <- hIsOpen h
    if openhandle then do
      hPutStr h p
      hFlush h
      else return ()
  
  tselect :: [(Client a)] -> STM (a, Client a)
  tselect = foldl orElse retry . map (\client@(Client ch _ _ _) -> (\line -> (line,client)) `fmap` readTChan ch) 
  