module Holumbus.Console.ServerConsole
(
ConsoleData
, nextOption
, parseOption
, initializeConsole
, addConsoleCommand
, startServerConsole
, defaultaction
, defaultconverter
)
where
import Holumbus.Network.DoWithServer
import System.IO
import Control.Monad (forM)
import qualified Data.Map as Map
import Holumbus.Common.Utils ( handleAll )
import Data.List
startServerConsole ::
ConsoleData a
-> a
-> Int
-> String
-> IO ()
startServerConsole cdata conf port prompt = doWithServer port (defaultaction cdata conf prompt) defaultconverter prompt
defaultaction :: ConsoleData a -> a -> String -> ServerAction String
defaultaction cdata conf prompt line sender clients = do
clients' <- handleAll (\_ -> return $ [delete sender $ clients]) $ do
forM (filter (==sender) clients) $
\(Client _ handle _ _) -> do
result <- handleInput line cdata conf
if result == exitString then do
hClose handle
return . delete sender $ clients
else do
hPutStrLn handle result
hPutStr handle prompt
hFlush handle
return clients
return . concat $ clients'
defaultconverter :: LineConverter String
defaultconverter = id
type ConsoleData a = Map.Map String (ConsoleCommand a)
type ConsoleCommand a = ( Maybe (ConsoleFunction a), String )
type ConsoleFunction a = (a -> [String] -> IO String )
initializeConsole :: ConsoleData a
initializeConsole = Map.fromList [(exitString, exitCommand), (helpString, helpCommand)]
addConsoleCommand
:: String
-> ConsoleFunction a
-> String
-> ConsoleData a
-> ConsoleData a
addConsoleCommand c f d m = Map.insert c (Just f, d) m
exitString :: String
exitString = "exit"
exitCommand :: ConsoleCommand a
exitCommand = ( Nothing, "exit the console")
helpString :: String
helpString = "help"
helpCommand :: ConsoleCommand a
helpCommand = (Nothing, "print this help")
nextOption :: [String] -> IO (Maybe String, [String])
nextOption o
= handleAll (\_ -> return (Nothing, o)) $
do
if ( null o ) then
return (Nothing, o)
else
return (Just $ head o, tail o)
parseOption :: Read a => [String] -> IO (Maybe a, [String])
parseOption o
= handleAll (\_ -> return (Nothing, o)) $
do
if ( null o ) then
return (Nothing, o)
else
return (Just $ read $ head o, tail o)
handleInput :: String -> ConsoleData a -> a -> IO String
handleInput line cdata conf
= do
input <- return (words line)
cmd <- return (command input)
args <- return (arguments input)
if (cmd == exitString)
then do
return exitString
else do
if (not $ null cmd) then handleCommand cdata conf cmd args else return "undefined"
where
command s = if (not $ null s) then head s else ""
arguments s = tail s
handleCommand :: ConsoleData a -> a -> String -> [String] -> IO String
handleCommand cdata conf cmd args
= do
if (cmd == helpString)
then do
printHelp cdata
else do
handleCommand' (Map.lookup cmd cdata)
where
handleCommand' Nothing = do printError
handleCommand' (Just (Nothing, _ )) = do printNoHandler
handleCommand' (Just (Just f, _ )) = do f conf args
printNoHandler :: IO String
printNoHandler = return "no function handler found"
printError :: IO String
printError = return "unknown command, try help for a list of available commands"
printHelp :: ConsoleData a -> IO String
printHelp cdata = return $ "available Commands:\n"++printCommands "" (Map.toAscList cdata)
where
printCommands acc [] = acc
printCommands acc (x:xs) = printCommands (acc ++ "\n" ++ printCommand x) xs
printCommand (c, (_, t)) = (prettyCommandName 15 c) ++ " - " ++ t
prettyCommandName :: Int -> String -> String
prettyCommandName n s
| n <= 0 = s
| (n > 0) && (null s) = ' ' : prettyCommandName (n1) s
| otherwise = x : prettyCommandName (n1) xs
where
(x:xs) = s