From 51d8c2000f46b9c0a8f45ce8d927f23ef5b6193f Mon Sep 17 00:00:00 2001 From: FĂ©lix Sipma Date: Fri, 16 Oct 2015 20:40:48 +0200 Subject: convert symlink properties to File.isSymlinkedTo --- src/Propellor/Property/Nginx.hs | 3 +-- src/Propellor/Property/Prosody.hs | 3 +-- src/Propellor/Property/SiteSpecific/JoeySites.hs | 33 +++++++++++------------- src/Propellor/Property/Uwsgi.hs | 3 +-- 4 files changed, 18 insertions(+), 24 deletions(-) diff --git a/src/Propellor/Property/Nginx.hs b/src/Propellor/Property/Nginx.hs index d0d4d3a9..1bd285c7 100644 --- a/src/Propellor/Property/Nginx.hs +++ b/src/Propellor/Property/Nginx.hs @@ -20,8 +20,7 @@ siteEnabled hn cf = enable disable `onChange` reloaded where test = not <$> doesFileExist (siteVal hn) - prop = property "nginx site in place" $ makeChange $ - createSymbolicLink target dir + prop = dir `File.isSymlinkedTo` target target = siteValRelativeCfg hn dir = siteVal hn disable = trivial $ File.notPresent (siteVal hn) diff --git a/src/Propellor/Property/Prosody.hs b/src/Propellor/Property/Prosody.hs index 78a2c529..7dbfb1e1 100644 --- a/src/Propellor/Property/Prosody.hs +++ b/src/Propellor/Property/Prosody.hs @@ -22,8 +22,7 @@ confEnabled conf cf = enable disable `onChange` reloaded where test = not <$> doesFileExist (confValPath conf) - prop = property "prosody conf in place" $ makeChange $ - createSymbolicLink target dir + prop = dir `File.isSymlinkedTo` target target = confValRelativePath conf dir = confValPath conf confValRelativePath conf' = "../conf.avail" conf' <.> "cfg.lua" diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs index 3f3205e6..25062b42 100644 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -96,11 +96,8 @@ oldUseNetServer hosts = propertyList "olduse.net server" $ props & oldUseNetInstalled "oldusenet-server" & oldUseNetBackup & check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) - (property "olduse.net spool in place" $ makeChange $ do - removeDirectoryRecursive newsspool - createSymbolicLink (datadir "news") newsspool - ) - & "/etc/news/leafnode/config" `File.hasContent` + (newsspool `File.isSymlinkedTo` (datadir "news")) + & "/etc/news/leafnode/config" `File.hasContent` [ "# olduse.net configuration (deployed by propellor)" , "expire = 1000000" -- no expiry via texpire , "server = " -- no upstream server @@ -260,7 +257,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann dir = "/srv/web/" ++ hn postupdatehook = dir ".git/hooks/post-update" setup = userScriptProperty (User "joey") setupscript - setupscript = + setupscript = [ "cd " ++ shellEscape dir , "git annex reinit " ++ shellEscape uuid ] ++ map addremote remotes ++ @@ -294,7 +291,7 @@ apachecfg hn withssl middle | withssl = vhost False ++ vhost True | otherwise = vhost False where - vhost ssl = + vhost ssl = [ "" , " ServerAdmin grue@joeyh.name" , " ServerName "++hn++":"++show port @@ -319,13 +316,13 @@ apachecfg hn withssl middle mainhttpscert :: Bool -> Apache.ConfigFile mainhttpscert False = [] -mainhttpscert True = +mainhttpscert True = [ " SSLEngine on" , " SSLCertificateFile /etc/ssl/certs/web.pem" , " SSLCertificateKeyFile /etc/ssl/private/web.pem" , " SSLCertificateChainFile /etc/ssl/certs/startssl.pem" ] - + gitAnnexDistributor :: Property HasInfo gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props & Apt.installed ["rsync"] @@ -352,7 +349,7 @@ downloads hosts = annexWebSite "/srv/git/downloads.git" "840760dc-08f0-11e2-8c61-576b7e66acfd" [("eubackup", "ssh://eubackup.kitenet.net/~/lib/downloads/")] `requires` Ssh.knownHost hosts "eubackup.kitenet.net" (User "joey") - + tmp :: Property HasInfo tmp = propertyList "tmp.kitenet.net" $ props & annexWebSite "/srv/git/joey/tmp.git" @@ -376,7 +373,7 @@ twitRss = combineProperties "twitter rss" $ props "./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss") compiled = userScriptProperty (User "joey") [ "cd " ++ dir - , "ghc --make twitRss" + , "ghc --make twitRss" ] `requires` Apt.installed [ "libghc-xml-dev" @@ -438,7 +435,7 @@ githubBackup = propertyList "github-backup box" $ props gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")" githubKeys :: Property HasInfo -githubKeys = +githubKeys = let f = "/home/joey/.github-keys" in File.hasPrivContent f anyContext `onChange` File.ownerGroup f (User "joey") (Group "joey") @@ -502,14 +499,14 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props ] `onChange` Service.restarted "spamassassin" `describe` "spamd enabled" `requires` Apt.serviceInstalledRunning "cron" - + & Apt.serviceInstalledRunning "spamass-milter" -- Add -m to prevent modifying messages Subject or body. & "/etc/default/spamass-milter" `File.containsLine` "OPTIONS=\"-m -u spamass-milter -i 127.0.0.1\"" `onChange` Service.restarted "spamass-milter" `describe` "spamass-milter configured" - + & Apt.serviceInstalledRunning "amavisd-milter" & "/etc/default/amavisd-milter" `File.containsLines` [ "# Propellor deployed" @@ -629,7 +626,7 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props `onChange` Postfix.dedupMainCf `onChange` Postfix.reloaded `describe` "postfix configured" - + & Apt.serviceInstalledRunning "dovecot-imapd" & Apt.serviceInstalledRunning "dovecot-pop3d" & "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine` @@ -666,7 +663,7 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props , "inbox-path={localhost/novalidate-cert/NoRsh}inbox" ] `describe` "pine configured to use local imap server" - + & Apt.serviceInstalledRunning "mailman" where ctx = Context "kitenet.net" @@ -816,7 +813,7 @@ legacyWebSites = propertyList "legacy web sites" $ props , "RewriteRule ^/joey/index.html http://www.kitenet.net/joey/ [R]" , "RewriteRule ^/wifi http://www.kitenet.net/wifi/ [R]" , "RewriteRule ^/wifi/index.html http://www.kitenet.net/wifi/ [R]" - + , "# Old ikiwiki filenames for kitenet.net wiki." , "rewritecond $1 !^/~" , "rewritecond $1 !^/doc/" @@ -903,7 +900,7 @@ legacyWebSites = propertyList "legacy web sites" $ props , "rewritecond $1 !.*/index$" , "rewriterule (.+).rss$ http://joeyh.name/$1/index.rss [l]" - + , "# Redirect all to joeyh.name." , "rewriterule (.*) http://joeyh.name$1 [r]" ] diff --git a/src/Propellor/Property/Uwsgi.hs b/src/Propellor/Property/Uwsgi.hs index 8beea17a..c6ae880b 100644 --- a/src/Propellor/Property/Uwsgi.hs +++ b/src/Propellor/Property/Uwsgi.hs @@ -22,8 +22,7 @@ appEnabled an cf = enable disable `onChange` reloaded where test = not <$> doesFileExist (appVal an) - prop = property "uwsgi app in place" $ makeChange $ - createSymbolicLink target dir + prop = dir `File.isSymlinkedTo` target target = appValRelativeCfg an dir = appVal an disable = trivial $ File.notPresent (appVal an) -- cgit v1.2.3 From 40346113191977b6f49cdb4e9996c3a60ca40556 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 16 Oct 2015 15:15:38 -0400 Subject: revert change to JoeySites The change to JoeySites is wrong, because IIRC leafnode creates a spool directory, and isSymlinkedTo will not replace an existing directory with a symlink. --- src/Propellor/Property/SiteSpecific/JoeySites.hs | 33 +++++++++++++----------- 1 file changed, 18 insertions(+), 15 deletions(-) diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs index 25062b42..3f3205e6 100644 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -96,8 +96,11 @@ oldUseNetServer hosts = propertyList "olduse.net server" $ props & oldUseNetInstalled "oldusenet-server" & oldUseNetBackup & check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) - (newsspool `File.isSymlinkedTo` (datadir "news")) - & "/etc/news/leafnode/config" `File.hasContent` + (property "olduse.net spool in place" $ makeChange $ do + removeDirectoryRecursive newsspool + createSymbolicLink (datadir "news") newsspool + ) + & "/etc/news/leafnode/config" `File.hasContent` [ "# olduse.net configuration (deployed by propellor)" , "expire = 1000000" -- no expiry via texpire , "server = " -- no upstream server @@ -257,7 +260,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann dir = "/srv/web/" ++ hn postupdatehook = dir ".git/hooks/post-update" setup = userScriptProperty (User "joey") setupscript - setupscript = + setupscript = [ "cd " ++ shellEscape dir , "git annex reinit " ++ shellEscape uuid ] ++ map addremote remotes ++ @@ -291,7 +294,7 @@ apachecfg hn withssl middle | withssl = vhost False ++ vhost True | otherwise = vhost False where - vhost ssl = + vhost ssl = [ "" , " ServerAdmin grue@joeyh.name" , " ServerName "++hn++":"++show port @@ -316,13 +319,13 @@ apachecfg hn withssl middle mainhttpscert :: Bool -> Apache.ConfigFile mainhttpscert False = [] -mainhttpscert True = +mainhttpscert True = [ " SSLEngine on" , " SSLCertificateFile /etc/ssl/certs/web.pem" , " SSLCertificateKeyFile /etc/ssl/private/web.pem" , " SSLCertificateChainFile /etc/ssl/certs/startssl.pem" ] - + gitAnnexDistributor :: Property HasInfo gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props & Apt.installed ["rsync"] @@ -349,7 +352,7 @@ downloads hosts = annexWebSite "/srv/git/downloads.git" "840760dc-08f0-11e2-8c61-576b7e66acfd" [("eubackup", "ssh://eubackup.kitenet.net/~/lib/downloads/")] `requires` Ssh.knownHost hosts "eubackup.kitenet.net" (User "joey") - + tmp :: Property HasInfo tmp = propertyList "tmp.kitenet.net" $ props & annexWebSite "/srv/git/joey/tmp.git" @@ -373,7 +376,7 @@ twitRss = combineProperties "twitter rss" $ props "./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss") compiled = userScriptProperty (User "joey") [ "cd " ++ dir - , "ghc --make twitRss" + , "ghc --make twitRss" ] `requires` Apt.installed [ "libghc-xml-dev" @@ -435,7 +438,7 @@ githubBackup = propertyList "github-backup box" $ props gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")" githubKeys :: Property HasInfo -githubKeys = +githubKeys = let f = "/home/joey/.github-keys" in File.hasPrivContent f anyContext `onChange` File.ownerGroup f (User "joey") (Group "joey") @@ -499,14 +502,14 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props ] `onChange` Service.restarted "spamassassin" `describe` "spamd enabled" `requires` Apt.serviceInstalledRunning "cron" - + & Apt.serviceInstalledRunning "spamass-milter" -- Add -m to prevent modifying messages Subject or body. & "/etc/default/spamass-milter" `File.containsLine` "OPTIONS=\"-m -u spamass-milter -i 127.0.0.1\"" `onChange` Service.restarted "spamass-milter" `describe` "spamass-milter configured" - + & Apt.serviceInstalledRunning "amavisd-milter" & "/etc/default/amavisd-milter" `File.containsLines` [ "# Propellor deployed" @@ -626,7 +629,7 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props `onChange` Postfix.dedupMainCf `onChange` Postfix.reloaded `describe` "postfix configured" - + & Apt.serviceInstalledRunning "dovecot-imapd" & Apt.serviceInstalledRunning "dovecot-pop3d" & "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine` @@ -663,7 +666,7 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props , "inbox-path={localhost/novalidate-cert/NoRsh}inbox" ] `describe` "pine configured to use local imap server" - + & Apt.serviceInstalledRunning "mailman" where ctx = Context "kitenet.net" @@ -813,7 +816,7 @@ legacyWebSites = propertyList "legacy web sites" $ props , "RewriteRule ^/joey/index.html http://www.kitenet.net/joey/ [R]" , "RewriteRule ^/wifi http://www.kitenet.net/wifi/ [R]" , "RewriteRule ^/wifi/index.html http://www.kitenet.net/wifi/ [R]" - + , "# Old ikiwiki filenames for kitenet.net wiki." , "rewritecond $1 !^/~" , "rewritecond $1 !^/doc/" @@ -900,7 +903,7 @@ legacyWebSites = propertyList "legacy web sites" $ props , "rewritecond $1 !.*/index$" , "rewriterule (.+).rss$ http://joeyh.name/$1/index.rss [l]" - + , "# Redirect all to joeyh.name." , "rewriterule (.*) http://joeyh.name$1 [r]" ] -- cgit v1.2.3 From 556cba2f6d0a85545d9a81baf66dbc848fff848e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 16 Oct 2015 15:19:29 -0400 Subject: clarify which param is which --- src/Propellor/Property/File.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs index 12a3e80a..07ace24b 100644 --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -97,8 +97,12 @@ dirExists :: FilePath -> Property NoInfo dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $ makeChange $ createDirectoryIfMissing True d --- | Creates or atomically updates a symbolic link. Does not overwrite regular --- files or directories. +-- | Creates or atomically updates a symbolic link. +-- +-- The first parameter is what the link should point to. +-- +-- The second parameter is the name of the symbolic link to create. +-- Does not overwrite regular files or directories. isSymlinkedTo :: FilePath -> FilePath -> Property NoInfo link `isSymlinkedTo` target = property desc $ go =<< (liftIO $ tryIO $ getSymbolicLinkStatus link) -- cgit v1.2.3 From 7f7249f801653e0bd7fa083ed001bf3c5a3c3900 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 16 Oct 2015 15:31:18 -0400 Subject: add a LinkTarget type to disambiguate parameters of isSymlinkedTo Something about making symlinks is very confusing about which parameter is which. It perhaps doesn't help that isSymlinkedTo has the target second, while ln has it first. Let's use a type to prevent confusion. Also, simplified some properties that now use isSymlinkedTo. Since isSymlinkedTo checks the link target, these properties don't need to check themselves that the link is in place. --- src/Propellor/Property/File.hs | 10 +++++----- src/Propellor/Property/Nginx.hs | 12 +++--------- src/Propellor/Property/Prosody.hs | 8 +++----- src/Propellor/Property/Uwsgi.hs | 12 +++--------- 4 files changed, 14 insertions(+), 28 deletions(-) diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs index 07ace24b..08fdc780 100644 --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -97,14 +97,14 @@ dirExists :: FilePath -> Property NoInfo dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $ makeChange $ createDirectoryIfMissing True d +-- | The location that a symbolic link points to. +newtype LinkTarget = LinkTarget FilePath + -- | Creates or atomically updates a symbolic link. -- --- The first parameter is what the link should point to. --- --- The second parameter is the name of the symbolic link to create. -- Does not overwrite regular files or directories. -isSymlinkedTo :: FilePath -> FilePath -> Property NoInfo -link `isSymlinkedTo` target = property desc $ +isSymlinkedTo :: FilePath -> LinkTarget -> Property NoInfo +link `isSymlinkedTo` (LinkTarget target) = property desc $ go =<< (liftIO $ tryIO $ getSymbolicLinkStatus link) where desc = link ++ " is symlinked to " ++ target diff --git a/src/Propellor/Property/Nginx.hs b/src/Propellor/Property/Nginx.hs index 1bd285c7..c9b4d8fd 100644 --- a/src/Propellor/Property/Nginx.hs +++ b/src/Propellor/Property/Nginx.hs @@ -6,23 +6,17 @@ import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service -import System.Posix.Files type ConfigFile = [String] siteEnabled :: HostName -> ConfigFile -> RevertableProperty siteEnabled hn cf = enable disable where - enable = check test prop + enable = siteVal hn `File.isSymlinkedTo` siteValRelativeCfg hn `describe` ("nginx site enabled " ++ hn) `requires` siteAvailable hn cf `requires` installed `onChange` reloaded - where - test = not <$> doesFileExist (siteVal hn) - prop = dir `File.isSymlinkedTo` target - target = siteValRelativeCfg hn - dir = siteVal hn disable = trivial $ File.notPresent (siteVal hn) `describe` ("nginx site disable" ++ hn) `requires` installed @@ -40,8 +34,8 @@ siteCfg hn = "/etc/nginx/sites-available/" ++ hn siteVal :: HostName -> FilePath siteVal hn = "/etc/nginx/sites-enabled/" ++ hn -siteValRelativeCfg :: HostName -> FilePath -siteValRelativeCfg hn = "../sites-available/" ++ hn +siteValRelativeCfg :: HostName -> File.LinkTarget +siteValRelativeCfg hn = File.LinkTarget ("../sites-available/" ++ hn) installed :: Property NoInfo installed = Apt.installed ["nginx"] diff --git a/src/Propellor/Property/Prosody.hs b/src/Propellor/Property/Prosody.hs index 7dbfb1e1..0e379e63 100644 --- a/src/Propellor/Property/Prosody.hs +++ b/src/Propellor/Property/Prosody.hs @@ -6,7 +6,6 @@ import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service -import System.Posix.Files type ConfigFile = [String] @@ -15,17 +14,16 @@ type Conf = String confEnabled :: Conf -> ConfigFile -> RevertableProperty confEnabled conf cf = enable disable where - enable = check test prop + enable = dir `File.isSymlinkedTo` target `describe` ("prosody conf enabled " ++ conf) `requires` confAvailable conf cf `requires` installed `onChange` reloaded where - test = not <$> doesFileExist (confValPath conf) - prop = dir `File.isSymlinkedTo` target target = confValRelativePath conf dir = confValPath conf - confValRelativePath conf' = "../conf.avail" conf' <.> "cfg.lua" + confValRelativePath conf' = File.LinkTarget $ + "../conf.avail" conf' <.> "cfg.lua" disable = trivial $ File.notPresent (confValPath conf) `describe` ("prosody conf disabled " ++ conf) `requires` installed diff --git a/src/Propellor/Property/Uwsgi.hs b/src/Propellor/Property/Uwsgi.hs index c6ae880b..7de1a85a 100644 --- a/src/Propellor/Property/Uwsgi.hs +++ b/src/Propellor/Property/Uwsgi.hs @@ -6,7 +6,6 @@ import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service -import System.Posix.Files type ConfigFile = [String] @@ -15,16 +14,11 @@ type AppName = String appEnabled :: AppName -> ConfigFile -> RevertableProperty appEnabled an cf = enable disable where - enable = check test prop + enable = appVal an `File.isSymlinkedTo` appValRelativeCfg an `describe` ("uwsgi app enabled " ++ an) `requires` appAvailable an cf `requires` installed `onChange` reloaded - where - test = not <$> doesFileExist (appVal an) - prop = dir `File.isSymlinkedTo` target - target = appValRelativeCfg an - dir = appVal an disable = trivial $ File.notPresent (appVal an) `describe` ("uwsgi app disable" ++ an) `requires` installed @@ -42,8 +36,8 @@ appCfg an = "/etc/uwsgi/apps-available/" ++ an appVal :: AppName -> FilePath appVal an = "/etc/uwsgi/apps-enabled/" ++ an -appValRelativeCfg :: AppName -> FilePath -appValRelativeCfg an = "../apps-available/" ++ an +appValRelativeCfg :: AppName -> File.LinkTarget +appValRelativeCfg an = File.LinkTarget $ "../apps-available/" ++ an installed :: Property NoInfo installed = Apt.installed ["uwsgi"] -- cgit v1.2.3