{-# LANGUAGE LambdaCase #-}
module Facter where
import Prelude
import Control.Arrow
import Control.Lens
import Control.Monad.Trans.Except
import Data.Char
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import Data.List (intercalate, stripPrefix)
import Data.List.Split (splitOn)
import Data.Maybe (mapMaybe)
import qualified Data.Text as T
import Puppet.Interpreter.Types
import System.Directory (doesFileExist)
import System.Environment
import System.Posix.Unistd (SystemID (..), getSystemID)
import System.Posix.User
import Text.Printf
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 <- doesFileExist "/etc/lsb-release"
isdeb <- 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 = splitOn "." (takeWhile (/='-') rl)
return [ ("kernel" , sn) -- Linux
, ("kernelmajversion" , intercalate "." (take 2 vparts)) -- 3.5
, ("kernelrelease" , rl) -- 3.5.0-45-generic
, ("kernelversion" , 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))) . stripPrefix "model name") (lines cpuinfo)
return $ ("processorcount", show (length cpuinfos)) : cpuinfos
puppetDBFacts :: NodeName -> PuppetDBAPI IO -> IO (Container PValue)
puppetDBFacts node pdbapi =
runExceptT (getFacts pdbapi (QEqual FCertname node)) >>= \case
Right facts@(_:_) -> return (HM.fromList (map (\f -> (f ^. factInfoName, f ^. factInfoVal)) facts))
_ -> do
rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, fversion, factMountPoints, factOS, factUser, factUName, fenv, factProcessor])
let ofacts = genFacts $ map (T.pack *** T.pack) rawFacts
(hostname, ddomainname) = T.break (== '.') node
domainname = if T.null ddomainname
then ""
else T.tail ddomainname
nfacts = genFacts [ ("fqdn", node)
, ("hostname", hostname)
, ("domain", domainname)
, ("rootrsa", "xxx")
, ("operatingsystem", "Ubuntu")
, ("puppetversion", "language-puppet")
, ("virtual", "xenu")
, ("clientcert", node)
, ("is_virtual", "true")
, ("concat_basedir", "/var/lib/puppet/concat")
]
allfacts = nfacts `HM.union` ofacts
genFacts = HM.fromList
return (allfacts & traverse %~ PString)