{-# LANGUAGE TemplateHaskell #-}
module Facter where
import Control.Lens
import Data.Aeson
import Data.Char
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.List as List
import qualified Data.List.Split as List
import Data.Maybe (mapMaybe)
import qualified Data.Text as T
import Puppet.Language
import qualified System.Directory as Directory
import System.Environment
import System.Posix.Unistd (SystemID (..), getSystemID)
import System.Posix.User
import Text.Printf
import Prelude
type Facts = HM.HashMap T.Text PValue
data FactInfo = FactInfo
{ _factInfoNodename :: !NodeName,
_factInfoName :: !T.Text,
_factInfoVal :: !PValue
}
makeClassy ''FactInfo
instance ToJSON FactInfo where
toJSON (FactInfo n f v) = object [("certname", String n), ("name", String f), ("value", toJSON v)]
instance FromJSON FactInfo where
parseJSON (Object v) = FactInfo <$> v .: "certname" <*> v .: "name" <*> v .: "value"
parseJSON _ = fail "invalid fact info"
storageunits :: [(String, Int)]
storageunits = [("", 0), ("K", 1), ("M", 2), ("G", 3), ("T", 4)]
getPrefix :: Int -> String
getPrefix n
| null fltr = error $ "Could not get unit prefix for order " <> show n
| otherwise = fst $ head fltr
where
fltr = filter (\(_, x) -> x == n) storageunits
getOrder :: String -> Int
getOrder n
| null fltr = error $ "Could not get order for unit prefix " <> show n
| otherwise = snd $ head fltr
where
nu = map toUpper n
fltr = filter (\(x, _) -> x == nu) storageunits
normalizeUnit :: (Double, Int) -> Double -> (Double, Int)
normalizeUnit (unit, order) base
| unit > base = normalizeUnit (unit / base, order + 1) base
| otherwise = (unit, order)
storagedesc :: (String, String) -> String
storagedesc (ssize, unit) =
let size = read ssize :: Double
uprefix
| unit == "B" = ""
| otherwise = [head unit]
uorder = getOrder uprefix
(osize, oorder) = normalizeUnit (size, uorder) 1024
in printf "%.2f %sB" osize (getPrefix oorder)
factRAM :: IO [(String, String)]
factRAM = do
meminfo <- fmap (map words . lines) (readFile "/proc/meminfo")
let memtotal = ginfo "MemTotal:"
memfree = ginfo "MemFree:"
swapfree = ginfo "SwapFree:"
swaptotal = ginfo "SwapTotal:"
ginfo st = sdesc $ head $ filter ((== st) . head) meminfo
sdesc [_, size, unit] = storagedesc (size, unit)
sdesc _ = storagedesc ("1", "B")
return [("memorysize", memtotal), ("memoryfree", memfree), ("swapfree", swapfree), ("swapsize", swaptotal)]
factNET :: IO [(String, String)]
factNET = return [("ipaddress", "192.168.0.1")]
factOS :: IO [(String, String)]
factOS = do
islsb <- Directory.doesFileExist "/etc/lsb-release"
isdeb <- Directory.doesFileExist "/etc/debian_version"
case (islsb, isdeb) of
(True, _) -> factOSLSB
(_, True) -> factOSDebian
_ -> return []
factOSDebian :: IO [(String, String)]
factOSDebian = fmap (toV . head . lines) (readFile "/etc/debian_version")
where
toV v =
[ ("lsbdistid", "Debian"),
("operatingsystem", "Debian"),
("lsbdistrelease", v),
("operatingsystemrelease", v),
("lsbmajdistrelease", takeWhile (/= '.') v),
("osfamily", "Debian"),
("lsbdistcodename", codename v),
("lsbdistdescription", "Debian GNU/Linux " <> v <> " (" <> codename v <> ")")
]
codename v
| null v = "unknown"
| h '7' = "wheezy"
| h '6' = "squeeze"
| h '5' = "lenny"
| h '4' = "etch"
| v == "3.1" = "sarge"
| v == "3.0" = "woody"
| v == "2.2" = "potato"
| v == "2.1" = "slink"
| v == "2.0" = "hamm"
| otherwise = "unknown"
where
h x = head v == x
factOSLSB :: IO [(String, String)]
factOSLSB = do
lsb <- fmap (map (break (== '=')) . lines) (readFile "/etc/lsb-release")
let getval st
| null filterd = "?"
| otherwise = rvalue
where
filterd = filter (\(k, _) -> k == st) lsb
value = (tail . snd . head) filterd
rvalue
| head value == '"' = read value
| otherwise = value
lrelease = getval "DISTRIB_RELEASE"
distid = getval "DISTRIB_ID"
maj
| lrelease == "?" = "?"
| otherwise = takeWhile (/= '.') lrelease
osfam
| distid == "Ubuntu" = "Debian"
| otherwise = distid
return
[ ("lsbdistid", distid),
("operatingsystem", distid),
("lsbdistrelease", lrelease),
("operatingsystemrelease", lrelease),
("operatingsystemmajrelease", lrelease),
("lsbmajdistrelease", maj),
("lsbminordistrelease", ""),
("osfamily", osfam),
("lsbdistcodename", getval "DISTRIB_CODENAME"),
("lsbdistdescription", getval "DISTRIB_DESCRIPTION")
]
factMountPoints :: IO [(String, String)]
factMountPoints = do
mountinfo <- fmap (map words . lines) (readFile "/proc/mounts")
let ignorefs =
HS.fromList
[ "NFS",
"nfs",
"nfs4",
"nfsd",
"afs",
"binfmt_misc",
"proc",
"smbfs",
"autofs",
"iso9660",
"ncpfs",
"coda",
"devpts",
"ftpfs",
"devfs",
"mfs",
"shfs",
"sysfs",
"cifs",
"lustre_lite",
"tmpfs",
"usbfs",
"udf",
"fusectl",
"fuse.snapshotfs",
"rpc_pipefs",
"configfs",
"devtmpfs",
"debugfs",
"securityfs",
"ecryptfs",
"fuse.gvfs-fuse-daemon",
"rootfs"
]
goodlines = filter (\x -> not $ HS.member (x !! 2) ignorefs) mountinfo
goodfs = map (!! 1) goodlines
return [("mountpoints", unwords goodfs)]
fversion :: IO [(String, String)]
fversion = return [("facterversion", "0.1"), ("environment", "test")]
factUser :: IO [(String, String)]
factUser = do
username <- getEffectiveUserName
return [("id", username)]
factUName :: IO [(String, String)]
factUName = do
SystemID sn nn rl _ mc <- getSystemID
let vparts = List.splitOn "." (takeWhile (/= '-') rl)
return
[ ("kernel", sn), -- Linux
("kernelmajversion", List.intercalate "." (take 2 vparts)), -- 3.5
("kernelrelease", rl), -- 3.5.0-45-generic
("kernelversion", List.intercalate "." (take 3 vparts)), -- 3.5.0
("hardwareisa", mc), -- x86_64
("hardwaremodel", mc), -- x86_64
("hostname", nn)
]
fenv :: IO [(String, String)]
fenv = do
path <- getEnv "PATH"
return [("path", path)]
factProcessor :: IO [(String, String)]
factProcessor = do
cpuinfo <- readFile "/proc/cpuinfo"
let cpuinfos = zip ["processor" <> show (n :: Int) | n <- [0 ..]] modelnames
modelnames = mapMaybe (fmap (dropWhile (`elem` ("\t :" :: String))) . List.stripPrefix "model name") (lines cpuinfo)
return $ ("processorcount", show (length cpuinfos)) : cpuinfos