language-puppet-1.1.1: Puppet/OptionalTests.hs

{-# LANGUAGE LambdaCase #-}
-- | The module works in IO and throws a 'PrettyError' exception at each failure.
-- These exceptions can be caught (see the exceptions package).
module Puppet.OptionalTests (testCatalog) where

import           Control.Applicative
import           Control.Lens
import           Control.Monad                    (unless)
import           Control.Monad.Catch
import           Control.Monad.Trans              (liftIO)
import           Control.Monad.Trans.Except
import           Data.Foldable                    (asum, elem, toList,
                                                   traverse_)
import qualified Data.HashSet                     as HS
import           Data.Maybe                       (mapMaybe)
import           Data.Monoid                      ((<>))
import qualified Data.Text                        as T
import           Prelude                          hiding (all, elem)

import           Puppet.Interpreter.PrettyPrinter ()
import           Puppet.Interpreter.Types
import           Puppet.Lens                      (_PString)
import           Puppet.PP
import           Puppet.Preferences
import           System.Posix.Files


-- | Entry point for all optional tests
testCatalog :: Preferences IO -> FinalCatalog -> IO ()
testCatalog prefs c = testFileSources (prefs^.puppetPaths.baseDir) c >> testUsersGroups (prefs^.knownusers) (prefs^.knowngroups) c

-- | Tests that all users and groups are defined
testUsersGroups :: [T.Text] -> [T.Text] -> FinalCatalog -> IO ()
testUsersGroups kusers kgroups c = do
    let users = HS.fromList $ "" : map (view (rid . iname)) (getResourceFrom "user") ++ kusers
        groups = HS.fromList $ "" : map (view (rid . iname)) (getResourceFrom "group") ++ kgroups
        checkResource lu lg = mapM_ (checkResource' lu lg)
        checkResource' lu lg res = do
            let msg att name = align (vsep [ "Resource" <+> ttext (res^.rid.itype)
                                             <+> ttext (res^.rid.iname) <+> showPos (res^.rpos._1)
                                           , "reference the unknown" <+> string att <+> squotes (ttext name)])
                               <> line
            case lu of
                Just lu' -> do
                    let u = res ^. rattributes . lu' . _PString
                    unless (HS.member u users) $ throwM $ PrettyError (msg "user" u)
                Nothing -> pure ()
            case lg of
                Just lg' -> do
                    let g = res ^. rattributes . lg' . _PString
                    unless (HS.member g groups) $ throwM $ PrettyError (msg "group" g)
                Nothing -> pure ()
    do
        checkResource (Just $ ix "owner") (Just $ ix "group") (getResourceFrom "file")
        checkResource (Just $ ix "user")  (Just $ ix "group") (getResourceFrom "exec")
        checkResource (Just $ ix "user")  Nothing             (getResourceFrom "cron")
        checkResource (Just $ ix "user")  Nothing             (getResourceFrom "ssh_authorized_key")
        checkResource (Just $ ix "user")  Nothing             (getResourceFrom "ssh_authorized_key_secure")
        checkResource Nothing             (Just $ ix "gid")   (getResourceFrom "users")
    where
      getResourceFrom t = c ^.. traverse . filtered (\r -> r ^. rid . itype == t && r ^. rattributes . at "ensure" /= Just "absent")

-- | Test source for every file resources in the catalog.
testFileSources :: FilePath -> FinalCatalog -> IO ()
testFileSources basedir c = do
    let getFiles = filter presentFile . toList
        presentFile r = r ^. rid . itype == "file"
                        && (r ^. rattributes . at "ensure") `elem` [Nothing, Just "present"]
                        && r ^. rattributes . at "source" /= Just PUndef
        getSource = mapMaybe (\r -> (,) <$> pure r <*> r ^. rattributes . at "source")
    checkAllSources basedir $ (getSource . getFiles) c

-- | Check source for all file resources and append failures along.
checkAllSources :: FilePath -> [(Resource, PValue)] -> IO ()
checkAllSources fp fs = go fs []
  where
    go ((res, filesource):xs) es =
      runExceptT (checkFile fp filesource) >>= \case
        Right () -> go xs es
        Left err -> go xs ((PrettyError $ "Could not find " <+> pretty filesource <> semi
                           <+> align (vsep [getError err, showPos (res^.rpos^._1)])):es)
    go [] [] = pure ()
    go [] es = traverse_ throwM es

testFile :: FilePath -> ExceptT PrettyError IO ()
testFile fp = do
    p <-  liftIO (fileExist fp)
    unless p (throwE $ PrettyError $ "searched in" <+> squotes (string fp))

-- | Only test the `puppet:///` protocol (files managed by the puppet server)
--   we don't test absolute path (puppet client files)
checkFile :: FilePath -> PValue -> ExceptT PrettyError IO ()
checkFile basedir (PString f) = case T.stripPrefix "puppet:///" f of
    Just stringdir -> case T.splitOn "/" stringdir of
        ("modules":modname:rest) -> testFile (basedir <> "/modules/" <> T.unpack modname <> "/files/" <> T.unpack (T.intercalate "/" rest))
        ("files":rest)           -> testFile (basedir <> "/files/" <> T.unpack (T.intercalate "/" rest))
        ("private":_)            -> return ()
        _                        -> throwE (PrettyError $ "Invalid file source:" <+> ttext f)
    Nothing        -> return ()
-- source is always an array of possible paths. We only fails if none of them check.
checkFile basedir (PArray xs) = asum [checkFile basedir x | x <- toList xs]
checkFile _ x = throwE (PrettyError $ "Source was not a string, but" <+> pretty x)