diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,16 @@ +propellor (2.6.0) unstable; urgency=medium + + * Replace String type synonym Docker.Image by a data type + which allows to specify an image name and an optional tag. (API change) + Thanks, Antoine Eiche. + * Added --unset to delete a privdata field. + * Version dependency on exceptions. + * Systemd: Add masked property. + Thanks, Sean Whitton + * Fix make install target to work even when git is not configured. + + -- Joey Hess Fri, 10 Jul 2015 22:36:29 -0400 + propellor (2.5.0) unstable; urgency=medium * cmdProperty' renamed to cmdPropertyEnv to make way for a new, diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -17,11 +17,15 @@ cat dist/propellor-*.tar.gz | (cd dist/gittmp && tar zx --strip-components=1) # cabal sdist does not preserve symlinks, so copy over file cd dist/gittmp && for f in $$(find -type f); do rm -f $$f; cp -a ../../$$f $$f; done - cd dist/gittmp && git init && \ - git add . \ - && git commit -q -m "distributed version of propellor" \ - && git bundle create $(DESTDIR)/usr/src/propellor/propellor.git master HEAD \ - && git show-ref master --hash > $(DESTDIR)/usr/src/propellor/head + export GIT_AUTHOR_NAME=build \ + && export GIT_AUTHOR_EMAIL=build@buildhost \ + && export GIT_COMMITTER_NAME=build \ + && export GIT_COMMITTER_EMAIL=build@buildhost \ + && cd dist/gittmp && git init \ + && git add . \ + && git commit -q -m "distributed version of propellor" \ + && git bundle create $(DESTDIR)/usr/src/propellor/propellor.git master HEAD \ + && git show-ref master --hash > $(DESTDIR)/usr/src/propellor/head rm -rf dist/gittmp clean: diff --git a/config-joey.hs b/config-joey.hs --- a/config-joey.hs +++ b/config-joey.hs @@ -505,10 +505,10 @@ -- Docker images I prefer to use. dockerImage :: System -> Docker.Image -dockerImage (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch -dockerImage (System (Debian Testing) arch) = "joeyh/debian-unstable-" ++ arch -dockerImage (System (Debian (Stable _)) arch) = "joeyh/debian-stable-" ++ arch -dockerImage _ = "debian-stable-official" -- does not currently exist! +dockerImage (System (Debian Unstable) arch) = Docker.latestImage ("joeyh/debian-unstable-" ++ arch) +dockerImage (System (Debian Testing) arch) = Docker.latestImage ("joeyh/debian-unstable-" ++ arch) +dockerImage (System (Debian (Stable _)) arch) = Docker.latestImage ("joeyh/debian-stable-" ++ arch) +dockerImage _ = Docker.latestImage "debian-stable-official" -- does not currently exist! myDnsSecondary :: Property HasInfo myDnsSecondary = propertyList "dns secondary for all my domains" $ props diff --git a/config-simple.hs b/config-simple.hs --- a/config-simple.hs +++ b/config-simple.hs @@ -41,7 +41,7 @@ -- A generic webserver in a Docker container. webserverContainer :: Docker.Container -webserverContainer = Docker.container "webserver" "debian" +webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") & os (System (Debian (Stable "jessie")) "amd64") & Apt.stdSourcesList & Docker.publish "80:80" diff --git a/config.hs b/config.hs --- a/config.hs +++ b/config.hs @@ -41,7 +41,7 @@ -- A generic webserver in a Docker container. webserverContainer :: Docker.Container -webserverContainer = Docker.container "webserver" "debian" +webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") & os (System (Debian (Stable "jessie")) "amd64") & Apt.stdSourcesList & Docker.publish "80:80" diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,16 @@ +propellor (2.6.0) unstable; urgency=medium + + * Replace String type synonym Docker.Image by a data type + which allows to specify an image name and an optional tag. (API change) + Thanks, Antoine Eiche. + * Added --unset to delete a privdata field. + * Version dependency on exceptions. + * Systemd: Add masked property. + Thanks, Sean Whitton + * Fix make install target to work even when git is not configured. + + -- Joey Hess Fri, 10 Jul 2015 22:36:29 -0400 + propellor (2.5.0) unstable; urgency=medium * cmdProperty' renamed to cmdPropertyEnv to make way for a new, diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -16,7 +16,7 @@ libghc-quickcheck2-dev, libghc-mtl-dev, libghc-transformers-dev, - libghc-exceptions-dev, + libghc-exceptions-dev (>= 0.6), Maintainer: Gergely Nagy Standards-Version: 3.9.6 Vcs-Git: git://git.joeyh.name/propellor @@ -38,7 +38,7 @@ libghc-quickcheck2-dev, libghc-mtl-dev, libghc-transformers-dev, - libghc-exceptions-dev, + libghc-exceptions-dev (>= 0.6), git, Description: property-based host configuration management in haskell Propellor enures that the system it's run in satisfies a list of diff --git a/propellor.cabal b/propellor.cabal --- a/propellor.cabal +++ b/propellor.cabal @@ -1,6 +1,6 @@ Name: propellor -Version: 2.5.0 -Cabal-Version: >= 1.6 +Version: 2.6.0 +Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess Author: Joey Hess @@ -38,7 +38,7 @@ Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers, network, async, time, QuickCheck, mtl, transformers, - exceptions + exceptions (>= 0.6) if (! os(windows)) Build-Depends: unix diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -51,6 +51,7 @@ _ -> Spin <$> mapM hostname ps <*> pure Nothing go ("--add-key":k:[]) = return $ AddKey k go ("--set":f:c:[]) = withprivfield f c Set + go ("--unset":f:c:[]) = withprivfield f c Unset go ("--dump":f:c:[]) = withprivfield f c Dump go ("--edit":f:c:[]) = withprivfield f c Edit go ("--list-fields":[]) = return ListFields @@ -94,6 +95,7 @@ go _ (Continue cmdline) = go False cmdline go _ Check = return () go _ (Set field context) = setPrivData field context + go _ (Unset field context) = unsetPrivData field context go _ (Dump field context) = dumpPrivData field context go _ (Edit field context) = editPrivData field context go _ ListFields = listPrivDataFields hostlist diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -6,6 +6,7 @@ withSomePrivData, addPrivData, setPrivData, + unsetPrivData, dumpPrivData, editPrivData, filterPrivData, @@ -143,6 +144,11 @@ putStrLn "Enter private data on stdin; ctrl-D when done:" setPrivDataTo field context =<< hGetContentsStrict stdin +unsetPrivData :: PrivDataField -> Context -> IO () +unsetPrivData field context = do + modifyPrivData $ M.delete (field, context) + putStrLn "Private data unset." + dumpPrivData :: PrivDataField -> Context -> IO () dumpPrivData field context = maybe (error "Requested privdata is not set.") putStrLn @@ -192,16 +198,21 @@ setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO () setPrivDataTo field context value = do - makePrivDataDir - m <- decryptPrivData - let m' = M.insert (field, context) (chomp value) m - gpgEncrypt privDataFile (show m') + modifyPrivData set putStrLn "Private data set." - void $ boolSystem "git" [Param "add", File privDataFile] where + set = M.insert (field, context) (chomp value) chomp s | end s == "\n" = chomp (beginning s) | otherwise = s + +modifyPrivData :: (PrivMap -> PrivMap) -> IO () +modifyPrivData f = do + makePrivDataDir + m <- decryptPrivData + let m' = f m + gpgEncrypt privDataFile (show m') + void $ boolSystem "git" [Param "add", File privDataFile] decryptPrivData :: IO PrivMap decryptPrivData = fromMaybe M.empty . readish <$> gpgDecrypt privDataFile diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -16,7 +16,8 @@ memoryLimited, garbageCollected, tweaked, - Image, + Image(..), + latestImage, ContainerName, Container, HasImage(..), @@ -155,8 +156,8 @@ imageBuilt :: HasImage c => FilePath -> c -> Property NoInfo imageBuilt directory ctr = describe built msg where - msg = "docker image " ++ image ++ " built from " ++ directory - built = Cmd.cmdProperty' dockercmd ["build", "--tag", image, "./"] workDir + msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory + built = Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir workDir p = p { cwd = Just directory } image = getImageName ctr @@ -164,8 +165,8 @@ imagePulled :: HasImage c => c -> Property NoInfo imagePulled ctr = describe pulled msg where - msg = "docker image " ++ image ++ " pulled" - pulled = Cmd.cmdProperty dockercmd ["pull", image] + msg = "docker image " ++ (imageIdentifier image) ++ " pulled" + pulled = Cmd.cmdProperty dockercmd ["pull", imageIdentifier image] image = getImageName ctr propigateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo @@ -243,9 +244,53 @@ -- | Parameters to pass to `docker run` when creating a container. type RunParam = String --- | A docker image, that can be used to run a container. -type Image = String +-- | ImageID is an image identifier to perform action on images. An +-- ImageID can be the name of an container image, a UID, etc. +-- +-- It just encapsulates a String to avoid the definition of a String +-- instance of ImageIdentifier. +newtype ImageID = ImageID String +-- | Used to perform Docker action on an image. +-- +-- Minimal complete definition: `imageIdentifier` +class ImageIdentifier i where + -- | For internal purposes only. + toImageID :: i -> ImageID + toImageID = ImageID . imageIdentifier + -- | A string that Docker can use as an image identifier. + imageIdentifier :: i -> String + +instance ImageIdentifier ImageID where + imageIdentifier (ImageID i) = i + toImageID = id + +-- | A docker image, that can be used to run a container. The user has +-- to specify a name and can provide an optional tag. +-- See +-- for more information. +data Image = Image + { repository :: String + , tag :: Maybe String + } + deriving (Eq, Read, Show) + +-- | Defines a Docker image without any tag. This is considered by +-- Docker as the latest image of the provided repository. +latestImage :: String -> Image +latestImage repo = Image repo Nothing + +instance ImageIdentifier Image where + -- | The format of the imageIdentifier of an `Image` is: + -- repository | repository:tag + imageIdentifier i = repository i ++ (maybe "" ((++) ":") $ tag i) + +-- | The UID of an image. This UID is generated by Docker. +newtype ImageUID = ImageUID String + +instance ImageIdentifier ImageUID where + imageIdentifier (ImageUID uid) = uid + -- | Set custom dns server for container. dns :: String -> Property HasInfo dns = runProp "dns" @@ -424,7 +469,9 @@ return FailedChange restartcontainer = do - oldimage <- liftIO $ fromMaybe image <$> commitContainer cid + oldimage <- liftIO $ + fromMaybe (toImageID image) . fmap toImageID <$> + commitContainer cid void $ liftIO $ removeContainer cid go oldimage @@ -561,20 +608,20 @@ removeContainer cid = catchBoolIO $ snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing -removeImage :: Image -> IO Bool +removeImage :: ImageIdentifier i => i -> IO Bool removeImage image = catchBoolIO $ - snd <$> processTranscript dockercmd ["rmi", image ] Nothing + snd <$> processTranscript dockercmd ["rmi", imageIdentifier image] Nothing -runContainer :: Image -> [RunParam] -> [String] -> IO Bool +runContainer :: ImageIdentifier i => i -> [RunParam] -> [String] -> IO Bool runContainer image ps cmd = boolSystem dockercmd $ map Param $ - "run" : (ps ++ image : cmd) + "run" : (ps ++ (imageIdentifier image) : cmd) inContainerProcess :: ContainerId -> [String] -> [String] -> CreateProcess inContainerProcess cid ps cmd = proc dockercmd ("exec" : ps ++ [fromContainerId cid] ++ cmd) -commitContainer :: ContainerId -> IO (Maybe Image) +commitContainer :: ContainerId -> IO (Maybe ImageUID) commitContainer cid = catchMaybeIO $ - takeWhile (/= '\n') + ImageUID . takeWhile (/= '\n') <$> readProcess dockercmd ["commit", fromContainerId cid] data ContainerFilter = RunningContainers | AllContainers @@ -592,8 +639,8 @@ | otherwise = baseps baseps = ["ps", "--no-trunc"] -listImages :: IO [Image] -listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"] +listImages :: IO [ImageUID] +listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"] runProp :: String -> RunParam -> Property HasInfo runProp field val = pureInfoProperty (param) $ dockerInfo $ diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs --- a/src/Propellor/Property/Postfix.hs +++ b/src/Propellor/Property/Postfix.hs @@ -23,10 +23,10 @@ -- | Configures postfix as a satellite system, which -- relays all mail through a relay host, which defaults to smtp.domain, --- but can be changed by mainCf "relayhost" +-- but can be changed by @mainCf "relayhost"@. -- -- The smarthost may refuse to relay mail on to other domains, without --- futher coniguration/keys. But this should be enough to get cron job +-- further configuration/keys. But this should be enough to get cron job -- mail flowing to a place where it will be seen. satellite :: Property NoInfo satellite = check (not <$> mainCfIsSet "relayhost") setup @@ -58,7 +58,7 @@ `onChange` cmdProperty "postmap" [f] -- | Run newaliases command, which should be done after changing --- . +-- @/etc/aliases@. newaliases :: Property NoInfo newaliases = trivial $ cmdProperty "newaliases" [] @@ -66,7 +66,7 @@ mainCfFile :: FilePath mainCfFile = "/etc/postfix/main.cf" --- | Sets a main.cf name=value pair. Does not reload postfix immediately. +-- | Sets a main.cf @name=value@ pair. Does not reload postfix immediately. mainCf :: (String, String) -> Property NoInfo mainCf (name, value) = check notset set `describe` ("postfix main.cf " ++ setting) @@ -75,7 +75,7 @@ notset = (/= Just value) <$> getMainCf name set = cmdProperty "postconf" ["-e", setting] --- | Gets a man.cf setting. +-- | Gets a main.cf setting. getMainCf :: String -> IO (Maybe String) getMainCf name = parse . lines <$> readProcess "postconf" [name] where @@ -131,9 +131,9 @@ -- | Installs saslauthd and configures it for postfix, authenticating -- against PAM. -- --- Does not configure postfix to use it; eg smtpd_sasl_auth_enable = yes +-- Does not configure postfix to use it; eg @smtpd_sasl_auth_enable = yes@ -- needs to be set to enable use. See --- https://wiki.debian.org/PostfixAndSASL +-- . saslAuthdInstalled :: Property NoInfo saslAuthdInstalled = setupdaemon `requires` Service.running "saslauthd" diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -67,7 +67,6 @@ buildDepsApt :: Property HasInfo buildDepsApt = combineProperties "gitannexbuilder build deps" $ props & Apt.buildDep ["git-annex"] - & Apt.installed ["liblockfile-simple-perl"] & buildDepsNoHaskellLibs & Apt.buildDepIn builddir `describe` "git-annex source build deps installed" @@ -86,7 +85,7 @@ haskellPkgsInstalled dir = flagFile go ("/haskellpkgsinstalled") where go = userScriptProperty (User builduser) - [ "cd " ++ builddir ++ " && ./standalone/ " ++ dir ++ "/install-haskell-packages" + [ "cd " ++ builddir ++ " && ./standalone/" ++ dir ++ "/install-haskell-packages" ] -- Installs current versions of git-annex's deps from cabal, but only @@ -150,7 +149,6 @@ & File.ownerGroup homedir (User builduser) (Group builduser) & flagFile chrootsetup ("/chrootsetup") `requires` setupgitannexdir - & buildDepsApt & haskellPkgsInstalled "android" where -- Use git-annex's android chroot setup script, which will install @@ -159,5 +157,5 @@ chrootsetup = scriptProperty [ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot" ] - osver = System (Debian Testing) "i386" + osver = System (Debian (Stable "jessie")) "i386" bootstrap = Chroot.debootstrapped osver mempty diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -859,6 +859,8 @@ , " AllowOverride None" , Apache.allowAll , "" + , "RewriteEngine On" + , "RewriteRule .* http://www.sowsearpoetry.org/ [L]" ] & alias "wortroot.kitenet.net" & alias "www.wortroot.kitenet.net" diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -7,6 +7,7 @@ stopped, enabled, disabled, + masked, running, restarted, networkd, @@ -88,6 +89,15 @@ disabled :: ServiceName -> Property NoInfo disabled n = trivial $ cmdProperty "systemctl" ["disable", n] `describe` ("service " ++ n ++ " disabled") + +-- | Masks a systemd service. +masked :: ServiceName -> RevertableProperty +masked n = systemdMask systemdUnmask + where + systemdMask = trivial $ cmdProperty "systemctl" ["mask", n] + `describe` ("service " ++ n ++ " masked") + systemdUnmask = trivial $ cmdProperty "systemctl" ["unmask", n] + `describe` ("service " ++ n ++ " unmasked") -- | Ensures that a service is both enabled and started running :: ServiceName -> Property NoInfo diff --git a/src/Propellor/Types/CmdLine.hs b/src/Propellor/Types/CmdLine.hs --- a/src/Propellor/Types/CmdLine.hs +++ b/src/Propellor/Types/CmdLine.hs @@ -10,6 +10,7 @@ | Spin [HostName] (Maybe HostName) | SimpleRun HostName | Set PrivDataField Context + | Unset PrivDataField Context | Dump PrivDataField Context | Edit PrivDataField Context | ListFields diff --git a/src/config.hs b/src/config.hs --- a/src/config.hs +++ b/src/config.hs @@ -41,7 +41,7 @@ -- A generic webserver in a Docker container. webserverContainer :: Docker.Container -webserverContainer = Docker.container "webserver" "debian" +webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") & os (System (Debian (Stable "jessie")) "amd64") & Apt.stdSourcesList & Docker.publish "80:80"