{-# Language FlexibleContexts, FlexibleInstances #-}
module Network.RTbl.Parser ( parseRTbl_ipv6, parseRTbl_ipv4, rTblToIsabelle, RTbl, Routing_rule)
where

import           Text.Parsec
import           Data.Functor ((<$>), ($>))
import           Control.Applicative ((<*), (*>), (<$>), (<*>))
import qualified Network.IPTables.Generated as Isabelle
import           Network.IPTables.Ruleset
import           Network.IPTables.ParserHelper
import           Network.IPTables.IsabelleToString (Word32, Word128)
import qualified Network.IPTables.Generated as Isabelle
import           Network.IPTables.Generated (metric_update, routing_action_next_hop_update, routing_action_oiface_update, empty_rr_hlp)
import           Data.Maybe (catMaybes, Maybe (Just, Nothing), fromMaybe)
import           Control.Monad (void,liftM)

type Routing_rule a = Isabelle.Routing_rule_ext a ()
data RTbl a = RTbl [Routing_rule a]

parseRTbl ippars = flip runParser () $ RTbl . (\t -> if Isabelle.sanity_ip_route t then t else error "Routing table sanity check failed.") . Isabelle.sort_rtbl <$> many (parseRTblEntry ippars)

parseRTbl_ipv4 = parseRTbl ipv4dotdecimal
parseRTbl_ipv6 = parseRTbl ipv6colonsep

parseRTblEntry :: Isabelle.Len a => Parsec String s (Isabelle.Word a) -> Parsec String s (Routing_rule a)
parseRTblEntry ippars = do
    pfx <- ipaddrOrCidr ippars <|> defaultParser
    skipWS
    opts <- parseOpts ippars
    many1 (char '\n')
    return $ opts . empty_rr_hlp $ pfx
    where
        defaultParser = Prelude.const (Isabelle.default_prefix) <$> lit "default"

parseOpt :: Isabelle.Len a => Parsec String s (Isabelle.Word a) -> Parsec String s (Routing_rule a -> Routing_rule a)
parseOpt ippars = choice (map try [parseOIF, parseNH ippars, parseMetric, ignoreScope, ignoreProto, ignoreSrc ippars])

parseOpts :: Isabelle.Len a => Parsec String s (Isabelle.Word a) -> Parsec String s (Routing_rule a -> Routing_rule a)
parseOpts ippars = flip (foldl (flip id)) <$> many (parseOpt ippars <* skipWS)

litornat l =  (void $ nat) <|> void (choice (map lit l))

ignoreScope = do
    lit "scope"
    skipWS
    litornat ["host", "link", "global"]
    return id

ignoreProto = do
    lit "proto"
    skipWS
    litornat ["kernel", "boot", "static", "dhcp"]
    return id

ignoreSrc ippars = do
    lit "src"
    skipWS
    ippars
    return id

parseOIF :: Isabelle.Len a => Parsec String s (Routing_rule a -> Routing_rule a)
parseOIF = do
    lit "dev"
    skipWS
    routing_action_oiface_update <$> siface

parseNH ippars = do
    lit "via"
    skipWS
    routing_action_next_hop_update <$> ippars

parseMetric :: Isabelle.Len a => Parsec String s (Routing_rule a -> Routing_rule a)
parseMetric = do
    lit "metric"
    skipWS
    metric_update . const . Isabelle.nat_of_integer <$> nat

rTblToIsabelle (RTbl t) = t

instance Show (RTbl Word32) where
    show (RTbl t) = unlines . map show $ t
instance Show (RTbl Word128) where
    show (RTbl t) = unlines . map show $ t

{- now, for some code duplication... -}
skipWS = void $ many $ oneOf " \t"
lit str = (string str)
ipaddrOrCidr ippars = try (Isabelle.PrefixMatch <$> (ippars <* char '/') <*> (Isabelle.nat_of_integer <$> nat))
             <|> try (flip Isabelle.PrefixMatch (Isabelle.nat_of_integer 32) <$> ippars)
siface = many1 (oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ ['+', '*', '.', '-'])
