module Propellor.Property.Apt where
import Data.Maybe
import Data.List
import System.IO
import Control.Monad
import Control.Applicative
import Prelude
import Propellor.Base
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Service as Service
import Propellor.Property.File (Line)
sourcesList :: FilePath
sourcesList = "/etc/apt/sources.list"
type Url = String
type Section = String
type SourcesGenerator = DebianSuite -> [Line]
showSuite :: DebianSuite -> String
showSuite (Stable s) = s
showSuite Testing = "testing"
showSuite Unstable = "unstable"
showSuite Experimental = "experimental"
backportSuite :: DebianSuite -> Maybe String
backportSuite (Stable s) = Just (s ++ "-backports")
backportSuite _ = Nothing
stableUpdatesSuite :: DebianSuite -> Maybe String
stableUpdatesSuite (Stable s) = Just (s ++ "-updates")
stableUpdatesSuite _ = Nothing
debLine :: String -> Url -> [Section] -> Line
debLine suite mirror sections = unwords $
["deb", mirror, suite] ++ sections
srcLine :: Line -> Line
srcLine l = case words l of
("deb":rest) -> unwords $ "deb-src" : rest
_ -> ""
stdSections :: [Section]
stdSections = ["main", "contrib", "non-free"]
binandsrc :: String -> SourcesGenerator
binandsrc url suite = catMaybes
[ Just l
, Just $ srcLine l
, bl
, srcLine <$> bl
]
where
l = debLine (showSuite suite) url stdSections
bl = do
bs <- backportSuite suite
return $ debLine bs url stdSections
debCdn :: SourcesGenerator
debCdn = binandsrc "http://httpredir.debian.org/debian"
kernelOrg :: SourcesGenerator
kernelOrg = binandsrc "http://mirrors.kernel.org/debian"
securityUpdates :: SourcesGenerator
securityUpdates suite
| isStable suite || suite == Testing =
let l = "deb http://security.debian.org/ " ++ showSuite suite ++ "/updates " ++ unwords stdSections
in [l, srcLine l]
| otherwise = []
stdSourcesList :: Property NoInfo
stdSourcesList = withOS "standard sources.list" $ \o ->
case o of
(Just (System (Debian suite) _)) ->
ensureProperty $ stdSourcesListFor suite
_ -> error "os is not declared to be Debian"
stdSourcesListFor :: DebianSuite -> Property NoInfo
stdSourcesListFor suite = stdSourcesList' suite []
stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property NoInfo
stdSourcesList' suite more = setSourcesList
(concatMap (\gen -> gen suite) generators)
`describe` ("standard sources.list for " ++ show suite)
where
generators = [debCdn, kernelOrg, securityUpdates] ++ more
setSourcesList :: [Line] -> Property NoInfo
setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update
setSourcesListD :: [Line] -> FilePath -> Property NoInfo
setSourcesListD ls basename = f `File.hasContent` ls `onChange` update
where
f = "/etc/apt/sources.list.d/" ++ basename ++ ".list"
runApt :: [String] -> UncheckedProperty NoInfo
runApt ps = cmdPropertyEnv "apt-get" ps noninteractiveEnv
noninteractiveEnv :: [(String, String)]
noninteractiveEnv =
[ ("DEBIAN_FRONTEND", "noninteractive")
, ("APT_LISTCHANGES_FRONTEND", "none")
]
update :: Property NoInfo
update = runApt ["update"]
`assume` MadeChange
`describe` "apt update"
upgrade :: Property NoInfo
upgrade = runApt ["-y", "dist-upgrade"]
`assume` MadeChange
`describe` "apt dist-upgrade"
type Package = String
installed :: [Package] -> Property NoInfo
installed = installed' ["-y"]
installed' :: [String] -> [Package] -> Property NoInfo
installed' params ps = robustly $ check (isInstallable ps) go
`describe` (unwords $ "apt installed":ps)
where
go = runApt (params ++ ["install"] ++ ps)
installedBackport :: [Package] -> Property NoInfo
installedBackport ps = withOS desc $ \o -> case o of
Nothing -> error "cannot install backports; os not declared"
(Just (System (Debian suite) _)) -> case backportSuite suite of
Nothing -> notsupported o
Just bs -> ensureProperty $
runApt (["install", "-t", bs, "-y"] ++ ps)
`changesFile` dpkgStatus
_ -> notsupported o
where
desc = (unwords $ "apt installed backport":ps)
notsupported o = error $ "backports not supported on " ++ show o
installedMin :: [Package] -> Property NoInfo
installedMin = installed' ["--no-install-recommends", "-y"]
removed :: [Package] -> Property NoInfo
removed ps = check (or <$> isInstalled' ps) (runApt (["-y", "remove"] ++ ps))
`describe` (unwords $ "apt removed":ps)
buildDep :: [Package] -> Property NoInfo
buildDep ps = robustly $ go
`changesFile` dpkgStatus
`describe` (unwords $ "apt build-dep":ps)
where
go = runApt $ ["-y", "build-dep"] ++ ps
buildDepIn :: FilePath -> Property NoInfo
buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv
`changesFile` dpkgStatus
`requires` installedMin ["devscripts", "equivs"]
where
cmd = "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"
robustly :: (Combines (Property i) (Property NoInfo)) => Property i -> Property i
robustly p = adjustPropertySatisfy p $ \satisfy -> do
r <- satisfy
if r == FailedChange
then ensureProperty $ ignoreInfo $ p `requires` update
else return r
isInstallable :: [Package] -> IO Bool
isInstallable ps = do
l <- isInstalled' ps
return $ elem False l && not (null l)
isInstalled :: Package -> IO Bool
isInstalled p = (== [True]) <$> isInstalled' [p]
isInstalled' :: [Package] -> IO [Bool]
isInstalled' ps = (mapMaybe parse . lines) <$> policy
where
parse l
| "Installed: (none)" `isInfixOf` l = Just False
| "Installed: " `isInfixOf` l = Just True
| otherwise = Nothing
policy = do
environ <- addEntry "LANG" "C" <$> getEnvironment
readProcessEnv "apt-cache" ("policy":ps) (Just environ)
autoRemove :: Property NoInfo
autoRemove = runApt ["-y", "autoremove"]
`changesFile` dpkgStatus
`describe` "apt autoremove"
unattendedUpgrades :: RevertableProperty NoInfo
unattendedUpgrades = enable <!> disable
where
enable = setup True
`before` Service.running "cron"
`before` configure
disable = setup False
setup enabled = (if enabled then installed else removed) ["unattended-upgrades"]
`onChange` reConfigure "unattended-upgrades"
[("unattended-upgrades/enable_auto_updates" , "boolean", v)]
`describe` ("unattended upgrades " ++ v)
where
v
| enabled = "true"
| otherwise = "false"
configure = withOS "unattended upgrades configured" $ \o ->
case o of
(Just (System (Debian suite) _))
| not (isStable suite) -> ensureProperty $
"/etc/apt/apt.conf.d/50unattended-upgrades"
`File.containsLine`
("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };")
_ -> noChange
type DebconfTemplate = String
type DebconfTemplateType = String
type DebconfTemplateValue = String
reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property NoInfo
reConfigure package vals = reconfigure `requires` setselections
`describe` ("reconfigure " ++ package)
where
setselections = property "preseed" $
if null vals
then noChange
else makeChange $
withHandle StdinHandle createProcessSuccess
(proc "debconf-set-selections" []) $ \h -> do
forM_ vals $ \(tmpl, tmpltype, value) ->
hPutStrLn h $ unwords [package, tmpl, tmpltype, value]
hClose h
reconfigure = cmdPropertyEnv "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv
`assume` MadeChange
serviceInstalledRunning :: Package -> Property NoInfo
serviceInstalledRunning svc = Service.running svc `requires` installed [svc]
data AptKey = AptKey
{ keyname :: String
, pubkey :: String
}
trustsKey :: AptKey -> RevertableProperty NoInfo
trustsKey k = trustsKey' k <!> untrustKey k
trustsKey' :: AptKey -> Property NoInfo
trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do
withHandle StdinHandle createProcessSuccess
(proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do
hPutStr h (pubkey k)
hClose h
nukeFile $ f ++ "~"
where
desc = "apt trusts key " ++ keyname k
f = aptKeyFile k
untrustKey :: AptKey -> Property NoInfo
untrustKey = File.notPresent . aptKeyFile
aptKeyFile :: AptKey -> FilePath
aptKeyFile k = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"
cacheCleaned :: Property NoInfo
cacheCleaned = cmdProperty "apt-get" ["clean"]
`assume` NoChange
`describe` "apt cache cleaned"
hasForeignArch :: String -> Property NoInfo
hasForeignArch arch = check notAdded (add `before` update)
`describe` ("dpkg has foreign architecture " ++ arch)
where
notAdded = (not . elem arch . lines) <$> readProcess "dpkg" ["--print-foreign-architectures"]
add = cmdProperty "dpkg" ["--add-architecture", arch]
`assume` MadeChange
dpkgStatus :: FilePath
dpkgStatus = "/var/lib/dpkg/status"