propellor/Propellor/Property/Apt.hs

210 lines
6.5 KiB
Haskell
Raw Normal View History

2014-03-31 03:37:54 +00:00
module Propellor.Property.Apt where
import Data.Maybe
import Control.Applicative
import Data.List
2014-03-30 05:44:36 +00:00
import System.IO
import Control.Monad
2014-03-31 03:55:59 +00:00
import Propellor
2014-03-31 03:37:54 +00:00
import qualified Propellor.Property.File as File
2014-04-08 23:31:03 +00:00
import qualified Propellor.Property.Service as Service
2014-03-31 03:37:54 +00:00
import Propellor.Property.File (Line)
sourcesList :: FilePath
sourcesList = "/etc/apt/sources.list"
type Url = String
type Section = String
2014-04-01 20:58:11 +00:00
showSuite :: DebianSuite -> String
showSuite Stable = "stable"
showSuite Testing = "testing"
showSuite Unstable = "unstable"
showSuite Experimental = "experimental"
2014-04-01 20:58:11 +00:00
showSuite (DebianRelease r) = r
2014-04-13 21:50:44 +00:00
backportSuite :: String
backportSuite = showSuite stableRelease ++ "-backports"
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
_ -> ""
2014-03-30 04:08:02 +00:00
stdSections :: [Section]
stdSections = ["main", "contrib", "non-free"]
2014-04-02 04:05:10 +00:00
binandsrc :: String -> DebianSuite -> [Line]
binandsrc url suite
2014-04-13 21:50:44 +00:00
| isStable suite = [l, srcLine l, bl, srcLine bl]
| otherwise = [l, srcLine l]
where
l = debLine (showSuite suite) url stdSections
2014-04-13 21:50:44 +00:00
bl = debLine backportSuite url stdSections
2014-04-02 04:05:10 +00:00
debCdn :: DebianSuite -> [Line]
debCdn = binandsrc "http://cdn.debian.net/debian"
kernelOrg :: DebianSuite -> [Line]
kernelOrg = binandsrc "http://mirrors.kernel.org/debian"
2014-04-10 04:29:47 +00:00
-- | Only available for Stable and Testing
securityUpdates :: DebianSuite -> [Line]
securityUpdates suite
2014-04-13 21:50:44 +00:00
| isStable suite || suite == Testing =
2014-04-10 04:29:47 +00:00
let l = "deb http://security.debian.org/ " ++ showSuite suite ++ "/updates " ++ unwords stdSections
in [l, srcLine l]
| otherwise = []
2014-04-03 06:27:17 +00:00
-- | Makes sources.list have a standard content using the mirror CDN,
-- with a particular DebianSuite.
--
-- Since the CDN is sometimes unreliable, also adds backup lines using
-- kernel.org.
2014-04-01 20:58:11 +00:00
stdSourcesList :: DebianSuite -> Property
2014-04-10 04:29:47 +00:00
stdSourcesList suite = setSourcesList
(concatMap (\gen -> gen suite) [debCdn, kernelOrg, securityUpdates])
2014-03-30 20:04:50 +00:00
`describe` ("standard sources.list for " ++ show suite)
setSourcesList :: [Line] -> Property
2014-03-30 17:12:33 +00:00
setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update
2014-03-31 03:55:59 +00:00
runApt :: [String] -> Property
2014-04-03 00:26:38 +00:00
runApt ps = cmdProperty' "apt-get" ps noninteractiveEnv
noninteractiveEnv :: [(String, String)]
noninteractiveEnv =
2014-03-30 05:13:53 +00:00
[ ("DEBIAN_FRONTEND", "noninteractive")
, ("APT_LISTCHANGES_FRONTEND", "none")
]
update :: Property
2014-03-31 03:55:59 +00:00
update = runApt ["update"]
2014-03-30 19:53:35 +00:00
`describe` "apt update"
upgrade :: Property
2014-03-31 03:55:59 +00:00
upgrade = runApt ["-y", "dist-upgrade"]
2014-03-30 19:53:35 +00:00
`describe` "apt dist-upgrade"
type Package = String
installed :: [Package] -> Property
2014-04-03 00:44:11 +00:00
installed = installed' ["-y"]
installed' :: [String] -> [Package] -> Property
installed' params ps = robustly $ check (isInstallable ps) go
2014-03-30 19:53:35 +00:00
`describe` (unwords $ "apt installed":ps)
where
2014-04-03 00:44:11 +00:00
go = runApt $ params ++ ["install"] ++ ps
installedBackport :: [Package] -> Property
installedBackport ps = withOS desc $ \o -> case o of
Nothing -> error "cannot install backports; os not declared"
2014-04-13 21:50:44 +00:00
(Just (System (Debian suite) _))
| isStable suite ->
ensureProperty $ installed' ["-t", backportSuite, "-y"] ps
_ -> error $ "backports not supported on " ++ show o
where
desc = (unwords $ "apt installed backport":ps)
2014-04-03 00:40:38 +00:00
-- | Minimal install of package, without recommends.
installedMin :: [Package] -> Property
2014-04-03 03:32:09 +00:00
installedMin = installed' ["--no-install-recommends", "-y"]
2014-04-03 00:40:38 +00:00
removed :: [Package] -> Property
2014-03-31 02:14:14 +00:00
removed ps = check (or <$> isInstalled' ps) go
2014-03-30 19:53:35 +00:00
`describe` (unwords $ "apt removed":ps)
where
2014-03-31 03:55:59 +00:00
go = runApt $ ["-y", "remove"] ++ ps
2014-04-01 20:58:11 +00:00
buildDep :: [Package] -> Property
2014-04-02 04:31:07 +00:00
buildDep ps = robustly go
2014-04-01 20:58:11 +00:00
`describe` (unwords $ "apt build-dep":ps)
where
go = runApt $ ["-y", "build-dep"] ++ ps
2014-04-03 00:26:38 +00:00
-- | Installs the build deps for the source package unpacked
-- in the specifed directory, with a dummy package also
-- installed so that autoRemove won't remove them.
buildDepIn :: FilePath -> Property
2014-04-03 03:36:36 +00:00
buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"]
2014-04-03 00:26:38 +00:00
where
2014-04-03 03:40:37 +00:00
go = cmdProperty' "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"]
2014-04-03 00:26:38 +00:00
noninteractiveEnv
-- | Package installation may fail becuse the archive has changed.
2014-04-03 06:27:17 +00:00
-- Run an update in that case and retry.
2014-04-02 04:31:07 +00:00
robustly :: Property -> Property
robustly p = Property (propertyDesc p) $ do
r <- ensureProperty p
if r == FailedChange
then ensureProperty $ p `requires` update
else return r
isInstallable :: [Package] -> IO Bool
isInstallable ps = do
2014-03-31 02:14:14 +00:00
l <- isInstalled' ps
return $ any (== False) l && not (null l)
2014-03-31 02:14:14 +00:00
isInstalled :: Package -> IO Bool
isInstalled p = (== [True]) <$> isInstalled' [p]
2014-03-31 03:55:59 +00:00
-- | Note that the order of the returned list will not always
-- correspond to the order of the input list. The number of items may
-- even vary. If apt does not know about a package at all, it will not
-- be included in the result list.
2014-03-31 02:14:14 +00:00
isInstalled' :: [Package] -> IO [Bool]
isInstalled' ps = catMaybes . map parse . lines
<$> readProcess "apt-cache" ("policy":ps)
where
parse l
| "Installed: (none)" `isInfixOf` l = Just False
| "Installed: " `isInfixOf` l = Just True
| otherwise = Nothing
autoRemove :: Property
2014-03-31 03:55:59 +00:00
autoRemove = runApt ["-y", "autoremove"]
2014-03-30 19:53:35 +00:00
`describe` "apt autoremove"
2014-03-30 05:44:36 +00:00
2014-04-02 16:13:39 +00:00
-- | Enables unattended upgrades. Revert to disable.
unattendedUpgrades :: RevertableProperty
2014-04-08 22:41:30 +00:00
unattendedUpgrades = RevertableProperty enable disable
2014-03-30 19:53:35 +00:00
where
2014-04-08 23:31:03 +00:00
enable = setup True `before` Service.running "cron"
2014-04-08 22:41:30 +00:00
disable = setup False
setup enabled = (if enabled then installed else removed) ["unattended-upgrades"]
2014-04-02 16:13:39 +00:00
`onChange` reConfigure "unattended-upgrades"
[("unattended-upgrades/enable_auto_updates" , "boolean", v)]
`describe` ("unattended upgrades " ++ v)
where
v
| enabled = "true"
| otherwise = "false"
2014-03-30 05:44:36 +00:00
2014-03-31 03:55:59 +00:00
-- | Preseeds debconf values and reconfigures the package so it takes
-- effect.
2014-03-30 05:44:36 +00:00
reConfigure :: Package -> [(String, String, String)] -> Property
reConfigure package vals = reconfigure `requires` setselections
2014-03-30 19:53:35 +00:00
`describe` ("reconfigure " ++ package)
2014-03-30 05:44:36 +00:00
where
2014-03-30 19:31:57 +00:00
setselections = Property "preseed" $ makeChange $
2014-03-30 05:44:36 +00:00
withHandle StdinHandle createProcessSuccess
(proc "debconf-set-selections" []) $ \h -> do
2014-04-11 01:09:20 +00:00
forM_ vals $ \(tmpl, tmpltype, value) ->
hPutStrLn h $ unwords [package, tmpl, tmpltype, value]
2014-03-30 05:44:36 +00:00
hClose h
2014-03-31 03:55:59 +00:00
reconfigure = cmdProperty "dpkg-reconfigure" ["-fnone", package]
2014-04-08 23:31:03 +00:00
-- | Ensures that a service is installed and running.
--
-- Assumes that there is a 1:1 mapping between service names and apt
-- package names.
serviceInstalledRunning :: Package -> Property
serviceInstalledRunning svc = Service.running svc `requires` installed [svc]