netcalc.hs

import qualified Data.Text as T
import Control.Monad
import Data.List (unfoldr, intercalate)
import Data.Bits (testBit)
import Data.Function ((&))

data Node = Sat -- all 1
          | Unsat -- all 0
          | Mixed Node Node -- mixed (left, right)
          deriving (Show)

type Tree = Node

type IP = [Bit]

-- prefix = take len IP
type Prefix = [Bit]

data Bit = B0 | B1
  deriving Show


splitOn :: String -> String -> [String]
splitOn sep text  = map T.unpack $ T.splitOn (T.pack sep) (T.pack text)

parseIP :: String -> IP
parseIP ip = foldl (\y x -> y ++ toIPSeg x) [] $ map read $ splitOn "." ip
  where toIPSeg :: Integer -> [Bit]
        toIPSeg n = reverse $ map toBit $ map (testBit n) [0..7]
        toBit False = B0
        toBit True = B1

parseCidr :: String -> Prefix
parseCidr cidr = let [ip, len] = splitOn "/" cidr
                 in take (read len) $ parseIP ip

flipTree :: Tree -> Tree
flipTree Sat = Unsat
flipTree Unsat = Sat
flipTree (Mixed a b) = Mixed (flipTree a) (flipTree b)


addCidr :: Prefix -> Tree -> Tree
addCidr [] _ = Sat
addCidr _ Sat = Sat
addCidr (B0:p) Unsat = Mixed (addCidr p Unsat) Unsat
addCidr (B1:p) Unsat = Mixed Unsat (addCidr p Unsat)
addCidr (B0:p) (Mixed l r) = Mixed (addCidr p l) r
addCidr (B1:p) (Mixed l r) = Mixed l (addCidr p l)

delCidr :: Prefix -> Tree -> Tree
delCidr p = flipTree . addCidr p . flipTree

treeToPrefixes :: Tree -> Prefix -> [Prefix]
treeToPrefixes Sat p = [p]
treeToPrefixes Unsat _ = []
treeToPrefixes (Mixed l r) p = treeToPrefixes l (p ++ [B0]) ++
                               treeToPrefixes r (p ++ [B1])

optimizeTree :: Tree -> Tree
optimizeTree Sat = Sat
optimizeTree Unsat = Unsat
optimizeTree (Mixed l r) = case Mixed (optimizeTree l) (optimizeTree r) of
                             (Mixed Sat Sat) -> Sat
                             (Mixed Unsat Unsat) -> Unsat
                             (Mixed l r) -> Mixed l r

showPrefix :: Prefix -> String
showPrefix p = let n = length p
                   ip = rightPad B0 32 p
               in showIP ip ++ "/" ++ show n

showIP :: IP -> String
showIP ip = intercalate "." $ map show $ map fromIPSeg $ chunk 8 ip
  where chunk n [] = []
        chunk n xs = (take n xs) : chunk n (drop n xs)
        fromIPSeg seg = foldl (\y x -> y * 2 + x) 0 $ map fromBit seg
        fromBit B0 = 0
        fromBit B1 = 1

testValue = let net = Sat & delCidr (parseCidr "192.168.0.0/16")
                          & delCidr (parseCidr "10.0.0.0/8")
                          & delCidr (parseCidr "172.16.0.0/12")
                          & addCidr (parseCidr "172.16.0.1/32")
                          & addCidr (parseIP "162.159.192.5")
            in map showPrefix $ treeToPrefixes (optimizeTree net) []

leftPad :: a -> Int -> [a] -> [a]
leftPad e n xs | n == length xs = xs
leftPad e n xs = leftPad e n (e:xs)

rightPad :: a -> Int -> [a] -> [a]
rightPad e n xs | n == length xs = xs
rightPad e n xs = rightPad e n (xs++[e])