module XenConfigParser ( Host (..), maybeHostFromFile ) where

-- Coypright 2007 Adam Peacock adpeac@gmail.com

import Prelude hiding ( exp )
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language( emptyDef )

{- to generate the iptables rules, we need to know what 
   ports to open up and what virtual interface it runs on.
   The hostname is optional, but included all the same -}

data Host = 
	Host { hostName :: String 
	     , vifname :: String
	     , portsIncomingOpenTCP :: [Int]
	     , portsIncomingOpenUDP :: [Int]
	     } deriving Show

instance Eq Host where
	h1 == h2 = hostName h1 == hostName h2
	h1 /= h2 = hostName h1 /= hostName h2

data Stmt = HostName String 
	  | VIFName String
	  | TCP [Int]
	  | UDP [Int]
	  | DontCare
	    deriving Show

-- maybeHostFromFile parses many statements in a given file name
-- and returns maybe a host
maybeHostFromFile :: String -> IO (Maybe Host)
maybeHostFromFile fileName = do
	statements <- parseFromFile (many (stripped stmt)) fileName 
	case statements of
		Left err -> return Nothing
		Right ss -> return $ toValidHost ss

{- ### LEXER ### -}

lexer = P.makeTokenParser xenDef
		where 
		xenDef = emptyDef
			 { P.commentStart = "# "
			 , P.reservedOpNames = [portOperator]
			 , P.opLetter = oneOf "="
			 , P.reservedNames = ["name","vif","tcp_incoming_open_ports","udp_incoming_open_ports"]
			 , P.identStart = lower 
			 , P.identLetter = alphaNum <|> oneOf ".:"
			 }

-- Small parser combinators defined in Text.ParserCombinators.Parsec.Token 
natural       = P.natural lexer
whiteSpace    = P.whiteSpace lexer
reserved      = P.reserved lexer    
reservedOp    = P.reservedOp lexer
stringLiteral = P.stringLiteral lexer
identifier    = P.identifier lexer
squares       = P.squares lexer
commaSep      = P.commaSep lexer

{- ### PARSER ### -}

-- strip leading white space
stripped :: GenParser Char a b -> GenParser Char a b
stripped p = do
	whiteSpace
	x <- p
	return x

stmt :: GenParser Char a Stmt
stmt = do 
       xe <- xenExprWeCareAbout 
       choice [eof, many newline >> return ()] -- stmt separated \n+ (or EOF)
       return xe
       <|> portStmt
       <|> xenExprWeDontCareAbout
    <?> "Statement"

xenExprWeCareAbout :: GenParser Char a Stmt
xenExprWeCareAbout = choice [ domainName, vifAssignment ]
		     <?> "Xen expression we care about (i.e. name, or vif)"

-- name = "linuxbox"
domainName :: GenParser Char a Stmt
domainName = do { reserved "name"
		; reservedOp "="
		; name <- stringLiteral
		; return (HostName name)
		}
             <?> "Xen name expression"

-- vif = vifList
vifAssignment :: GenParser Char a Stmt
vifAssignment = do { reserved "vif"
		   ; reservedOp "="
		   ; vifnames <- vifList
		   ; let vifname = (filter isVifName vifnames) 
		     in if validVifName vifname then (return $ (\(Just x) -> x) (head vifname)) else error "vifname not supplied" 
		}
		<?> "Xen vifname expression"

-- [ ' vifName ' ]
vifList :: GenParser Char a [Maybe Stmt]
vifList = squares (commaSep (do { char '\''
				; many space 
				; vif <- vifName 
				; char '\''
				; many space 
				; return vif
				}))
	  <?> "vif list"

-- vifname=protos.0, bridge=xenbr0
vifName :: GenParser Char a (Maybe Stmt)
vifName = do { reserved "vifname"
	     ; reservedOp "="
	     ; vifname <- identifier
	     ; return (Just $ VIFName vifname)
	     } 
         <|> do { identifier -- mac and bridge
		; reservedOp "="
		; many (alphaNum <|> oneOf ":")
		; return Nothing
		} 
	 <?> "idenifier=stringLiteral with vif list"

-- #=> tcpOrUDPPorts
portStmt :: GenParser Char a Stmt
portStmt = do { reservedOp portOperator
	      ; tcpOrUDPPorts >>= return 
	      } 
        <?> "iptables port statement"

-- tcp_incoming_open_ports 22 80
-- | udp_incoming_open_ports 
tcpOrUDPPorts = do { reserved "tcp_incoming_open_ports"
		   ; ports <- many natural
		   ; return (TCP $ map fromIntegral ports)
		   }
             <|> do { reserved "udp_incoming_open_ports"
		    ; ports <- many natural
		    ; return (UDP $ map fromIntegral ports)
		    }
	     <?> "{tcp,udp}_incoming_open_ports int ..."

-- eat a line
xenExprWeDontCareAbout :: GenParser Char a Stmt
xenExprWeDontCareAbout = do { newline
			    ; return DontCare
			    }
			 <|> do { anyToken
				; xenExprWeDontCareAbout
				}
			 <?> "Xen expression we dont care about"

portOperator = "#=>"

isVifName (Just (VIFName _)) = True
isVifName _ = False

validVifName [(Just x)] = True
validVifName _ = False

toValidHost :: [Stmt] -> Maybe Host
toValidHost statements = isValidHost $ toValidHost' (Host "" "" [] []) statements

toValidHost' h [] = h
toValidHost' h ((VIFName x):ss) = toValidHost' (h {vifname = x}) ss
toValidHost' h ((HostName x):ss) = toValidHost' (h {hostName = x}) ss
toValidHost' h ((TCP x):ss) = toValidHost' (h {portsIncomingOpenTCP = x}) ss
toValidHost' h ((UDP x):ss) = toValidHost' (h {portsIncomingOpenUDP = x}) ss
toValidHost' h (x:xs) = toValidHost' h xs

isValidHost :: Host -> Maybe Host 
isValidHost h@(Host n v t u) = if length n > 0 && 
			           length v > 0 &&
			           (foldl (\c n -> n>0 && c) True t) &&
			           (foldl (\c n -> n>0 && c) True u) then Just h else Nothing