diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,47 @@ +propellor (1.3.2) unstable; urgency=medium + + * SSHFP records are also generated for CNAMES of hosts. + * Merge Utiity modules from git-annex. + * Ignore bogus DNS when spinning the local host. + + -- Joey Hess Thu, 15 Jan 2015 14:02:07 -0400 + +propellor (1.3.1) unstable; urgency=medium + + * Fix bug that prevented deploying ssh host keys when the file for the + key didn't already exist. + * DNS records for hosts with known ssh public keys now automatically + include SSHFP records. + + -- Joey Hess Sun, 04 Jan 2015 19:51:34 -0400 + +propellor (1.3.0) unstable; urgency=medium + + * --spin checks if the DNS matches any configured IP address property + of the host, and if not, sshes to the host by IP address. + * Detect #774376 and refuse to use docker if the system is so broken + that docker exec doesn't enter a chroot. + * Update intermediary propellor in --spin --via + * Added support for DNSSEC. + * Ssh.hostKey and Ssh.hostKeys no longer install public keys from + the privdata. Instead, the public keys are included in the + configuration. (API change) + * Ssh.hostKeys now removes any host keys of types that the host is not + configured to have. + * sshPubKey is renamed to Ssh.pubKey, and has an added SshKeyType + parameter. (API change) + * CloudAtCost.deCruft no longer forces randomHostKeys. + * Fix build with process 1.2.1.0. + + -- Joey Hess Sun, 04 Jan 2015 17:17:44 -0400 + +propellor (1.2.2) unstable; urgency=medium + + * Revert ensureProperty warning message, too many false positives in places + where Info is correctly propigated. Better approach needed. + + -- Joey Hess Sun, 21 Dec 2014 21:41:11 -0400 + propellor (1.2.1) unstable; urgency=medium * Added CryptPassword to PrivDataField, for password hashes as produced diff --git a/config-joey.hs b/config-joey.hs --- a/config-joey.hs +++ b/config-joey.hs @@ -25,8 +25,6 @@ import qualified Propellor.Property.Obnam as Obnam import qualified Propellor.Property.Gpg as Gpg import qualified Propellor.Property.Systemd as Systemd -import qualified Propellor.Property.Chroot as Chroot -import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.OS as OS import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost @@ -48,7 +46,6 @@ , kite , diatom , elephant - , alien , testvm ] ++ monsters @@ -76,27 +73,17 @@ & Apt.buildDep ["git-annex"] `period` Daily & Docker.configured ! Docker.docked gitAnnexAndroidDev - ! website "foo" -website :: String -> RevertableProperty -website hn = Apache.siteEnabled hn apachecfg - where - apachecfg = [ "" - , "DocumentRoot /tmp/xx" - , "" - , " Options Indexes FollowSymLinks Multiviews" - , " Order allow,deny" - , Apache.allowAll - , "" - , "" - ] + & JoeySites.postfixClientRelay (Context "darkstar.kitenet.net") + & JoeySites.dkimMilter clam :: Host clam = standardSystem "clam.kitenet.net" Unstable "amd64" [ "Unreliable server. Anything here may be lost at any time!" ] - & ipv4 "162.248.9.29" + & ipv4 "167.88.41.194" & CloudAtCost.decruft + & Ssh.randomHostKeys & Apt.unattendedUpgrades & Network.ipv6to4 & Tor.isBridge @@ -109,6 +96,7 @@ & File.notPresent "/var/www/html/index.html" & "/var/www/index.html" `File.hasContent` ["hello, world"] & alias "helloworld.kitenet.net" + & Docker.docked oldusenetShellBox -- ssh on some extra ports to deal with horrible networks -- while travelling @@ -117,21 +105,7 @@ ! Ssh.listenPort 443 & Systemd.persistentJournal - ! Systemd.nspawned meow - -meow :: Systemd.Container -meow = Systemd.container "meow" (Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty) - & Apt.serviceInstalledRunning "uptimed" - & alias "meow.kitenet.net" -alien :: Host -alien = host "alientest.kitenet.net" - & ipv4 "104.131.106.199" - & Chroot.provisioned - ( Chroot.debootstrapped (System (Debian Unstable) "amd64") Debootstrap.MinBase "/debian" - & Apt.serviceInstalledRunning "uptimed" - ) - orca :: Host orca = standardSystem "orca.kitenet.net" Unstable "amd64" [ "Main git-annex build box." ] @@ -148,25 +122,29 @@ & Docker.docked (GitAnnexBuilder.androidAutoBuilderContainer dockerImage "1 1 * * *" "3h") & Docker.garbageCollected `period` Daily & Apt.buildDep ["git-annex"] `period` Daily - + -- This is not a complete description of kite, since it's a -- multiuser system with eg, user passwords that are not deployed -- with propellor. kite :: Host kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64" - [ "Welcome to the new kitenet.net server!" - ] + [ "Welcome to the new kitenet.net server!" ] & ipv4 "66.228.36.95" & ipv6 "2600:3c03::f03c:91ff:fe73:b0d2" & alias "kitenet.net" & alias "wren.kitenet.net" -- temporary + & Ssh.hostKeys (Context "kitenet.net") + [ (SshDsa, "ssh-dss AAAAB3NzaC1kc3MAAACBAO9tnPUT4p+9z7K6/OYuiBNHaij4Nzv5YVBih1vMl+ALz0gYAj8RWJzXmqp5buFAyfgOoLw+H9s1bBS01Sy3i07Dm6cx1fWG4RXL/E/3w1tavX99GD2bBxDBu890ebA5Tp+eFRJkS9+JwSvFiF6CP7NbVjifCagoUO56Ig048RwDAAAAFQDPY2xM3q6KwsVQliel23nrd0rV2QAAAIEAga3hj1hL00rYPNnAUzT8GAaSP62S4W68lusErH+KPbsMwFBFY/Ib1FVf8k6Zn6dZLh/HH/RtJi0JwdzPI1IFW+lwVbKfwBvhQ1lw9cH2rs1UIVgi7Wxdgfy8gEWxf+QIqn62wG+Ulf/HkWGvTrRpoJqlYRNS/gnOWj9Z/4s99koAAACBAM/uJIo2I0nK15wXiTYs/NYUZA7wcErugFn70TRbSgduIFH6U/CQa3rgHJw9DCPCQJLq7pwCnFH7too/qaK+czDk04PsgqV0+Jc7957gU5miPg50d60eJMctHV4eQ1FpwmGGfXxRBR9k2ZvikWYatYir3L6/x1ir7M0bA9IzNU45") + , (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAIEA2QAJEuvbTmaN9ex9i9bjPhMGj+PHUYq2keIiaIImJ+8mo+yKSaGUxebG4tpuDPx6KZjdycyJt74IXfn1voGUrfzwaEY9NkqOP3v6OWTC3QeUGqDCeJ2ipslbEd9Ep9XBp+/ldDQm60D0XsIZdmDeN6MrHSbKF4fXv1bqpUoUILk=") + , (SshEcdsa, "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBLF+dzqBJZix+CWUkAd3Bd3cofFCKwHMNRIfwx1G7dL4XFe6fMKxmrNetQcodo2edyufwoPmCPr3NmnwON9vyh0=") + , (SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFZftKMnH/zH29BHMKbcBO4QsgTrstYFVhbrzrlRzBO3") + ] & Apt.installed ["linux-image-amd64"] & Linode.chainPVGrub 5 & Apt.unattendedUpgrades & Systemd.installed & Systemd.persistentJournal - & Ssh.hostKeys (Context "kitenet.net") & Ssh.passwordAuthentication True -- Since ssh password authentication is allowed: & Apt.serviceInstalledRunning "fail2ban" @@ -190,6 +168,11 @@ & alias "pop.kitenet.net" & alias "mail.kitenet.net" & JoeySites.kiteMailServer + + & alias "ns4.kitenet.net" + & myDnsSecondary + & alias "ns4.branchable.com" + & branchableSecondary & JoeySites.legacyWebSites @@ -206,7 +189,7 @@ `onChange` Service.restarted "bitlbee" & Apt.installed - ["git-annex", "myrepos" + [ "git-annex", "myrepos" , "build-essential", "make" , "rss2email", "archivemail" , "devscripts" @@ -216,14 +199,18 @@ & Docker.configured & Docker.garbageCollected `period` Daily + & Docker.docked oldusenetShellBox diatom :: Host diatom = standardSystem "diatom.kitenet.net" (Stable "wheezy") "amd64" [ "Important stuff that needs not too much memory or CPU." ] & ipv4 "107.170.31.195" + & Ssh.hostKeys hostContext + [ (SshDsa, "ssh-dss AAAAB3NzaC1kc3MAAACBAO9tnPUT4p+9z7K6/OYuiBNHaij4Nzv5YVBih1vMl+ALz0gYAj8RWJzXmqp5buFAyfgOoLw+H9s1bBS01Sy3i07Dm6cx1fWG4RXL/E/3w1tavX99GD2bBxDBu890ebA5Tp+eFRJkS9+JwSvFiF6CP7NbVjifCagoUO56Ig048RwDAAAAFQDPY2xM3q6KwsVQliel23nrd0rV2QAAAIEAga3hj1hL00rYPNnAUzT8GAaSP62S4W68lusErH+KPbsMwFBFY/Ib1FVf8k6Zn6dZLh/HH/RtJi0JwdzPI1IFW+lwVbKfwBvhQ1lw9cH2rs1UIVgi7Wxdgfy8gEWxf+QIqn62wG+Ulf/HkWGvTrRpoJqlYRNS/gnOWj9Z/4s99koAAACBAM/uJIo2I0nK15wXiTYs/NYUZA7wcErugFn70TRbSgduIFH6U/CQa3rgHJw9DCPCQJLq7pwCnFH7too/qaK+czDk04PsgqV0+Jc7957gU5miPg50d60eJMctHV4eQ1FpwmGGfXxRBR9k2ZvikWYatYir3L6/x1ir7M0bA9IzNU45") + , (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAIEA2QAJEuvbTmaN9ex9i9bjPhMGj+PHUYq2keIiaIImJ+8mo+yKSaGUxebG4tpuDPx6KZjdycyJt74IXfn1voGUrfzwaEY9NkqOP3v6OWTC3QeUGqDCeJ2ipslbEd9Ep9XBp+/ldDQm60D0XsIZdmDeN6MrHSbKF4fXv1bqpUoUILk=") + ] & DigitalOcean.distroKernel - & Ssh.hostKeys hostContext & Apt.unattendedUpgrades & Apt.serviceInstalledRunning "ntp" & Postfix.satellite @@ -242,7 +229,6 @@ & alias "git.joeyh.name" & JoeySites.gitServer hosts - & alias "downloads.kitenet.net" & JoeySites.annexWebSite "/srv/git/downloads.git" "downloads.kitenet.net" "840760dc-08f0-11e2-8c61-576b7e66acfd" @@ -250,25 +236,30 @@ `requires` Ssh.keyImported SshRsa "joey" (Context "downloads.kitenet.net") `requires` Ssh.knownHost hosts "eubackup.kitenet.net" "joey" & JoeySites.gitAnnexDistributor - & alias "tmp.kitenet.net" + & JoeySites.annexWebSite "/srv/git/joey/tmp.git" "tmp.kitenet.net" "26fd6e38-1226-11e2-a75f-ff007033bdba" [] & JoeySites.twitRss & JoeySites.pumpRss + + & JoeySites.annexWebSite "/srv/git/user-liberation.git" + "user-liberation.joeyh.name" + "da89f112-808b-420a-b468-d990ae2e5b52" + [] & alias "nntp.olduse.net" & alias "resources.olduse.net" & JoeySites.oldUseNetServer hosts & alias "ns2.kitenet.net" - & myDnsPrimary "kitenet.net" [] - & myDnsPrimary "joeyh.name" [] - & myDnsPrimary "ikiwiki.info" [] - & myDnsPrimary "olduse.net" - [ (RelDomain "article", - CNAME $ AbsDomain "virgil.koldfront.dk") ] + & myDnsPrimary False "kitenet.net" [] + & myDnsPrimary True "joeyh.name" [] + & myDnsPrimary True "ikiwiki.info" [] + & myDnsPrimary True "olduse.net" + [ (RelDomain "article", CNAME $ AbsDomain "virgil.koldfront.dk") + ] & alias "ns3.branchable.com" & branchableSecondary @@ -281,14 +272,18 @@ , "(Encrypt all data stored here.)" ] & ipv4 "193.234.225.114" + & Ssh.hostKeys hostContext + [ (SshDsa, "ssh-dss AAAAB3NzaC1kc3MAAACBANxXGWac0Yz58akI3UbLkphAa8VPDCGswTS0CT3D5xWyL9OeArISAi/OKRIvxA4c+9XnWtNXS7nYVFDJmzzg8v3ZMx543AxXK82kXCfvTOc/nAlVz9YKJAA+FmCloxpmOGrdiTx1k36FE+uQgorslGW/QTxnOcO03fDZej/ppJifAAAAFQCnenyJIw6iJB1+zuF/1TSLT8UAeQAAAIEA1WDrI8rKnxnh2rGaQ0nk+lOcVMLEr7AxParnZjgC4wt2mm/BmkF/feI1Fjft2z4D+V1W7MJHOqshliuproxhFUNGgX9fTbstFJf66p7h7OLAlwK8ZkpRk/uV3h5cIUPel6aCwjL5M2gN6/yq+gcCTXeHLq9OPyUTmlN77SBL71UAAACBAJJiCHWxPAGooe7Vv3W7EIBbsDyf7b2kDH3bsIlo+XFcKIN6jysBu4kn9utjFlrlPeHUDzGQHe+DmSqTUQQ0JPCRGcAcuJL8XUqhJi6A6ye51M9hVt51cJMXmERx9TjLOP/adkEuxpv3Fj20FxRUr1HOmvRvewSHrJ1GeA1bjbYL") + , (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQCrEQ7aNmRYyLKY7xHILQsyV/w0B3++D98vn5IvjHkDnitrUWjB+vPxlS7LYKLzN9Jx7Hb14R2lg7+wdgtFMxLZZukA8b0tqFpTdRFBvBYGh8IM8Id1iE/6io/NZl+hTQEDp0LJP+RljH1CLfz7J3qtc+v6NbfTP5cOgH104mWYoLWzJGaZ4p53jz6THRWnVXy5nPO3dSBr2f/SQgRuJQWHNIh0jicRGD8H2kzOQzilpo+Y46PWtkufl3Yu3UsP5UMAyLRIXwZ6nNRZqRiVWrX44hoNfDbooTdFobbHlqMl+y6291bOXaOA6PACk8B4IVcC89/gmc9Oe4EaDuszU5kD") + , (SshEcdsa, "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBAJkoPRhUGT8EId6m37uBdYEtq42VNwslKnc9mmO+89ody066q6seHKeFY6ImfwjcyIjM30RTzEwftuVNQnbEB0=") + , (SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB6VtXi0uygxZeCo26n6PuCTlSFCBcwRifv6N8HdWh2Z") + ] & Grub.chainPVGrub "hd0,0" "xen/xvda1" 30 & Postfix.satellite & Apt.unattendedUpgrades & Systemd.installed & Systemd.persistentJournal - & Ssh.hostKeys hostContext - & sshPubKey "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBAJkoPRhUGT8EId6m37uBdYEtq42VNwslKnc9mmO+89ody066q6seHKeFY6ImfwjcyIjM30RTzEwftuVNQnbEB0=" & Ssh.keyImported SshRsa "joey" hostContext & Apt.serviceInstalledRunning "swapspace" @@ -319,6 +314,7 @@ & Docker.docked openidProvider `requires` Apt.serviceInstalledRunning "ntp" & Docker.docked ancientKitenet + & Docker.docked jerryPlay & Docker.garbageCollected `period` (Weekly (Just 1)) -- For https port 443, shellinabox with ssh login to @@ -375,6 +371,15 @@ & Docker.volume ("/home/joey/src/git-annex:" ++ gitannexdir) where gitannexdir = GitAnnexBuilder.homedir "git-annex" + +jerryPlay :: Docker.Container +jerryPlay = standardContainer "jerryplay" Unstable "amd64" + & alias "jerryplay.kitenet.net" + & Docker.publish "2202:22" + & Docker.publish "8001:80" + & Apt.installed ["ssh"] + & User.hasSomePassword "root" + & Ssh.permitRootLogin True type Motd = [String] @@ -411,7 +416,7 @@ standardStableContainer :: Docker.ContainerName -> Docker.Container standardStableContainer name = standardContainer name (Stable "wheezy") "amd64" --- This is my standard container setup, featuring automatic upgrades. +-- This is my standard container setup, Featuring automatic upgrades. standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Docker.Container standardContainer name suite arch = Docker.container name (dockerImage system) & os system @@ -441,16 +446,19 @@ branchableSecondary = Dns.secondaryFor ["branchable.com"] hosts "branchable.com" -- Currently using diatom (ns2) as primary with secondaries --- elephant (ns3) and gandi. +-- elephant (ns3), kite (ns4) and gandi. -- kite handles all mail. -myDnsPrimary :: Domain -> [(BindDomain, Record)] -> RevertableProperty -myDnsPrimary domain extras = Dns.primary hosts domain +myDnsPrimary :: Bool -> Domain -> [(BindDomain, Record)] -> RevertableProperty +myDnsPrimary dnssec domain extras = (if dnssec then Dns.signedPrimary (Weekly Nothing) else Dns.primary) hosts domain (Dns.mkSOA "ns2.kitenet.net" 100) $ [ (RootDomain, NS $ AbsDomain "ns2.kitenet.net") , (RootDomain, NS $ AbsDomain "ns3.kitenet.net") + , (RootDomain, NS $ AbsDomain "ns4.kitenet.net") , (RootDomain, NS $ AbsDomain "ns6.gandi.net") , (RootDomain, MX 0 $ AbsDomain "kitenet.net") - , (RootDomain, TXT "v=spf1 a ?all") + -- SPF only allows IP address of kitenet.net to send mail. + , (RootDomain, TXT "v=spf1 a:kitenet.net -all") + , JoeySites.domainKey ] ++ extras @@ -468,9 +476,9 @@ monsters :: [Host] -- Systems I don't manage with propellor, monsters = -- but do want to track their public keys etc. [ host "usw-s002.rsync.net" - & sshPubKey "ssh-dss AAAAB3NzaC1kc3MAAAEBAI6ZsoW8a+Zl6NqUf9a4xXSMcV1akJHDEKKBzlI2YZo9gb9YoCf5p9oby8THUSgfh4kse7LJeY7Nb64NR6Y/X7I2/QzbE1HGGl5mMwB6LeUcJ74T3TQAlNEZkGt/MOIVLolJHk049hC09zLpkUDtX8K0t1yaCirC9SxDGLTCLEhvU9+vVdVrdQlKZ9wpLUNbdAzvbra+O/IVvExxDZ9WCHrnfNA8ddVZIGEWMqsoNgiuCxiXpi8qL+noghsSQNFTXwo7W2Vp9zj1JkCt3GtSz5IzEpARQaXEAWNEM0n1nJ686YUOhou64iRM8bPC1lp3QXvvZNgj3m+QHhIempx+de8AAAAVAKB5vUDaZOg14gRn7Bp81ja/ik+RAAABACPH/bPbW912x1NxNiikzGR6clLh+bLpIp8Qie3J7DwOr8oC1QOKjNDK+UgQ7mDQEgr4nGjNKSvpDi4c1QCw4sbLqQgx1y2VhT0SmUPHf5NQFldRQyR/jcevSSwOBxszz3aq9AwHiv9OWaO3XY18suXPouiuPTpIcZwc2BLDNHFnDURQeGEtmgqj6gZLIkTY0iw7q9Tj5FOyl4AkvEJC5B4CSzaWgey93Wqn1Imt7KI8+H9lApMKziVL1q+K7xAuNkGmx5YOSNlE6rKAPtsIPHZGxR7dch0GURv2jhh0NQYvBRn3ukCjuIO5gx56HLgilq59/o50zZ4NcT7iASF76TcAAAEAC6YxX7rrs8pp13W4YGiJHwFvIO1yXLGOdqu66JM0plO4J1ItV1AQcazOXLiliny3p2/W+wXZZKd5HIRt52YafCA8YNyMk/sF7JcTR4d4z9CfKaAxh0UpzKiAk+0j/Wu3iPoTOsyt7N0j1+dIyrFodY2sKKuBMT4TQ0yqQpbC+IDQv2i1IlZAPneYGfd5MIGygs2QMfaMQ1jWAKJvEO0vstZ7GB6nDAcg4in3ZiBHtomx3PL5w+zg48S4Ed69BiFXLZ1f6MnjpUOP75pD4MP6toS0rgK9b93xCrEQLgm4oD/7TCHHBo2xR7wwcsN2OddtwWsEM2QgOkt/jdCAoVCqwQ==" + & Ssh.pubKey SshDsa "ssh-dss AAAAB3NzaC1kc3MAAAEBAI6ZsoW8a+Zl6NqUf9a4xXSMcV1akJHDEKKBzlI2YZo9gb9YoCf5p9oby8THUSgfh4kse7LJeY7Nb64NR6Y/X7I2/QzbE1HGGl5mMwB6LeUcJ74T3TQAlNEZkGt/MOIVLolJHk049hC09zLpkUDtX8K0t1yaCirC9SxDGLTCLEhvU9+vVdVrdQlKZ9wpLUNbdAzvbra+O/IVvExxDZ9WCHrnfNA8ddVZIGEWMqsoNgiuCxiXpi8qL+noghsSQNFTXwo7W2Vp9zj1JkCt3GtSz5IzEpARQaXEAWNEM0n1nJ686YUOhou64iRM8bPC1lp3QXvvZNgj3m+QHhIempx+de8AAAAVAKB5vUDaZOg14gRn7Bp81ja/ik+RAAABACPH/bPbW912x1NxNiikzGR6clLh+bLpIp8Qie3J7DwOr8oC1QOKjNDK+UgQ7mDQEgr4nGjNKSvpDi4c1QCw4sbLqQgx1y2VhT0SmUPHf5NQFldRQyR/jcevSSwOBxszz3aq9AwHiv9OWaO3XY18suXPouiuPTpIcZwc2BLDNHFnDURQeGEtmgqj6gZLIkTY0iw7q9Tj5FOyl4AkvEJC5B4CSzaWgey93Wqn1Imt7KI8+H9lApMKziVL1q+K7xAuNkGmx5YOSNlE6rKAPtsIPHZGxR7dch0GURv2jhh0NQYvBRn3ukCjuIO5gx56HLgilq59/o50zZ4NcT7iASF76TcAAAEAC6YxX7rrs8pp13W4YGiJHwFvIO1yXLGOdqu66JM0plO4J1ItV1AQcazOXLiliny3p2/W+wXZZKd5HIRt52YafCA8YNyMk/sF7JcTR4d4z9CfKaAxh0UpzKiAk+0j/Wu3iPoTOsyt7N0j1+dIyrFodY2sKKuBMT4TQ0yqQpbC+IDQv2i1IlZAPneYGfd5MIGygs2QMfaMQ1jWAKJvEO0vstZ7GB6nDAcg4in3ZiBHtomx3PL5w+zg48S4Ed69BiFXLZ1f6MnjpUOP75pD4MP6toS0rgK9b93xCrEQLgm4oD/7TCHHBo2xR7wwcsN2OddtwWsEM2QgOkt/jdCAoVCqwQ==" , host "github.com" - & sshPubKey "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAq2A7hRGmdnm9tUDbO9IDSwBK6TbQa+PXYPCPy6rbTrTtw7PHkccKrpp0yVhp5HdEIcKr6pLlVDBfOLX9QUsyCOV0wzfjIJNlGEYsdlLJizHhbn2mUjvSAHQqZETYP81eFzLQNnPHt4EVVUh7VfDESU84KezmD5QlWpXLmvU31/yMf+Se8xhHTvKSCZIFImWwoG6mbUoWf9nzpIoaSjB+weqqUUmpaaasXVal72J+UX2B+2RPW3RcT0eOzQgqlJL3RKrTJvdsjE3JEAvGq3lGHSZXy28G3skua2SmVi/w4yCE6gbODqnTWlg7+wC604ydGXA8VJiS5ap43JXiUFFAaQ==" + & Ssh.pubKey SshRsa "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAq2A7hRGmdnm9tUDbO9IDSwBK6TbQa+PXYPCPy6rbTrTtw7PHkccKrpp0yVhp5HdEIcKr6pLlVDBfOLX9QUsyCOV0wzfjIJNlGEYsdlLJizHhbn2mUjvSAHQqZETYP81eFzLQNnPHt4EVVUh7VfDESU84KezmD5QlWpXLmvU31/yMf+Se8xhHTvKSCZIFImWwoG6mbUoWf9nzpIoaSjB+weqqUUmpaaasXVal72J+UX2B+2RPW3RcT0eOzQgqlJL3RKrTJvdsjE3JEAvGq3lGHSZXy28G3skua2SmVi/w4yCE6gbODqnTWlg7+wC604ydGXA8VJiS5ap43JXiUFFAaQ==" , host "ns6.gandi.net" & ipv4 "217.70.177.40" , host "turtle.kitenet.net" @@ -478,15 +486,11 @@ & ipv6 "2001:4978:f:2d9::2" & alias "backup.kitenet.net" & alias "usbackup.kitenet.net" - & sshPubKey "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAokMXQiX/NZjA1UbhMdgAscnS5dsmy+Q7bWrQ6tsTZ/o+6N/T5cbjoBHOdpypXJI3y/PiJTDJaQtXIhLa8gFg/EvxMnMz/KG9skADW1361JmfCc4BxicQIO2IOOe6eilPr+YsnOwiHwL0vpUnuty39cppuMWVD25GzxXlS6KQsLCvXLzxLLuNnGC43UAM0q4UwQxDtAZEK1dH2o3HMWhgMP2qEQupc24dbhpO3ecxh2C9678a3oGDuDuNf7mLp3s7ptj5qF3onitpJ82U5o7VajaHoygMaSRFeWxP2c13eM57j3bLdLwxVXFhePcKXARu1iuFTLS5uUf3hN6MkQcOGw==" - , host "old.kitenet.net" - & ipv4 "80.68.85.49" + & Ssh.pubKey SshRsa "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAokMXQiX/NZjA1UbhMdgAscnS5dsmy+Q7bWrQ6tsTZ/o+6N/T5cbjoBHOdpypXJI3y/PiJTDJaQtXIhLa8gFg/EvxMnMz/KG9skADW1361JmfCc4BxicQIO2IOOe6eilPr+YsnOwiHwL0vpUnuty39cppuMWVD25GzxXlS6KQsLCvXLzxLLuNnGC43UAM0q4UwQxDtAZEK1dH2o3HMWhgMP2qEQupc24dbhpO3ecxh2C9678a3oGDuDuNf7mLp3s7ptj5qF3onitpJ82U5o7VajaHoygMaSRFeWxP2c13eM57j3bLdLwxVXFhePcKXARu1iuFTLS5uUf3hN6MkQcOGw==" , host "mouse.kitenet.net" & ipv6 "2001:4830:1600:492::2" , host "beaver.kitenet.net" & ipv6 "2001:4830:1600:195::2" - , host "hydra.kitenet.net" - & ipv4 "192.25.206.60" , host "branchable.com" & ipv4 "66.228.46.55" & ipv6 "2600:3c03::f03c:91ff:fedf:c0e5" diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,47 @@ +propellor (1.3.2) unstable; urgency=medium + + * SSHFP records are also generated for CNAMES of hosts. + * Merge Utiity modules from git-annex. + * Ignore bogus DNS when spinning the local host. + + -- Joey Hess Thu, 15 Jan 2015 14:02:07 -0400 + +propellor (1.3.1) unstable; urgency=medium + + * Fix bug that prevented deploying ssh host keys when the file for the + key didn't already exist. + * DNS records for hosts with known ssh public keys now automatically + include SSHFP records. + + -- Joey Hess Sun, 04 Jan 2015 19:51:34 -0400 + +propellor (1.3.0) unstable; urgency=medium + + * --spin checks if the DNS matches any configured IP address property + of the host, and if not, sshes to the host by IP address. + * Detect #774376 and refuse to use docker if the system is so broken + that docker exec doesn't enter a chroot. + * Update intermediary propellor in --spin --via + * Added support for DNSSEC. + * Ssh.hostKey and Ssh.hostKeys no longer install public keys from + the privdata. Instead, the public keys are included in the + configuration. (API change) + * Ssh.hostKeys now removes any host keys of types that the host is not + configured to have. + * sshPubKey is renamed to Ssh.pubKey, and has an added SshKeyType + parameter. (API change) + * CloudAtCost.deCruft no longer forces randomHostKeys. + * Fix build with process 1.2.1.0. + + -- Joey Hess Sun, 04 Jan 2015 17:17:44 -0400 + +propellor (1.2.2) unstable; urgency=medium + + * Revert ensureProperty warning message, too many false positives in places + where Info is correctly propigated. Better approach needed. + + -- Joey Hess Sun, 21 Dec 2014 21:41:11 -0400 + propellor (1.2.1) unstable; urgency=medium * Added CryptPassword to PrivDataField, for password hashes as produced diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -17,7 +17,7 @@ libghc-mtl-dev, libghc-monadcatchio-transformers-dev, Maintainer: Gergely Nagy -Standards-Version: 3.9.5 +Standards-Version: 3.9.6 Vcs-Git: git://git.kitenet.net/propellor Homepage: http://propellor.branchable.com/ diff --git a/propellor.cabal b/propellor.cabal --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 1.2.1 +Version: 1.3.2 Cabal-Version: >= 1.6 License: BSD3 Maintainer: Joey Hess @@ -77,6 +77,7 @@ Propellor.Property.Cron Propellor.Property.Debootstrap Propellor.Property.Dns + Propellor.Property.DnsSec Propellor.Property.Docker Propellor.Property.File Propellor.Property.Firewall @@ -154,4 +155,4 @@ source-repository head type: git - location: git://git.kitenet.net/propellor.git + location: git://git.joeyh.name/propellor.git diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -54,7 +54,6 @@ go ("--help":_) = do usage stdout exitFailure - go ("--update":_:[]) = return $ Update Nothing go ("--boot":_:[]) = return $ Update Nothing -- for back-compat go ("--serialized":s:[]) = serialized Serialized s go ("--continue":s:[]) = serialized Continue s @@ -98,8 +97,9 @@ go _ (DockerChain hn cid) = Docker.chain hostlist hn cid go _ (DockerInit hn) = Docker.init hn go _ (GitPush fin fout) = gitPushHelper fin fout + go _ (Relay h) = forceConsole >> updateFirst (Update (Just h)) (update (Just h)) go _ (Update Nothing) = forceConsole >> fetchFirst (onlyprocess (update Nothing)) - go _ (Update (Just h)) = forceConsole >> fetchFirst (update (Just h)) + go _ (Update (Just h)) = update (Just h) go _ Merge = mergeSpin go True cmdline@(Spin _ _) = buildFirst cmdline $ go False cmdline go True cmdline = updateFirst cmdline $ go False cmdline diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -23,7 +23,6 @@ import System.Directory import Propellor.Types -import Propellor.Types.Empty import Propellor.Message import Propellor.Exception import Propellor.Info @@ -36,7 +35,7 @@ mainProperties :: Host -> IO () mainProperties host = do ret <- runPropellor host $ - ensureProperties [Property "overall" (ensurePropertiesWith ensureProperty' $ hostProperties host) mempty] + ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty] h <- mkMessageHandle whenConsole h $ setTitle "propellor: done" @@ -63,35 +62,22 @@ -- | For when code running in the Propellor monad needs to ensure a -- Property. --- --- Note that any info of the Property is not propigated out to --- the enclosing Property, and so will not be available for propellor to --- use. A warning message will be printed if this is detected. ensureProperty :: Property -> Propellor Result -ensureProperty p = do - unless (isEmpty (getInfo p)) $ - warningMessage $ "ensureProperty called on " ++ show p ++ "; will not propigate its info: " ++ show (getInfo p) - ensureProperty' p - -ensureProperty' :: Property -> Propellor Result -ensureProperty' = catchPropellor . propertySatisfy +ensureProperty = catchPropellor . propertySatisfy -- | Ensures a list of Properties, with a display of each as it runs. ensureProperties :: [Property] -> Propellor Result -ensureProperties = ensurePropertiesWith ensureProperty - -ensurePropertiesWith :: (Property -> Propellor Result) -> [Property] -> Propellor Result -ensurePropertiesWith a ps = ensure ps NoChange +ensureProperties ps = ensure ps NoChange where ensure [] rs = return rs ensure (p:ls) rs = do hn <- asks hostName - r <- actionMessageOn hn (propertyDesc p) (a p) + r <- actionMessageOn hn (propertyDesc p) (ensureProperty p) ensure ls (r <> rs) -- | Lifts an action into a different host. -- --- For example, `fromHost hosts "otherhost" getSshPubKey` +-- For example, `fromHost hosts "otherhost" getPubKey` fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a) fromHost l hn getter = case findHost l hn of Nothing -> return Nothing diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -26,8 +26,13 @@ -- | Indidate that a host has an A record in the DNS. -- --- TODO check at run time if the host really has this address. --- (Can't change the host's address, but as a sanity check.) +-- When propellor is used to deploy a DNS server for a domain, +-- the hosts in the domain are found by looking for these +-- and similar properites. +-- +-- When propellor --spin is used to deploy a host, it checks +-- if the host's IP Property matches the DNS. If the DNS is missing or +-- out of date, the host will instead be contacted directly by IP address. ipv4 :: String -> Property ipv4 = addDNS . Address . IPv4 @@ -59,17 +64,12 @@ rdesc (NS d) = unwords ["NS", ddesc d] rdesc (TXT s) = unwords ["TXT", s] rdesc (SRV x y z d) = unwords ["SRV", show x, show y, show z, ddesc d] + rdesc (SSHFP x y s) = unwords ["SSHFP", show x, show y, s] + rdesc (INCLUDE f) = unwords ["$INCLUDE", f] ddesc (AbsDomain domain) = domain ddesc (RelDomain domain) = domain ddesc RootDomain = "@" - -sshPubKey :: String -> Property -sshPubKey k = pureInfoProperty ("ssh pubkey known") $ - mempty { _sshPubKey = Val k } - -getSshPubKey :: Propellor (Maybe String) -getSshPubKey = askInfo _sshPubKey hostMap :: [Host] -> M.Map HostName Host hostMap l = M.fromList $ zip (map hostName l) l diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -55,7 +55,7 @@ -> Property withPrivData s = withPrivData' snd [s] --- Like withPrivData, but here any of a list of PrivDataFields can be used. +-- Like withPrivData, but here any one of a list of PrivDataFields can be used. withSomePrivData :: (IsContext c, IsPrivDataSource s) => [s] @@ -83,7 +83,7 @@ warningMessage $ "Missing privdata " ++ intercalate " or " fieldnames ++ " (for " ++ cname ++ ")" liftIO $ putStrLn $ "Fix this by running:" liftIO $ forM_ srclist $ \src -> do - putStrLn $ " propellor --set '" ++ show (privDataField src) ++ "' '" ++ cname ++ "'" + putStrLn $ " propellor --set '" ++ show (privDataField src) ++ "' '" ++ cname ++ "' \\" maybe noop (\d -> putStrLn $ " " ++ d) (describePrivDataSource src) putStrLn "" return FailedChange diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -26,8 +26,7 @@ propertyList desc ps = Property desc (ensureProperties ps) (combineInfos ps) -- | Combines a list of properties, resulting in one property that --- ensures each in turn. Does not stop on failure; does propigate --- overall success/failure. +-- ensures each in turn. Stops if a property fails. combineProperties :: Desc -> [Property] -> Property combineProperties desc ps = Property desc (go ps NoChange) (combineInfos ps) where diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -1,6 +1,7 @@ module Propellor.Property.Dns ( module Propellor.Types.Dns, primary, + signedPrimary, secondary, secondaryFor, mkSOA, @@ -16,7 +17,10 @@ import Propellor.Types.Dns import Propellor.Property.File import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Ssh as Ssh import qualified Propellor.Property.Service as Service +import Propellor.Property.Scheduled +import Propellor.Property.DnsSec import Utility.Applicative import qualified Data.Map as M @@ -35,6 +39,9 @@ -- Will cause that hostmame and its alias to appear in the zone file, -- with the configured IP address. -- +-- Also, if a host has a ssh public key configured, a SSHFP record will +-- be automatically generated for it. +-- -- The [(BindDomain, Record)] list can be used for additional records -- that cannot be configured elsewhere. This often includes NS records, -- TXT records and perhaps CNAMEs pointing at hosts that propellor does @@ -53,28 +60,40 @@ primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty primary hosts domain soa rs = RevertableProperty setup cleanup where - setup = withwarnings (check needupdate baseprop) - `requires` servingZones + setup = setupPrimary zonefile id hosts domain soa rs `onChange` Service.reloaded "bind9" - cleanup = check (doesFileExist zonefile) $ - property ("removed dns primary for " ++ domain) - (makeChange $ removeZoneFile zonefile) - `requires` namedConfWritten - `onChange` Service.reloaded "bind9" + cleanup = cleanupPrimary zonefile domain + `onChange` Service.reloaded "bind9" - (partialzone, zonewarnings) = genZone hosts domain soa - zone = partialzone { zHosts = zHosts partialzone ++ rs } zonefile = "/etc/bind/propellor/db." ++ domain - baseprop = Property ("dns primary for " ++ domain) - (makeChange $ writeZoneFile zone zonefile) + +setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property +setupPrimary zonefile mknamedconffile hosts domain soa rs = + withwarnings baseprop + `requires` servingZones + where + hostmap = hostMap hosts + -- Known hosts with hostname located in the domain. + indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap + + (partialzone, zonewarnings) = genZone indomain hostmap domain soa + baseprop = Property ("dns primary for " ++ domain) satisfy (addNamedConf conf) - withwarnings p = adjustProperty p $ \satisfy -> do + satisfy = do + sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap) + let zone = partialzone + { zHosts = zHosts partialzone ++ rs ++ sshfps } + ifM (liftIO $ needupdate zone) + ( makeChange $ writeZoneFile zone zonefile + , noChange + ) + withwarnings p = adjustProperty p $ \a -> do mapM_ warningMessage $ zonewarnings ++ secondarywarnings - satisfy + a conf = NamedConf { confDomain = domain , confDnsServerType = Master - , confFile = zonefile + , confFile = mknamedconffile zonefile , confMasters = [] , confAllowTransfer = nub $ concatMap (\h -> hostAddresses h hosts) $ @@ -87,7 +106,7 @@ nssecondaries = mapMaybe (domainHostName <=< getNS) rootRecords rootRecords = map snd $ filter (\(d, _r) -> d == RootDomain || d == AbsDomain domain) rs - needupdate = do + needupdate zone = do v <- readZonePropellorFile zonefile return $ case v of Nothing -> True @@ -97,6 +116,63 @@ z = zone { zSOA = (zSOA zone) { sSerial = oldserial } } in z /= oldzone || oldserial < sSerial (zSOA zone) + +cleanupPrimary :: FilePath -> Domain -> Property +cleanupPrimary zonefile domain = check (doesFileExist zonefile) $ + property ("removed dns primary for " ++ domain) + (makeChange $ removeZoneFile zonefile) + `requires` namedConfWritten + +-- | Primary dns server for a domain, secured with DNSSEC. +-- +-- This is like `primary`, except the resulting zone +-- file is signed. +-- The Zone Signing Key (ZSK) and Key Signing Key (KSK) +-- used in signing it are taken from the PrivData. +-- +-- As a side effect of signing the zone, a +-- +-- file will be created. This file contains the DS records +-- which need to be communicated to your domain registrar +-- to make DNSSEC be used for your domain. Doing so is outside +-- the scope of propellor (currently). See for example the tutorial +-- +-- +-- The 'Recurrance' controls how frequently the signature +-- should be regenerated, using a new random salt, to prevent +-- zone walking attacks. `Weekly Nothing` is a reasonable choice. +-- +-- To transition from 'primary' to 'signedPrimary', you can revert +-- the 'primary' property, and add this property. +-- +-- Note that DNSSEC zone files use a serial number based on the unix epoch. +-- This is different from the serial number used by 'primary', so if you +-- want to later disable DNSSEC you will need to adjust the serial number +-- passed to mkSOA to ensure it is larger. +signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty +signedPrimary recurrance hosts domain soa rs = RevertableProperty setup cleanup + where + setup = combineProperties ("dns primary for " ++ domain ++ " (signed)") + [ setupPrimary zonefile signedZoneFile hosts domain soa rs' + , toProp (zoneSigned domain zonefile) + , forceZoneSigned domain zonefile `period` recurrance + ] + `onChange` Service.reloaded "bind9" + + cleanup = cleanupPrimary zonefile domain + `onChange` toProp (revert (zoneSigned domain zonefile)) + `onChange` Service.reloaded "bind9" + + -- Include the public keys into the zone file. + rs' = include PubKSK : include PubZSK : rs + include k = (RootDomain, INCLUDE (keyFn domain k)) + + -- Put DNSSEC zone files in a different directory than is used for + -- the regular ones. This allows 'primary' to be reverted and + -- 'signedPrimary' enabled, without the reverted property stomping + -- on the new one's settings. + zonefile = "/etc/bind/propellor/dnssec/db." ++ domain + -- | Secondary dns server for a domain. -- -- The primary server is determined by looking at the properties of other @@ -216,6 +292,8 @@ rField (NS _) = "NS" rField (TXT _) = "TXT" rField (SRV _ _ _ _) = "SRV" +rField (SSHFP _ _ _) = "SSHFP" +rField (INCLUDE _) = "$INCLUDE" rValue :: Record -> String rValue (Address (IPv4 addr)) = addr @@ -229,6 +307,12 @@ , show port , dValue target ] +rValue (SSHFP x y s) = unwords + [ show x + , show y + , s + ] +rValue (INCLUDE f) = f rValue (TXT s) = [q] ++ filter (/= q) s ++ [q] where q = '"' @@ -294,12 +378,16 @@ header = com $ "BIND zone file for " ++ zdomain ++ ". Generated by propellor, do not edit." genRecord :: Domain -> (BindDomain, Record) -> String +genRecord _ (_, record@(INCLUDE _)) = intercalate "\t" + [ rField record + , rValue record + ] genRecord zdomain (domain, record) = intercalate "\t" - [ domainHost zdomain domain - , "IN" - , rField record - , rValue record - ] + [ domainHost zdomain domain + , "IN" + , rField record + , rValue record + ] genSOA :: SOA -> [String] genSOA soa = @@ -331,19 +419,17 @@ -- | Generates a Zone for a particular Domain from the DNS properies of all -- hosts that propellor knows about that are in that Domain. -genZone :: [Host] -> Domain -> SOA -> (Zone, [WarningMessage]) -genZone hosts zdomain soa = +-- +-- Does not include SSHFP records. +genZone :: [Host] -> M.Map HostName Host -> Domain -> SOA -> (Zone, [WarningMessage]) +genZone inzdomain hostmap zdomain soa = let (warnings, zhosts) = partitionEithers $ concat $ map concat [ map hostips inzdomain , map hostrecords inzdomain - , map addcnames (M.elems m) + , map addcnames (M.elems hostmap) ] in (Zone zdomain soa (simplify zhosts), warnings) where - m = hostMap hosts - -- Known hosts with hostname located in the zone's domain. - inzdomain = M.elems $ M.filterWithKey (\hn _ -> inDomain zdomain $ AbsDomain $ hn) m - -- Each host with a hostname located in the zdomain -- should have 1 or more IPAddrs in its Info. -- @@ -423,3 +509,32 @@ getNamedConf :: Propellor (M.Map Domain NamedConf) getNamedConf = asks $ fromNamedConfMap . _namedconf . hostInfo + +-- | Generates SSHFP records for hosts in the domain (or with CNAMES +-- in the domain) that have configured ssh public keys. +-- +-- This is done using ssh-keygen, so sadly needs IO. +genSSHFP :: Domain -> Host -> Propellor [(BindDomain, Record)] +genSSHFP domain h = concatMap mk . concat <$> (gen =<< get) + where + get = fromHost [h] hostname Ssh.getPubKey + gen = liftIO . mapM genSSHFP' . M.elems . fromMaybe M.empty + mk r = mapMaybe (\d -> if inDomain domain d then Just (d, r) else Nothing) + (AbsDomain hostname : cnames) + cnames = mapMaybe getCNAME $ S.toList $ _dns info + hostname = hostName h + info = hostInfo h + +genSSHFP' :: String -> IO [Record] +genSSHFP' pubkey = withTmpFile "sshfp" $ \tmp tmph -> do + hPutStrLn tmph pubkey + hClose tmph + s <- catchDefaultIO "" $ + readProcess "ssh-keygen" ["-r", "dummy", "-f", tmp] + return $ mapMaybe (parse . words) $ lines s + where + parse ("dummy":"IN":"SSHFP":x:y:s:[]) = do + x' <- readish x + y' <- readish y + return $ SSHFP x' y' s + parse _ = Nothing diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/DnsSec.hs @@ -0,0 +1,122 @@ +module Propellor.Property.DnsSec where + +import Propellor +import qualified Propellor.Property.File as File + +-- | Puts the DNSSEC key files in place from PrivData. +-- +-- signedPrimary uses this, so this property does not normally need to be +-- used directly. +keysInstalled :: Domain -> RevertableProperty +keysInstalled domain = RevertableProperty setup cleanup + where + setup = propertyList "DNSSEC keys installed" $ + map installkey keys + + cleanup = propertyList "DNSSEC keys removed" $ + map (File.notPresent . keyFn domain) keys + + installkey k = writer (keysrc k) (keyFn domain k) (Context domain) + where + writer + | isPublic k = File.hasPrivContentExposedFrom + | otherwise = File.hasPrivContentFrom + + keys = [ PubZSK, PrivZSK, PubKSK, PrivKSK ] + + keysrc k = PrivDataSource (DnsSec k) $ unwords + [ "The file with extension" + , keyExt k + , "created by running:" + , if isZoneSigningKey k + then "dnssec-keygen -a RSASHA256 -b 2048 -n ZONE " ++ domain + else "dnssec-keygen -f KSK -a RSASHA256 -b 4096 -n ZONE " ++ domain + ] + +-- | Uses dnssec-signzone to sign a domain's zone file. +-- +-- signedPrimary uses this, so this property does not normally need to be +-- used directly. +zoneSigned :: Domain -> FilePath -> RevertableProperty +zoneSigned domain zonefile = RevertableProperty setup cleanup + where + setup = check needupdate (forceZoneSigned domain zonefile) + `requires` toProp (keysInstalled domain) + + cleanup = combineProperties ("removed signed zone for " ++ domain) + [ File.notPresent (signedZoneFile zonefile) + , File.notPresent dssetfile + , toProp (revert (keysInstalled domain)) + ] + + dssetfile = dir "-" ++ domain ++ "." + dir = takeDirectory zonefile + + -- Need to update the signed zone file if the zone file or + -- any of the keys have a newer timestamp. + needupdate = do + v <- catchMaybeIO $ getModificationTime (signedZoneFile zonefile) + case v of + Nothing -> return True + Just t1 -> anyM (newerthan t1) $ + zonefile : map (keyFn domain) [minBound..maxBound] + + newerthan t1 f = do + t2 <- getModificationTime f + return (t2 >= t1) + +forceZoneSigned :: Domain -> FilePath -> Property +forceZoneSigned domain zonefile = property ("zone signed for " ++ domain) $ liftIO $ do + salt <- take 16 <$> saltSha1 + let p = proc "dnssec-signzone" + [ "-A" + , "-3", salt + -- The serial number needs to be increased each time the + -- zone is resigned, even if there are no other changes, + -- so that it will propigate to secondaries. So, use the + -- unixtime serial format. + , "-N", "unixtime" + , "-o", domain + , zonefile + -- the ordering of these key files does not matter + , keyFn domain PubZSK + , keyFn domain PubKSK + ] + -- Run in the same directory as the zonefile, so it will + -- write the dsset file there. + (_, _, _, h) <- createProcess $ + p { cwd = Just (takeDirectory zonefile) } + ifM (checkSuccessProcess h) + ( return MadeChange + , return FailedChange + ) + +saltSha1 :: IO String +saltSha1 = readProcess "sh" + [ "-c" + , "head -c 1024 /dev/urandom | sha1sum | cut -d ' ' -f 1" + ] + +-- | The file used for a given key. +keyFn :: Domain -> DnsSecKey -> FilePath +keyFn domain k = "/etc/bind/propellor/dnssec" concat + [ "K" ++ domain ++ "." + , if isZoneSigningKey k then "ZSK" else "KSK" + , keyExt k + ] + +-- | These are the extensions that dnssec-keygen looks for. +keyExt :: DnsSecKey -> String +keyExt k + | isPublic k = ".key" + | otherwise = ".private" + +isPublic :: DnsSecKey -> Bool +isPublic k = k `elem` [PubZSK, PubKSK] + +isZoneSigningKey :: DnsSecKey -> Bool +isZoneSigningKey k = k `elem` [PubZSK, PrivZSK] + +-- | dnssec-signzone makes a .signed file +signedZoneFile :: FilePath -> FilePath +signedZoneFile zonefile = zonefile ++ ".signed" 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 @@ -351,29 +351,44 @@ -- Check if the ident has changed; if so the -- parameters of the container differ and it must -- be restarted. - checkident runningident + checkident (Right runningident) | runningident == Just ident = noChange | otherwise = do void $ liftIO $ stopContainer cid restartcontainer + checkident (Left errmsg) = do + warningMessage errmsg + return FailedChange restartcontainer = do oldimage <- liftIO $ fromMaybe image <$> commitContainer cid void $ liftIO $ removeContainer cid go oldimage - getrunningident = readish - <$> readProcess' (inContainerProcess cid [] ["cat", propellorIdent]) + getrunningident = withTmpFile "dockerrunsane" $ \t h -> do + -- detect #774376 which caused docker exec to not enter + -- the container namespace, and be able to access files + -- outside + hClose h + void . checkSuccessProcess . processHandle =<< + createProcess (inContainerProcess cid [] + ["rm", "-f", t]) + ifM (doesFileExist t) + ( Right . readish <$> + readProcess' (inContainerProcess cid [] + ["cat", propellorIdent]) + , return $ Left "docker exec failed to enter chroot properly (maybe an old kernel version?)" + ) - retry :: Int -> IO (Maybe a) -> IO (Maybe a) - retry 0 _ = return Nothing + retry :: Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a)) + retry 0 _ = return (Right Nothing) retry n a = do v <- a case v of - Just _ -> return v - Nothing -> do - threadDelaySeconds (Seconds 1) + Right Nothing -> do + threadDelaySeconds (Seconds 1) retry (n-1) a + _ -> return v go img = do liftIO $ do @@ -456,7 +471,8 @@ go cid h = do changeWorkingDirectory localdir onlyProcess (provisioningLock cid) $ do - r <- runPropellor h $ ensureProperties $ hostProperties h + r <- runPropellor h $ ensureProperties $ + hostProperties h putStrLn $ "\n" ++ show r stopContainer :: ContainerId -> IO Bool diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -18,18 +18,26 @@ -- The file's permissions are preserved if the file already existed. -- Otherwise, they're set to 600. hasPrivContent :: IsContext c => FilePath -> c -> Property -hasPrivContent = hasPrivContent' writeFileProtected +hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f +-- | Like hasPrivContent, but allows specifying a source +-- for PrivData, rather than using PrivDataSourceFile. +hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property +hasPrivContentFrom = hasPrivContent' writeFileProtected + -- | Leaves the file at its default or current mode, -- allowing "private" data to be read. -- -- Use with caution! hasPrivContentExposed :: IsContext c => FilePath -> c -> Property -hasPrivContentExposed = hasPrivContent' writeFile +hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f -hasPrivContent' :: IsContext c => (String -> FilePath -> IO ()) -> FilePath -> c -> Property -hasPrivContent' writer f context = - withPrivData (PrivDataSourceFile (PrivFile f) f) context $ \getcontent -> +hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property +hasPrivContentExposedFrom = hasPrivContent' writeFile + +hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (String -> FilePath -> IO ()) -> s -> FilePath -> c -> Property +hasPrivContent' writer source f context = + withPrivData source context $ \getcontent -> property desc $ getcontent $ \privcontent -> ensureProperty $ fileProperty' writer desc (\_oldcontent -> lines privcontent) f diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs --- a/src/Propellor/Property/HostingProvider/CloudAtCost.hs +++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs @@ -3,14 +3,12 @@ import Propellor import qualified Propellor.Property.Hostname as Hostname import qualified Propellor.Property.File as File -import qualified Propellor.Property.Ssh as Ssh import qualified Propellor.Property.User as User -- Clean up a system as installed by cloudatcost.com decruft :: Property decruft = propertyList "cloudatcost cleanup" [ Hostname.sane - , Ssh.randomHostKeys , "worked around grub/lvm boot bug #743126" ==> "/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true" `onChange` cmdProperty "update-grub" [] @@ -18,6 +16,7 @@ , combineProperties "nuked cloudatcost cruft" [ File.notPresent "/etc/rc.local" , File.notPresent "/etc/init.d/S97-setup.sh" + , File.notPresent "/zang-debian.sh" , User.nuked "user" User.YesReallyDeleteHome ] ] 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 @@ -17,7 +17,6 @@ import qualified Propellor.Property.Postfix as Postfix import Utility.SafeCommand import Utility.FileMode -import Utility.Path import Data.List import System.Posix.Files @@ -88,9 +87,6 @@ , "dpkg -i ../" ++ pkg ++ "_*.deb || true" , "apt-get -fy install" -- dependencies , "rm -rf /root/tmp/oldusenet" - -- screen fails unless the directory has this mode. - -- not sure what's going on. - , "chmod 777 /var/run/screen" ] `describe` "olduse.net built" ] @@ -196,6 +192,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex") [ Git.cloned "joey" origin dir Nothing `onChange` setup + , alias hn , postupdatehook `File.hasContent` [ "#!/bin/sh" , "exec git update-server-info" @@ -212,6 +209,7 @@ , "git config annex.uuid " ++ shellEscape uuid ] ++ map addremote remotes ++ [ "git annex get" + , "git update-server-info" ] addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $ @@ -314,6 +312,7 @@ "./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss") -- Work around for expired ssl cert. +-- (no longer expired, TODO remove this and change urls) pumpRss :: Property pumpRss = Cron.job "pump rss" "15 * * * *" "joey" "/srv/web/tmp.kitenet.net/" "wget https://pump2rss.com/feed/joeyh@identi.ca.atom -O pump.atom --no-check-certificate 2>/dev/null" @@ -322,7 +321,7 @@ ircBouncer = propertyList "IRC bouncer" [ Apt.installed ["znc"] , User.accountFor "znc" - , File.dirExists (parentDir conf) + , File.dirExists (takeDirectory conf) , File.hasPrivContent conf anyContext , File.ownerGroup conf "znc" "znc" , Cron.job "znconboot" "@reboot" "znc" "~" "znc" @@ -353,13 +352,34 @@ in File.hasPrivContent f anyContext `onChange` File.ownerGroup f "joey" "joey" , Cron.niceJob "github-backup run" "30 4 * * *" "joey" - "/home/joey/lib/backup" $ intercalate "&&" + "/home/joey/lib/backup" $ intercalate "&&" $ [ "mkdir -p github" , "cd github" - , ". $HOME/.github-keys && github-backup joeyh" + , ". $HOME/.github-keys" + , "github-backup joeyh" ] + , Cron.niceJob "gitriddance" "30 4 * * *" "joey" + "/home/joey/lib/backup" $ intercalate "&&" $ + [ "cd github" + , ". $HOME/.github-keys" + ] ++ map gitriddance githubMirrors ] + where + gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")" +-- these repos are only mirrored on github, I don't want +-- all the proprietary features +githubMirrors :: [(String, String)] +githubMirrors = + [ ("ikiwiki", plzuseurl "http://ikiwiki.info/todo/") + , ("git-annex", plzuseurl "http://git-annex.branchable.com/todo/") + , ("myrepos", plzuseurl "http://myrepos.branchable.com/todo/") + , ("propellor", plzuseurl "http://propellor.branchable.com/todo/") + , ("etckeeper", plzuseurl "http://etckeeper.branchable.com/todo/") + ] + where + plzuseurl u = "please submit changes to " ++ u ++ " instead of using github pull requests" + rsyncNetBackup :: [Host] -> Property rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" "30 5 * * *" "joey" "/home/joey/lib/backup" "mkdir -p rsync.net && rsync --delete -az 2318@usw-s002.rsync.net: rsync.net" @@ -425,6 +445,8 @@ `describe` "amavisd-milter configured for postfix" , Apt.serviceInstalledRunning "clamav-freshclam" + , dkimInstalled + , Apt.installed ["maildrop"] , "/etc/maildroprc" `File.hasContent` [ "# Global maildrop filter file (deployed with propellor)" @@ -443,8 +465,7 @@ , "/etc/aliases" `File.hasPrivContentExposed` ctx `onChange` Postfix.newaliases , hasJoeyCAChain - , "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx - , "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx + , hasPostfixCert ctx , "/etc/postfix/mydomain" `File.containsLines` [ "/.*\\.kitenet\\.net/\tOK" @@ -455,13 +476,13 @@ `describe` "postfix mydomain file configured" , "/etc/postfix/obscure_client_relay.pcre" `File.hasContent` -- Remove received lines for mails relayed from trusted - -- clients. These can be a privacy vilation, or trigger + -- clients. These can be a privacy violation, or trigger -- spam filters. [ "/^Received: from ([^.]+)\\.kitenet\\.net.*using TLS.*by kitenet\\.net \\(([^)]+)\\) with (E?SMTPS?A?) id ([A-F[:digit:]]+)(.*)/ IGNORE" -- Munge local Received line for postfix running on a -- trusted client that relays through. These can trigger -- spam filters. - , "/^Received: by ([^.]+)\\.kitenet\\.net.*/ REPLACE Received: by kitenet.net" + , "/^Received: by ([^.]+)\\.kitenet\\.net.*/ REPLACE X-Question: 42" ] `onChange` Postfix.reloaded `describe` "postfix obscure_client_relay file configured" @@ -493,9 +514,13 @@ , "# Enable postgrey." , "smtpd_recipient_restrictions = permit_tls_clientcerts,permit_mynetworks,reject_unauth_destination,check_policy_service inet:127.0.0.1:10023" - , "# Enable spamass-milter and amavis-milter." - , "smtpd_milters = unix:/spamass/spamass.sock unix:amavis/amavis.sock" + , "# Enable spamass-milter, amavis-milter, opendkim" + , "smtpd_milters = unix:/spamass/spamass.sock unix:amavis/amavis.sock inet:localhost:8891" + , "# opendkim is used for outgoing mail" + , "non_smtpd_milters = inet:localhost:8891" , "milter_connect_macros = j {daemon_name} v {if_name} _" + , "# If a milter is broken, fall back to just accepting mail." + , "milter_default_action = accept" , "# TLS setup -- server" , "smtpd_tls_CAfile = /etc/ssl/certs/joeyca.pem" @@ -563,9 +588,69 @@ pinescript = "/usr/local/bin/pine" dovecotusers = "/etc/dovecot/users" +-- Configures postfix to relay outgoing mail to kitenet.net, with +-- verification via tls cert. +postfixClientRelay :: Context -> Property +postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines` + [ "relayhost = kitenet.net" + , "smtp_tls_CAfile = /etc/ssl/certs/joeyca.pem" + , "smtp_tls_cert_file = /etc/ssl/certs/postfix.pem" + , "smtp_tls_key_file = /etc/ssl/private/postfix.pem" + , "smtp_tls_loglevel = 0" + , "smtp_use_tls = yes" + ] + `describe` "postfix client relay" + `onChange` Postfix.dedupMainCf + `onChange` Postfix.reloaded + `requires` hasJoeyCAChain + `requires` hasPostfixCert ctx + +-- Configures postfix to have the dkim milter, and no other milters. +dkimMilter :: Property +dkimMilter = Postfix.mainCfFile `File.containsLines` + [ "smtpd_milters = inet:localhost:8891" + , "non_smtpd_milters = inet:localhost:8891" + , "milter_default_action = accept" + ] + `describe` "postfix dkim milter" + `onChange` Postfix.dedupMainCf + `onChange` Postfix.reloaded + `requires` dkimInstalled + +-- This does not configure postfix to use the dkim milter, +-- nor does it set up domainkey DNS. +dkimInstalled :: Property +dkimInstalled = propertyList "opendkim installed" + [ Apt.serviceInstalledRunning "opendkim" + , File.dirExists "/etc/mail" + , File.hasPrivContent "/etc/mail/dkim.key" (Context "kitenet.net") + , File.ownerGroup "/etc/mail/dkim.key" "opendkim" "opendkim" + , "/etc/default/opendkim" `File.containsLine` + "SOCKET=\"inet:8891@localhost\"" + , "/etc/opendkim.conf" `File.containsLines` + [ "KeyFile /etc/mail/dkim.key" + , "SubDomains yes" + , "Domain *" + , "Selector mail" + ] + ] + `onChange` Service.restarted "opendkim" + +-- This is the dkim public key, corresponding with /etc/mail/dkim.key +-- This value can be included in a domain's additional records to make +-- it use this domainkey. +domainKey :: (BindDomain, Record) +domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; t=y; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB") + hasJoeyCAChain :: Property hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed` Context "joeyca.pem" + +hasPostfixCert :: Context -> Property +hasPostfixCert ctx = combineProperties "postfix tls cert installed" + [ "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx + , "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx + ] kitenetHttps :: Property kitenetHttps = propertyList "kitenet.net https certs" diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -8,6 +8,8 @@ randomHostKeys, hostKeys, hostKey, + pubKey, + getPubKey, keyImported, knownHost, authorizedKeys, @@ -22,7 +24,10 @@ import Utility.FileMode import System.PosixCompat +import qualified Data.Map as M +type PubKeyText = String + sshBool :: Bool -> String sshBool True = "yes" sshBool False = "no" @@ -79,34 +84,65 @@ ensureProperty $ scriptProperty [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ] --- | Sets all types of ssh host keys from the privdata. -hostKeys :: IsContext c => c -> Property -hostKeys ctx = propertyList "known ssh host keys" - [ hostKey SshDsa ctx - , hostKey SshRsa ctx - , hostKey SshEcdsa ctx - ] +-- | Installs the specified list of ssh host keys. +-- +-- The corresponding private keys come from the privdata. +-- +-- Any host keysthat are not in the list are removed from the host. +hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property +hostKeys ctx l = propertyList desc $ catMaybes $ + map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup] + where + desc = "ssh host keys configured " ++ typelist (map fst l) + typelist tl = "(" ++ unwords (map fromKeyType tl) ++ ")" + alltypes = [minBound..maxBound] + staletypes = let have = map fst l in filter (`notElem` have) alltypes + removestale b = map (File.notPresent . flip keyFile b) staletypes + cleanup + | null staletypes || null l = Nothing + | otherwise = Just $ property ("any other ssh host keys removed " ++ typelist staletypes) $ + ensureProperty $ + combineProperties desc (removestale True ++ removestale False) + `onChange` restarted --- | Sets a single ssh host key from the privdata. -hostKey :: IsContext c => SshKeyType -> c -> Property -hostKey keytype context = combineProperties desc - [ installkey (keysrc ".pub" (SshPubKey keytype "")) (install writeFile ".pub") - , installkey (keysrc "" (SshPrivKey keytype "")) (install writeFileProtected "") +-- | Installs a single ssh host key of a particular type. +-- +-- The public key is provided to this function; +-- the private key comes from the privdata; +hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property +hostKey context keytype pub = combineProperties desc + [ pubKey keytype pub + , property desc $ install writeFile True pub + , withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey -> + property desc $ getkey $ install writeFileProtected False ] `onChange` restarted where - desc = "known ssh host key (" ++ fromKeyType keytype ++ ")" - installkey p a = withPrivData p context $ \getkey -> - property desc $ getkey a - install writer ext key = do - let f = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext - s <- liftIO $ readFileStrict f + desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")" + install writer ispub key = do + let f = keyFile keytype ispub + s <- liftIO $ catchDefaultIO "" $ readFileStrict f if s == key then noChange else makeChange $ writer f key keysrc ext field = PrivDataSourceFileFromCommand field ("sshkey"++ext) ("ssh-keygen -t " ++ sshKeyTypeParam keytype ++ " -f sshkey") +keyFile :: SshKeyType -> Bool -> FilePath +keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext + where + ext = if ispub then ".pub" else "" + +-- | Indicates the host key that is used by a Host, but does not actually +-- configure the host to use it. Normally this does not need to be used; +-- use 'hostKey' instead. +pubKey :: SshKeyType -> PubKeyText -> Property +pubKey t k = pureInfoProperty ("ssh pubkey known") $ + mempty { _sshPubKey = M.singleton t k } + +getPubKey :: Propellor (M.Map SshKeyType String) +getPubKey = asks (_sshPubKey . hostInfo) + -- | Sets up a user with a ssh private key and public key pair from the -- PrivData. keyImported :: IsContext c => SshKeyType -> UserName -> c -> Property @@ -140,21 +176,23 @@ fromKeyType SshEcdsa = "ecdsa" fromKeyType SshEd25519 = "ed25519" --- | Puts some host's ssh public key into the known_hosts file for a user. +-- | Puts some host's ssh public key(s), as set using 'pubKey', +-- into the known_hosts file for a user. knownHost :: [Host] -> HostName -> UserName -> Property knownHost hosts hn user = property desc $ - go =<< fromHost hosts hn getSshPubKey + go =<< fromHost hosts hn getPubKey where desc = user ++ " knows ssh key for " ++ hn - go (Just (Just k)) = do + go (Just m) | not (M.null m) = do f <- liftIO $ dotFile "known_hosts" user ensureProperty $ combineProperties desc [ File.dirExists (takeDirectory f) - , f `File.containsLine` (hn ++ " " ++ k) + , f `File.containsLines` + (map (\k -> hn ++ " " ++ k) (M.elems m)) , File.ownerGroup f user user ] go _ = do - warningMessage $ "no configred sshPubKey for " ++ hn + warningMessage $ "no configred pubKey for " ++ hn return FailedChange -- | Makes a user have authorized_keys from the PrivData diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs --- a/src/Propellor/Protocol.hs +++ b/src/Propellor/Protocol.hs @@ -41,6 +41,11 @@ sendMarked :: Handle -> Marker -> String -> IO () sendMarked h marker s = do + debug ["sent marked", marker] + sendMarked' h marker s + +sendMarked' :: Handle -> Marker -> String -> IO () +sendMarked' h marker s = do -- Prefix string with newline because sometimes a -- incomplete line has been output, and the marker needs to -- come at the start of a line. @@ -56,9 +61,12 @@ unless (null l) $ hPutStrLn stderr l getMarked h marker - Just v -> return (Just v) + Just v -> do + debug ["received marked", marker] + return (Just v) req :: Stage -> Marker -> (String -> IO ()) -> IO () req stage marker a = do - sendMarked stdout statusMarker (show stage) + debug ["requested marked", marker] + sendMarked' stdout statusMarker (show stage) maybe noop a =<< getMarked stdin marker diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs --- a/src/Propellor/Shim.hs +++ b/src/Propellor/Shim.hs @@ -9,7 +9,6 @@ import Propellor import Utility.LinuxMkLibs import Utility.SafeCommand -import Utility.Path import Utility.FileMode import Utility.FileSystemEncoding @@ -34,7 +33,7 @@ let linker = (dest ++) $ fromMaybe (error "cannot find ld-linux linker") $ headMaybe $ filter ("ld-linux" `isInfixOf`) libs' - let gconvdir = (dest ++) $ parentDir $ + let gconvdir = (dest ++) $ takeDirectory $ fromMaybe (error "cannot find gconv directory") $ headMaybe $ filter ("/gconv/" `isInfixOf`) glibclibs let linkerparams = ["--library-path", intercalate ":" libdirs ] @@ -75,5 +74,5 @@ createLink f dest `catchIO` (const copy) where copy = void $ boolSystem "cp" [Param "-a", Param f, Param dest] - destdir = inTop top $ parentDir f + destdir = inTop top $ takeDirectory f dest = inTop top f diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -14,6 +14,9 @@ import Control.Concurrent.Async import Control.Exception (bracket) import qualified Data.ByteString as B +import qualified Data.Set as S +import qualified Network.BSD as BSD +import Network.Socket (inet_ntoa) import Propellor import Propellor.Protocol @@ -44,17 +47,20 @@ when viarelay $ void $ boolSystem "ssh-add" [] + sshtarget <- ("root@" ++) <$> case relay of + Just r -> pure r + Nothing -> getSshTarget target hst + -- Install, or update the remote propellor. updateServer target relay hst - (proc "ssh" $ cacheparams ++ [user, shellWrap probecmd]) - (proc "ssh" $ cacheparams ++ [user, shellWrap updatecmd]) + (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap probecmd]) + (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap updatecmd]) -- And now we can run it. - unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, shellWrap runcmd])) $ + unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $ error $ "remote propellor failed" where hn = fromMaybe target relay - user = "root@"++hn relaying = relay == Just target viarelay = isJust relay && not relaying @@ -74,7 +80,7 @@ , "if ! test -x ./propellor; then make deps build; fi" , if viarelay then "./propellor --continue " ++ - shellEscape (show (Update (Just target))) + shellEscape (show (Relay target)) -- Still using --boot for back-compat... else "./propellor --boot " ++ target ] @@ -83,6 +89,40 @@ cmd = if viarelay then "--serialized " ++ shellEscape (show (Spin [target] (Just target))) else "--continue " ++ shellEscape (show (SimpleRun target)) + +-- Check if the Host contains an IP address that matches one of the IPs +-- in the DNS for the HostName. If so, the HostName is used as-is, +-- but if the DNS is out of sync with the Host config, or doesn't have +-- the host in it at all, use one of the Host's IPs instead. +getSshTarget :: HostName -> Host -> IO String +getSshTarget target hst + | null configips = return target + | otherwise = go =<< tryIO (BSD.getHostByName target) + where + go (Left e) = useip (show e) + go (Right hostentry) = ifM (anyM matchingconfig (BSD.hostAddresses hostentry)) + ( return target + , do + ips <- mapM inet_ntoa (BSD.hostAddresses hostentry) + useip ("DNS " ++ show ips ++ " vs configured " ++ show configips) + ) + + matchingconfig a = flip elem configips <$> inet_ntoa a + + useip why = case headMaybe configips of + Nothing -> return target + Just ip -> do + -- If we're being asked to run on the local host, + -- ignore DNS. + s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"] + if s == target + then return target + else do + warningMessage $ "DNS seems out of date for " ++ target ++ " (" ++ why ++ "); using IP address from configuration instead." + return ip + + configips = map fromIPAddr $ mapMaybe getIPAddr $ + S.toList $ _dns $ hostInfo hst -- Update the privdata, repo url, and git repo over the ssh -- connection, talking to the user's local propellor instance which is diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -37,6 +37,7 @@ import "mtl" Control.Monad.RWS.Strict import "MonadCatchIO-transformers" Control.Monad.CatchIO import qualified Data.Set as S +import qualified Data.Map as M import qualified Propellor.Types.Dns as Dns import Propellor.Types.OS @@ -165,6 +166,7 @@ | Serialized CmdLine | Continue CmdLine | Update (Maybe HostName) + | Relay HostName | DockerInit HostName | DockerChain HostName String | ChrootChain HostName FilePath Bool Bool @@ -175,7 +177,7 @@ data Info = Info { _os :: Val System , _privDataFields :: S.Set (PrivDataField, HostContext) - , _sshPubKey :: Val String + , _sshPubKey :: M.Map SshKeyType String , _aliases :: S.Set HostName , _dns :: S.Set Dns.Record , _namedconf :: Dns.NamedConfMap @@ -189,7 +191,7 @@ mappend old new = Info { _os = _os old <> _os new , _privDataFields = _privDataFields old <> _privDataFields new - , _sshPubKey = _sshPubKey old <> _sshPubKey new + , _sshPubKey = _sshPubKey new `M.union` _sshPubKey old , _aliases = _aliases old <> _aliases new , _dns = _dns old <> _dns new , _namedconf = _namedconf old <> _namedconf new diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs --- a/src/Propellor/Types/Dns.hs +++ b/src/Propellor/Types/Dns.hs @@ -62,6 +62,8 @@ | NS BindDomain | TXT String | SRV Word16 Word16 Word16 BindDomain + | SSHFP Int Int String + | INCLUDE FilePath deriving (Read, Show, Eq, Ord) getIPAddr :: Record -> Maybe IPAddr diff --git a/src/Propellor/Types/PrivData.hs b/src/Propellor/Types/PrivData.hs --- a/src/Propellor/Types/PrivData.hs +++ b/src/Propellor/Types/PrivData.hs @@ -2,18 +2,19 @@ import Propellor.Types.OS --- | Note that removing or changing field names will break the +-- | Note that removing or changing constructors will break the -- serialized privdata files, so don't do that! --- It's fine to add new fields. +-- It's fine to add new constructors. data PrivDataField = DockerAuthentication | SshPubKey SshKeyType UserName - | SshPrivKey SshKeyType UserName + | SshPrivKey SshKeyType UserName -- ^ For host key, use empty UserName | SshAuthorizedKeys UserName | Password UserName | CryptPassword UserName | PrivFile FilePath | GpgKey + | DnsSec DnsSecKey deriving (Read, Show, Ord, Eq) -- | Combines a PrivDataField with a description of how to generate @@ -49,7 +50,7 @@ -- for the web server serving that domain. Multiple hosts might -- use that privdata. -- --- This appears in serlialized privdata files. +-- This appears in serialized privdata files. newtype Context = Context String deriving (Read, Show, Ord, Eq) @@ -89,7 +90,7 @@ type PrivData = String data SshKeyType = SshRsa | SshDsa | SshEcdsa | SshEd25519 - deriving (Read, Show, Ord, Eq) + deriving (Read, Show, Ord, Eq, Enum, Bounded) -- | Parameter that would be passed to ssh-keygen to generate key of this type sshKeyTypeParam :: SshKeyType -> String @@ -98,3 +99,9 @@ sshKeyTypeParam SshEcdsa = "ECDSA" sshKeyTypeParam SshEd25519 = "ED25519" +data DnsSecKey + = PubZSK -- ^ DNSSEC Zone Signing Key (public) + | PrivZSK -- ^ DNSSEC Zone Signing Key (private) + | PubKSK -- ^ DNSSEC Key Signing Key (public) + | PrivKSK -- ^ DNSSEC Key Signing Key (private) + deriving (Read, Show, Ord, Eq, Bounded, Enum) diff --git a/src/Utility/Applicative.hs b/src/Utility/Applicative.hs --- a/src/Utility/Applicative.hs +++ b/src/Utility/Applicative.hs @@ -1,6 +1,6 @@ {- applicative stuff - - - Copyright 2012 Joey Hess + - Copyright 2012 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Data.hs b/src/Utility/Data.hs --- a/src/Utility/Data.hs +++ b/src/Utility/Data.hs @@ -1,6 +1,6 @@ {- utilities for simple data types - - - Copyright 2013 Joey Hess + - Copyright 2013 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Env.hs b/src/Utility/Env.hs --- a/src/Utility/Env.hs +++ b/src/Utility/Env.hs @@ -1,6 +1,6 @@ {- portable environment variables - - - Copyright 2013 Joey Hess + - Copyright 2013 Joey Hess - - License: BSD-2-clause -} @@ -14,6 +14,7 @@ import Control.Applicative import Data.Maybe import qualified System.Environment as E +import qualified System.SetEnv #else import qualified System.Posix.Env as PE #endif @@ -39,27 +40,27 @@ getEnvironment = E.getEnvironment #endif -{- Returns True if it could successfully set the environment variable. +{- Sets an environment variable. To overwrite an existing variable, + - overwrite must be True. - - - There is, apparently, no way to do this in Windows. Instead, - - environment varuables must be provided when running a new process. -} -setEnv :: String -> String -> Bool -> IO Bool + - On Windows, setting a variable to "" unsets it. -} +setEnv :: String -> String -> Bool -> IO () #ifndef mingw32_HOST_OS -setEnv var val overwrite = do - PE.setEnv var val overwrite - return True +setEnv var val overwrite = PE.setEnv var val overwrite #else -setEnv _ _ _ = return False +setEnv var val True = System.SetEnv.setEnv var val +setEnv var val False = do + r <- getEnv var + case r of + Nothing -> setEnv var val True + Just _ -> return () #endif -{- Returns True if it could successfully unset the environment variable. -} -unsetEnv :: String -> IO Bool +unsetEnv :: String -> IO () #ifndef mingw32_HOST_OS -unsetEnv var = do - PE.unsetEnv var - return True +unsetEnv = PE.unsetEnv #else -unsetEnv _ = return False +unsetEnv = System.SetEnv.unsetEnv #endif {- Adds the environment variable to the input environment. If already diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs --- a/src/Utility/FileSystemEncoding.hs +++ b/src/Utility/FileSystemEncoding.hs @@ -1,6 +1,6 @@ {- GHC File system encoding handling. - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2014 Joey Hess - - License: BSD-2-clause -} @@ -111,7 +111,7 @@ #ifndef mingw32_HOST_OS truncateFilePath n = go . reverse where - go f = + go f = let bytes = decodeW8 f in if length bytes <= n then reverse f diff --git a/src/Utility/LinuxMkLibs.hs b/src/Utility/LinuxMkLibs.hs --- a/src/Utility/LinuxMkLibs.hs +++ b/src/Utility/LinuxMkLibs.hs @@ -1,6 +1,6 @@ {- Linux library copier and binary shimmer - - - Copyright 2013 Joey Hess + - Copyright 2013 Joey Hess - - License: BSD-2-clause -} @@ -10,6 +10,7 @@ import Control.Applicative import Data.Maybe import System.Directory +import System.FilePath import Data.List.Utils import System.Posix.Files import Data.Char @@ -28,14 +29,14 @@ ( do installfile top lib checksymlink lib - return $ Just $ parentDir lib + return $ Just $ takeDirectory lib , return Nothing ) where checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do l <- readSymbolicLink (inTop top f) - let absl = absPathFrom (parentDir f) l - let target = relPathDirToFile (parentDir f) absl + let absl = absPathFrom (takeDirectory f) l + let target = relPathDirToFile (takeDirectory f) absl installfile top absl nukeFile (top ++ f) createSymbolicLink target (inTop top f) diff --git a/src/Utility/Misc.hs b/src/Utility/Misc.hs --- a/src/Utility/Misc.hs +++ b/src/Utility/Misc.hs @@ -1,6 +1,6 @@ {- misc utility functions - - - Copyright 2010-2011 Joey Hess + - Copyright 2010-2011 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Monad.hs b/src/Utility/Monad.hs --- a/src/Utility/Monad.hs +++ b/src/Utility/Monad.hs @@ -1,6 +1,6 @@ {- monadic stuff - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2012 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs --- a/src/Utility/Path.hs +++ b/src/Utility/Path.hs @@ -1,6 +1,6 @@ {- path manipulation - - - Copyright 2010-2014 Joey Hess + - Copyright 2010-2014 Joey Hess - - License: BSD-2-clause -} @@ -21,6 +21,7 @@ import qualified System.FilePath.Posix as Posix #else import System.Posix.Files +import Utility.Exception #endif import qualified "MissingH" System.Path as MissingH @@ -76,14 +77,12 @@ todos = replace "/" "\\" #endif -{- Returns the parent directory of a path. - - - - To allow this to be easily used in loops, which terminate upon reaching the - - top, the parent of / is "" -} -parentDir :: FilePath -> FilePath +{- Just the parent directory of a path, or Nothing if the path has no + - parent (ie for "/") -} +parentDir :: FilePath -> Maybe FilePath parentDir dir - | null dirs = "" - | otherwise = joinDrive drive (join s $ init dirs) + | null dirs = Nothing + | otherwise = Just $ joinDrive drive (join s $ init dirs) where -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" (drive, path) = splitDrive dir @@ -93,8 +92,8 @@ prop_parentDir_basics :: FilePath -> Bool prop_parentDir_basics dir | null dir = True - | dir == "/" = parentDir dir == "" - | otherwise = p /= dir + | dir == "/" = parentDir dir == Nothing + | otherwise = p /= Just dir where p = parentDir dir @@ -235,11 +234,11 @@ | null drive = recombine parts | otherwise = recombine $ "/cygdrive" : driveletter drive : parts where - (drive, p') = splitDrive p + (drive, p') = splitDrive p parts = splitDirectories p' - driveletter = map toLower . takeWhile (/= ':') + driveletter = map toLower . takeWhile (/= ':') recombine = fixtrailing . Posix.joinPath - fixtrailing s + fixtrailing s | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s | otherwise = s #endif @@ -255,7 +254,9 @@ fileNameLengthLimit _ = return 255 #else fileNameLengthLimit dir = do - l <- fromIntegral <$> getPathVar dir FileNameLimit + -- getPathVar can fail due to statfs(2) overflow + l <- catchDefaultIO 0 $ + fromIntegral <$> getPathVar dir FileNameLimit if l <= 0 then return 255 else return $ minimum [l, 255] @@ -267,12 +268,13 @@ - sane FilePath. - - All spaces and punctuation and other wacky stuff are replaced - - with '_', except for '.' "../" will thus turn into ".._", which is safe. + - with '_', except for '.' + - "../" will thus turn into ".._", which is safe. -} sanitizeFilePath :: String -> FilePath sanitizeFilePath = map sanitize where - sanitize c + sanitize c | c == '.' = c | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' | otherwise = c diff --git a/src/Utility/PosixFiles.hs b/src/Utility/PosixFiles.hs --- a/src/Utility/PosixFiles.hs +++ b/src/Utility/PosixFiles.hs @@ -2,7 +2,7 @@ - - This is like System.PosixCompat.Files, except with a fixed rename. - - - Copyright 2014 Joey Hess + - Copyright 2014 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs --- a/src/Utility/Process.hs +++ b/src/Utility/Process.hs @@ -38,7 +38,7 @@ ) where import qualified System.Process -import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess) +import qualified System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess) import System.Process hiding (createProcess, readProcess) import System.Exit import System.IO @@ -47,7 +47,7 @@ import qualified Control.Exception as E import Control.Monad #ifndef mingw32_HOST_OS -import System.Posix.IO +import qualified System.Posix.IO #else import Control.Applicative #endif @@ -175,9 +175,9 @@ #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order - the process writes them. -} - (readf, writef) <- createPipe - readh <- fdToHandle readf - writeh <- fdToHandle writef + (readf, writef) <- System.Posix.IO.createPipe + readh <- System.Posix.IO.fdToHandle readf + writeh <- System.Posix.IO.fdToHandle writef p@(_, _, _, pid) <- createProcess $ (proc cmd opts) { std_in = if isJust input then CreatePipe else Inherit diff --git a/src/Utility/QuickCheck.hs b/src/Utility/QuickCheck.hs --- a/src/Utility/QuickCheck.hs +++ b/src/Utility/QuickCheck.hs @@ -1,6 +1,6 @@ {- QuickCheck with additional instances - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2014 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs --- a/src/Utility/SafeCommand.hs +++ b/src/Utility/SafeCommand.hs @@ -1,6 +1,6 @@ {- safely running shell commands - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2013 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs --- a/src/Utility/Scheduled.hs +++ b/src/Utility/Scheduled.hs @@ -1,6 +1,6 @@ {- scheduled activities - - - Copyright 2013-2014 Joey Hess + - Copyright 2013-2014 Joey Hess - - License: BSD-2-clause -} @@ -44,7 +44,7 @@ {- Some sort of scheduled event. -} data Schedule = Schedule Recurrance ScheduledTime - deriving (Eq, Read, Show, Ord) + deriving (Eq, Read, Show, Ord) data Recurrance = Daily @@ -54,7 +54,7 @@ | Divisible Int Recurrance -- ^ Days, Weeks, or Months of the year evenly divisible by a number. -- (Divisible Year is years evenly divisible by a number.) - deriving (Eq, Read, Show, Ord) + deriving (Eq, Read, Show, Ord) type WeekDay = Int type MonthDay = Int @@ -63,7 +63,7 @@ data ScheduledTime = AnyTime | SpecificTime Hour Minute - deriving (Eq, Read, Show, Ord) + deriving (Eq, Read, Show, Ord) type Hour = Int type Minute = Int @@ -73,7 +73,7 @@ data NextTime = NextTimeExactly LocalTime | NextTimeWindow LocalTime LocalTime - deriving (Eq, Read, Show) + deriving (Eq, Read, Show) startTime :: NextTime -> LocalTime startTime (NextTimeExactly t) = t @@ -96,9 +96,9 @@ NextTimeExactly t -> window (localDay t) (localDay t) | otherwise = NextTimeExactly . startTime <$> findfromtoday False where - findfromtoday anytime = findfrom recurrance afterday today + findfromtoday anytime = findfrom recurrance afterday today where - today = localDay currenttime + today = localDay currenttime afterday = sameaslastrun || toolatetoday toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime sameaslastrun = lastrun == Just today @@ -163,8 +163,8 @@ Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing Divisible _ r'@(Divisible _ _) -> findfrom r' afterday candidate where - skip n = findfrom r False (addDays n candidate) - handlediv n r' getval mmax + skip n = findfrom r False (addDays n candidate) + handlediv n r' getval mmax | n > 0 && maybe True (n <=) mmax = findfromwhere r' (divisible n . getval) afterday candidate | otherwise = Nothing @@ -267,7 +267,7 @@ constructor u | "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u | otherwise = Nothing - withday sd u = do + withday sd u = do c <- constructor u d <- readish sd Just $ c (Just d) @@ -285,7 +285,7 @@ fromScheduledTime (SpecificTime h m) = show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm where - pad n s = take (n - length s) (repeat '0') ++ s + pad n s = take (n - length s) (repeat '0') ++ s (h', ampm) | h == 0 = (12, "AM") | h < 12 = (h, "AM") @@ -304,10 +304,10 @@ (s:[]) -> go s id _ -> Nothing where - h0 h + h0 h | h == 12 = 0 | otherwise = h - go :: String -> (Int -> Int) -> Maybe ScheduledTime + go :: String -> (Int -> Int) -> Maybe ScheduledTime go s adjust = let (h, m) = separate (== ':') s in SpecificTime @@ -363,7 +363,7 @@ ] ] where - arbday = oneof + arbday = oneof [ Just <$> nonNegative arbitrary , pure Nothing ] diff --git a/src/Utility/ThreadScheduler.hs b/src/Utility/ThreadScheduler.hs --- a/src/Utility/ThreadScheduler.hs +++ b/src/Utility/ThreadScheduler.hs @@ -1,6 +1,6 @@ {- thread scheduling - - - Copyright 2012, 2013 Joey Hess + - Copyright 2012, 2013 Joey Hess - Copyright 2011 Bas van Dijk & Roel van Dijk - - License: BSD-2-clause @@ -57,8 +57,7 @@ waitForTermination :: IO () waitForTermination = do #ifdef mingw32_HOST_OS - runEvery (Seconds 600) $ - void getLine + forever $ threadDelaySeconds (Seconds 6000) #else lock <- newEmptyMVar let check sig = void $ diff --git a/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs --- a/src/Utility/UserInfo.hs +++ b/src/Utility/UserInfo.hs @@ -1,6 +1,6 @@ {- user info - - - Copyright 2012 Joey Hess + - Copyright 2012 Joey Hess - - License: BSD-2-clause -} @@ -13,8 +13,10 @@ myUserGecos, ) where -import Control.Applicative import System.PosixCompat +#ifndef mingw32_HOST_OS +import Control.Applicative +#endif import Utility.Env @@ -40,16 +42,20 @@ env = ["USERNAME", "USER", "LOGNAME"] #endif -myUserGecos :: IO String -#ifdef __ANDROID__ -myUserGecos = return "" -- userGecos crashes on Android +myUserGecos :: IO (Maybe String) +-- userGecos crashes on Android and is not available on Windows. +#if defined(__ANDROID__) || defined(mingw32_HOST_OS) +myUserGecos = return Nothing #else -myUserGecos = myVal [] userGecos +myUserGecos = Just <$> myVal [] userGecos #endif myVal :: [String] -> (UserEntry -> String) -> IO String -myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars +myVal envvars extract = go envvars where - check [] = return Nothing - check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v - getpwent = getUserEntryForID =<< getEffectiveUserID +#ifndef mingw32_HOST_OS + go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID) +#else + go [] = error $ "environment not set: " ++ show envvars +#endif + go (v:vs) = maybe (go vs) return =<< getEnv v