module System.Info.MAC.Fetch where
import Data.MAC
import Control.Monad
import Control.Applicative ((<$>))
import Data.List
import Data.Maybe
import System.Process
import System.Info
import System.IO
import Text.ParserCombinators.Parsec
fetchNICs :: IO [(String, MAC)]
fetchNICs = parser <$> i_config
i_config :: IO String
i_config = do
(_, o, _, h) <- runInteractiveCommand cmd
outputs <- hGetContents o
seq (length outputs) (return ())
waitForProcess h
return outputs
where
cmd | os == "mingw32" = "ipconfig /all"
| otherwise = "LANG=C ifconfig"
parser | os == "mingw32" = parse' "ipconfig" ipconfig
| otherwise = parse' "ifconfig" ifconfig . ("\n\n" ++)
ifconfig :: Parser [(String, MAC)]
ifconfig = parseNICs parseNIC_ifconfig
ipconfig :: Parser [(String, MAC)]
ipconfig = parseNICs parseNIC_ipconfig
parseNIC_ifconfig :: Parser (Maybe (String, MAC))
parseNIC_ifconfig = do
name <- many1 alphaNum
skipManyTill (satisfy (/= '\n')) markers
char ' '
((name,) <$>) <$> parseMAC ':'
where
markers = choice $ map (try . string) [ "ether", "HWaddr" ]
parseNIC_ipconfig :: Parser (Maybe (String, MAC))
parseNIC_ipconfig = do
name <- do string "Ethernet adapter "
manyTill (satisfy (/= '\n')) (char ':')
(skipManyAnyTill . choice) [ try (nl >> nl) >> unexpected "\\r\\n\\r\\n"
, (try . string) "Physical Address" ]
manyTill (satisfy (/= '\n')) (char ':')
char ' '
((name,) <$>) <$> parseMAC '-'
parseNICs :: Parser (Maybe (String, MAC)) -> Parser [(String, MAC)]
parseNICs p = catMaybes <$> parseNICs'
where
parseNICs' = (skipManyAnyTill . choice)
[ eof >> return []
, do try (nl >> nl)
nic <- p
(nic:) <$> parseNICs' ]
parseMAC sepChar = maybeMAC . intercalate ":" <$> sepHex (char sepChar)
parse' :: String -> Parser [t] -> String -> [t]
parse' source parser = either (const []) id . parse parser source
maybeMAC :: String -> Maybe MAC
maybeMAC s =
case reads s of
[(mac, _)] -> Just mac
_ -> Nothing
sepHex = sepBy (sequence [hexDigit, hexDigit])
manyAnyTill :: Parser Char -> Parser String
manyAnyTill = manyTill anyChar
skipManyTill :: Parser a -> Parser b -> Parser b
skipManyTill p end = choice [try end, p >> skipManyTill p end]
skipManyAnyTill :: Parser a -> Parser a
skipManyAnyTill = skipManyTill anyChar
nl = many (char '\r') >> char '\n'