{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Propellor.Property.Apt where
import Data.Maybe
import Data.List
import Data.Typeable
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)
import Propellor.Types.Info
data HostMirror = HostMirror Url
deriving (Eq, Show, Typeable)
data HostAptProxy = HostAptProxy Url
deriving (Eq, Show, Typeable)
mirror :: Url -> Property (HasInfo + UnixLike)
mirror u = pureInfoProperty (u ++ " apt mirror selected")
(InfoVal (HostMirror u))
getMirror :: Propellor Url
getMirror = do
mirrorInfo <- getMirrorInfo
osInfo <- getOS
return $ case (osInfo, mirrorInfo) of
(_, Just (HostMirror u)) -> u
(Just (System (Debian _ _) _), _) ->
"http://deb.debian.org/debian"
(Just (System (Buntish _) _), _) ->
"mirror://mirrors.ubuntu.com/"
(Just (System dist _), _) ->
error ("no Apt mirror defined for " ++ show dist)
_ -> error "no Apt mirror defined for this host or OS"
where
getMirrorInfo :: Propellor (Maybe HostMirror)
getMirrorInfo = fromInfoVal <$> askInfo
withMirror :: Desc -> (Url -> Property DebianLike) -> Property DebianLike
withMirror desc mkp = property' desc $ \w -> do
u <- getMirror
ensureProperty w (mkp u)
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 url sections = unwords $
["deb", url, 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
, sul
, srcLine <$> sul
, bl
, srcLine <$> bl
]
where
l = debLine (showSuite suite) url stdSections
bl = do
bs <- backportSuite suite
return $ debLine bs url stdSections
sul = do
sus <- stableUpdatesSuite suite
return $ debLine sus url stdSections
stdArchiveLines :: Propellor SourcesGenerator
stdArchiveLines = return . binandsrc =<< getMirror
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 Debian
stdSourcesList = withOS "standard sources.list" $ \w o -> case o of
(Just (System (Debian _ suite) _)) ->
ensureProperty w $ stdSourcesListFor suite
_ -> unsupportedOS'
stdSourcesListFor :: DebianSuite -> Property Debian
stdSourcesListFor suite = stdSourcesList' suite []
stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property Debian
stdSourcesList' suite more = tightenTargets $
withMirror desc $ \u -> setSourcesList
(concatMap (\gen -> gen suite) (generators u))
where
generators u = [binandsrc u, securityUpdates] ++ more
desc = ("standard sources.list for " ++ show suite)
type PinPriority = Int
suiteAvailablePinned
:: DebianSuite
-> PinPriority
-> RevertableProperty Debian Debian
suiteAvailablePinned s pin = available <!> unavailable
where
available :: Property Debian
available = tightenTargets $ combineProperties (desc True) $ props
& File.hasContent prefFile (suitePinBlock "*" s pin)
& setSourcesFile
unavailable :: Property Debian
unavailable = tightenTargets $ combineProperties (desc False) $ props
& File.notPresent sourcesFile
`onChange` update
& File.notPresent prefFile
setSourcesFile :: Property Debian
setSourcesFile = tightenTargets $ withMirror (desc True) $ \u ->
withOS (desc True) $ \w o -> case o of
(Just (System (Debian _ hostSuite) _))
| s /= hostSuite -> ensureProperty w $
File.hasContent sourcesFile (sources u)
`onChange` update
_ -> noChange
sources u = dropBackports $ concatMap (\gen -> gen s) (generators u)
where
dropBackports
| "-backports" `isSuffixOf` (showSuite s) = id
| otherwise = filter (not . isInfixOf "-backports")
generators u = [binandsrc u, securityUpdates]
prefFile = "/etc/apt/preferences.d/20" ++ showSuite s ++ ".pref"
sourcesFile = "/etc/apt/sources.list.d/" ++ showSuite s ++ ".list"
desc True = "Debian " ++ showSuite s ++ " pinned, priority " ++ show pin
desc False = "Debian " ++ showSuite s ++ " not pinned"
setSourcesList :: [Line] -> Property DebianLike
setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update
setSourcesListD :: [Line] -> FilePath -> Property DebianLike
setSourcesListD ls basename = f `File.hasContent` ls `onChange` update
where
f = "/etc/apt/sources.list.d/" ++ basename ++ ".list"
runApt :: [String] -> UncheckedProperty DebianLike
runApt ps = tightenTargets $ cmdPropertyEnv "apt-get" ps noninteractiveEnv
noninteractiveEnv :: [(String, String)]
noninteractiveEnv =
[ ("DEBIAN_FRONTEND", "noninteractive")
, ("APT_LISTCHANGES_FRONTEND", "none")
]
update :: Property DebianLike
update = combineProperties ("apt update") $ props
& pendingConfigured
& runApt ["update"]
`assume` MadeChange
upgrade :: Property DebianLike
upgrade = upgrade' "dist-upgrade"
upgrade' :: String -> Property DebianLike
upgrade' p = combineProperties ("apt " ++ p) $ props
& pendingConfigured
& runApt ["-y", p]
`assume` MadeChange
safeUpgrade :: Property DebianLike
safeUpgrade = upgrade' "upgrade"
pendingConfigured :: Property DebianLike
pendingConfigured = tightenTargets $
cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv
`assume` MadeChange
`describe` "dpkg configured pending"
type Package = String
installed :: [Package] -> Property DebianLike
installed = installed' ["-y"]
installedMin :: [Package] -> Property DebianLike
installedMin = installed' ["--no-install-recommends", "-y"]
installed' :: [String] -> [Package] -> Property DebianLike
installed' params ps = robustly $ check (not <$> isInstalled' ps) go
`describe` unwords ("apt installed":ps)
where
go = runApt (params ++ ["install"] ++ ps)
backportInstalled :: [Package] -> Property Debian
backportInstalled = backportInstalled' ["-y"]
backportInstalledMin :: [Package] -> Property Debian
backportInstalledMin = backportInstalled' ["--no-install-recommends", "-y"]
backportInstalled' :: [String] -> [Package] -> Property Debian
backportInstalled' params ps = withOS desc $ \w o -> case o of
(Just (System (Debian _ suite) _)) -> case backportSuite suite of
Nothing -> unsupportedOS'
Just bs -> ensureProperty w $
runApt (("install":params) ++ ((++ '/':bs) <$> ps))
`changesFile` dpkgStatus
_ -> unsupportedOS'
where
desc = unwords ("apt installed backport":ps)
removed :: [Package] -> Property DebianLike
removed ps = check (any (== IsInstalled) <$> getInstallStatus ps)
(runApt (["-y", "remove"] ++ ps))
`describe` unwords ("apt removed":ps)
buildDep :: [Package] -> Property DebianLike
buildDep ps = robustly $ go
`changesFile` dpkgStatus
`describe` unwords ("apt build-dep":ps)
where
go = runApt $ ["-y", "build-dep"] ++ ps
buildDepIn :: FilePath -> Property DebianLike
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"
type AptPackagePref = String
pinnedTo
:: [AptPackagePref]
-> [(DebianSuite, PinPriority)]
-> RevertableProperty Debian Debian
pinnedTo ps pins = mconcat (map (\p -> pinnedTo' p pins) ps)
`describe` unwords (("pinned to " ++ showSuites):ps)
where
showSuites = intercalate "," $ showSuite . fst <$> pins
pinnedTo'
:: AptPackagePref
-> [(DebianSuite, PinPriority)]
-> RevertableProperty Debian Debian
pinnedTo' p pins =
(tightenTargets $ prefFile `File.hasContent` prefs)
<!> (tightenTargets $ File.notPresent prefFile)
where
prefs = foldr step [] pins
step (suite, pin) ls = ls ++ suitePinBlock p suite pin ++ [""]
prefFile = "/etc/apt/preferences.d/10propellor_"
++ File.configFileName p <.> "pref"
robustly :: Property DebianLike -> Property DebianLike
robustly p = p `fallback` (update `before` p)
isInstalled :: Package -> IO Bool
isInstalled p = isInstalled' [p]
isInstalled' :: [Package] -> IO Bool
isInstalled' ps = do
is <- getInstallStatus ps
return $ all (== IsInstalled) is && length is == length ps
data InstallStatus = IsInstalled | NotInstalled
deriving (Show, Eq)
getInstallStatus :: [Package] -> IO [InstallStatus]
getInstallStatus ps = mapMaybe parse . lines <$> policy
where
parse l
| "Installed: (none)" `isInfixOf` l = Just NotInstalled
| "Installed: " `isInfixOf` l = Just IsInstalled
| otherwise = Nothing
policy = do
environ <- addEntry "LANG" "C" <$> getEnvironment
readProcessEnv "apt-cache" ("policy":ps) (Just environ)
autoRemove :: Property DebianLike
autoRemove = runApt ["-y", "autoremove"]
`changesFile` dpkgStatus
`describe` "apt autoremove"
unattendedUpgrades :: RevertableProperty DebianLike DebianLike
unattendedUpgrades = enable <!> disable
where
enable = setup True
`before` Service.running "cron"
`before` configure
`before` File.notPresent "/etc/apt/apt.conf.d/50unattended-upgrades.ucf-dist"
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 :: Property DebianLike
configure = propertyList "unattended upgrades configured" $ props
& enableupgrading
& unattendedconfig `File.containsLine` "Unattended-Upgrade::Mail \"root\";"
where
enableupgrading :: Property DebianLike
enableupgrading = withOS "unattended upgrades configured" $ \w o ->
case o of
(Just (System (Debian _ suite) _))
| not (isStable suite) -> ensureProperty w $
unattendedconfig
`File.containsLine`
("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };")
_ -> noChange
unattendedconfig = "/etc/apt/apt.conf.d/50unattended-upgrades"
periodicUpdates :: Property DebianLike
periodicUpdates = tightenTargets $ "/etc/apt/apt.conf.d/02periodic" `File.hasContent`
[ "APT::Periodic::Enable \"1\";"
, "APT::Periodic::Update-Package-Lists \"1\";"
, "APT::Periodic::Download-Upgradeable-Packages \"1\";"
, "APT::Periodic::Verbose \"1\";"
]
type DebconfTemplate = String
type DebconfTemplateType = String
type DebconfTemplateValue = String
reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property DebianLike
reConfigure package vals = tightenTargets $
reconfigure
`requires` setselections
`describe` ("reconfigure " ++ package)
where
setselections :: Property DebianLike
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 DebianLike
serviceInstalledRunning svc = Service.running svc `requires` installed [svc]
data AptKey = AptKey
{ keyname :: String
, pubkey :: String
}
trustsKey :: AptKey -> RevertableProperty DebianLike DebianLike
trustsKey k = trustsKey' k <!> untrustKey k
trustsKey' :: AptKey -> Property DebianLike
trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do
withHandle StdinHandle createProcessSuccess
(proc "apt-key" ["--keyring", f, "add", "-"]) $ \h -> do
hPutStr h (pubkey k)
hClose h
nukeFile $ f ++ "~"
where
desc = "apt trusts key " ++ keyname k
f = aptKeyFile k
untrustKey :: AptKey -> Property DebianLike
untrustKey = tightenTargets . File.notPresent . aptKeyFile
aptKeyFile :: AptKey -> FilePath
aptKeyFile k = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"
cacheCleaned :: Property DebianLike
cacheCleaned = tightenTargets $ cmdProperty "apt-get" ["clean"]
`assume` NoChange
`describe` "apt cache cleaned"
hasForeignArch :: String -> Property DebianLike
hasForeignArch arch = check notAdded (add `before` update)
`describe` ("dpkg has foreign architecture " ++ arch)
where
notAdded = (notElem arch . lines) <$> readProcess "dpkg" ["--print-foreign-architectures"]
add = cmdProperty "dpkg" ["--add-architecture", arch]
`assume` MadeChange
noPDiffs :: Property DebianLike
noPDiffs = tightenTargets $ "/etc/apt/apt.conf.d/20pdiffs" `File.hasContent`
[ "Acquire::PDiffs \"false\";" ]
suitePin :: DebianSuite -> String
suitePin s = prefix s ++ showSuite s
where
prefix (Stable _) = "n="
prefix _ = "a="
suitePinBlock :: AptPackagePref -> DebianSuite -> PinPriority -> [Line]
suitePinBlock p suite pin =
[ "Explanation: This file added by propellor"
, "Package: " ++ p
, "Pin: release " ++ suitePin suite
, "Pin-Priority: " ++ val pin
]
dpkgStatus :: FilePath
dpkgStatus = "/var/lib/dpkg/status"
proxy :: Url -> Property (HasInfo + DebianLike)
proxy u = setInfoProperty (proxy' u) (proxyInfo u)
where
proxyInfo = toInfo . InfoVal . HostAptProxy
proxy' :: Url -> Property DebianLike
proxy' u = tightenTargets $
"/etc/apt/apt.conf.d/20proxy" `File.hasContent`
[ "Acquire::HTTP::Proxy \"" ++ u ++ "\";" ]
`describe` desc
where
desc = (u ++ " apt proxy selected")
useLocalCacher :: Property (HasInfo + DebianLike)
useLocalCacher = proxy "http://localhost:3142"
`requires` serviceInstalledRunning "apt-cacher-ng"
`describe` "apt uses local apt cacher"