summaryrefslogtreecommitdiff
path: root/Propellor
diff options
context:
space:
mode:
authorJoey Hess2014-05-14 19:41:05 -0400
committerJoey Hess2014-05-14 19:41:05 -0400
commit7115d1ec162b4059b3e8e8f84bd8d5898c1db025 (patch)
tree42c1cce54e890e1d56484794ab33129132d8fee2 /Propellor
parentffe371a9d42cded461236e972a24a142419d7fc4 (diff)
moved source code to src
This is to work around OSX's brain-damange regarding filename case insensitivity. Avoided moving config.hs, because it's a config file. Put in a symlink to make build work.
Diffstat (limited to 'Propellor')
-rw-r--r--Propellor/Attr.hs111
-rw-r--r--Propellor/CmdLine.hs392
-rw-r--r--Propellor/Engine.hs37
-rw-r--r--Propellor/Exception.hs18
-rw-r--r--Propellor/Message.hs51
-rw-r--r--Propellor/PrivData.hs91
-rw-r--r--Propellor/Property.hs163
-rw-r--r--Propellor/Property/Apache.hs62
-rw-r--r--Propellor/Property/Apt.hs256
-rw-r--r--Propellor/Property/Cmd.hs49
-rw-r--r--Propellor/Property/Cron.hs49
-rw-r--r--Propellor/Property/Dns.hs405
-rw-r--r--Propellor/Property/Docker.hs456
-rw-r--r--Propellor/Property/Docker/Shim.hs61
-rw-r--r--Propellor/Property/File.hs94
-rw-r--r--Propellor/Property/Git.hs93
-rw-r--r--Propellor/Property/Gpg.hs41
-rw-r--r--Propellor/Property/Hostname.hs33
-rw-r--r--Propellor/Property/Network.hs30
-rw-r--r--Propellor/Property/Obnam.hs155
-rw-r--r--Propellor/Property/OpenId.hs29
-rw-r--r--Propellor/Property/Postfix.hs25
-rw-r--r--Propellor/Property/Reboot.hs7
-rw-r--r--Propellor/Property/Scheduled.hs67
-rw-r--r--Propellor/Property/Service.hs31
-rw-r--r--Propellor/Property/SiteSpecific/GitAnnexBuilder.hs57
-rw-r--r--Propellor/Property/SiteSpecific/GitHome.hs34
-rw-r--r--Propellor/Property/SiteSpecific/JoeySites.hs314
-rw-r--r--Propellor/Property/Ssh.hs152
-rw-r--r--Propellor/Property/Sudo.hs32
-rw-r--r--Propellor/Property/Tor.hs19
-rw-r--r--Propellor/Property/User.hs61
-rw-r--r--Propellor/SimpleSh.hs101
-rw-r--r--Propellor/Types.hs153
-rw-r--r--Propellor/Types/Attr.hs48
-rw-r--r--Propellor/Types/Dns.hs92
-rw-r--r--Propellor/Types/OS.hs27
37 files changed, 0 insertions, 3896 deletions
diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs
deleted file mode 100644
index 98cfc64d..00000000
--- a/Propellor/Attr.hs
+++ /dev/null
@@ -1,111 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-
-module Propellor.Attr where
-
-import Propellor.Types
-import Propellor.Types.Attr
-
-import "mtl" Control.Monad.Reader
-import qualified Data.Set as S
-import qualified Data.Map as M
-import Data.Maybe
-import Control.Applicative
-
-pureAttrProperty :: Desc -> SetAttr -> Property
-pureAttrProperty desc = Property ("has " ++ desc) (return NoChange)
-
-hostname :: HostName -> Property
-hostname name = pureAttrProperty ("hostname " ++ name) $
- \d -> d { _hostname = name }
-
-getHostName :: Propellor HostName
-getHostName = asks _hostname
-
-os :: System -> Property
-os system = pureAttrProperty ("Operating " ++ show system) $
- \d -> d { _os = Just system }
-
-getOS :: Propellor (Maybe System)
-getOS = asks _os
-
--- | 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.)
-ipv4 :: String -> Property
-ipv4 addr = pureAttrProperty ("ipv4 " ++ addr)
- (addDNS $ Address $ IPv4 addr)
-
--- | Indidate that a host has an AAAA record in the DNS.
-ipv6 :: String -> Property
-ipv6 addr = pureAttrProperty ("ipv6 " ++ addr)
- (addDNS $ Address $ IPv6 addr)
-
--- | Indicates another name for the host in the DNS.
-alias :: Domain -> Property
-alias domain = pureAttrProperty ("alias " ++ domain)
- (addDNS $ CNAME $ AbsDomain domain)
-
-addDNS :: Record -> SetAttr
-addDNS record d = d { _dns = S.insert record (_dns d) }
-
--- | Adds a DNS NamedConf stanza.
---
--- Note that adding a Master stanza for a domain always overrides an
--- existing Secondary stanza, while a Secondary stanza is only added
--- when there is no existing Master stanza.
-addNamedConf :: NamedConf -> SetAttr
-addNamedConf conf d = d { _namedconf = new }
- where
- m = _namedconf d
- domain = confDomain conf
- new = case (confDnsServerType conf, confDnsServerType <$> M.lookup domain m) of
- (Secondary, Just Master) -> m
- _ -> M.insert domain conf m
-
-getNamedConf :: Propellor (M.Map Domain NamedConf)
-getNamedConf = asks _namedconf
-
-sshPubKey :: String -> Property
-sshPubKey k = pureAttrProperty ("ssh pubkey known") $
- \d -> d { _sshPubKey = Just k }
-
-getSshPubKey :: Propellor (Maybe String)
-getSshPubKey = asks _sshPubKey
-
-hostnameless :: Attr
-hostnameless = newAttr (error "hostname Attr not specified")
-
-hostAttr :: Host -> Attr
-hostAttr (Host _ mkattrs) = mkattrs hostnameless
-
-hostProperties :: Host -> [Property]
-hostProperties (Host ps _) = ps
-
-hostMap :: [Host] -> M.Map HostName Host
-hostMap l = M.fromList $ zip (map (_hostname . hostAttr) l) l
-
-hostAttrMap :: [Host] -> M.Map HostName Attr
-hostAttrMap l = M.fromList $ zip (map _hostname attrs) attrs
- where
- attrs = map hostAttr l
-
-findHost :: [Host] -> HostName -> Maybe Host
-findHost l hn = M.lookup hn (hostMap l)
-
-getAddresses :: Attr -> [IPAddr]
-getAddresses = mapMaybe getIPAddr . S.toList . _dns
-
-hostAddresses :: HostName -> [Host] -> [IPAddr]
-hostAddresses hn hosts = case hostAttr <$> findHost hosts hn of
- Nothing -> []
- Just attr -> mapMaybe getIPAddr $ S.toList $ _dns attr
-
--- | Lifts an action into a different host.
---
--- For example, `fromHost hosts "otherhost" getSshPubKey`
-fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a)
-fromHost l hn getter = case findHost l hn of
- Nothing -> return Nothing
- Just h -> liftIO $ Just <$>
- runReaderT (runWithAttr getter) (hostAttr h)
diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs
deleted file mode 100644
index ab1d7f9e..00000000
--- a/Propellor/CmdLine.hs
+++ /dev/null
@@ -1,392 +0,0 @@
-module Propellor.CmdLine where
-
-import System.Environment (getArgs)
-import Data.List
-import System.Exit
-import System.Log.Logger
-import System.Log.Formatter
-import System.Log.Handler (setFormatter, LogHandler)
-import System.Log.Handler.Simple
-import System.PosixCompat
-import Control.Exception (bracket)
-import System.Posix.IO
-import Data.Time.Clock.POSIX
-
-import Propellor
-import qualified Propellor.Property.Docker as Docker
-import qualified Propellor.Property.Docker.Shim as DockerShim
-import Utility.FileMode
-import Utility.SafeCommand
-import Utility.UserInfo
-
-usage :: IO a
-usage = do
- putStrLn $ unlines
- [ "Usage:"
- , " propellor"
- , " propellor hostname"
- , " propellor --spin hostname"
- , " propellor --set hostname field"
- , " propellor --add-key keyid"
- ]
- exitFailure
-
-processCmdLine :: IO CmdLine
-processCmdLine = go =<< getArgs
- where
- go ("--help":_) = usage
- go ("--spin":h:[]) = return $ Spin h
- go ("--boot":h:[]) = return $ Boot h
- go ("--add-key":k:[]) = return $ AddKey k
- go ("--set":h:f:[]) = case readish f of
- Just pf -> return $ Set h pf
- Nothing -> errorMessage $ "Unknown privdata field " ++ f
- go ("--continue":s:[]) = case readish s of
- Just cmdline -> return $ Continue cmdline
- Nothing -> errorMessage "--continue serialization failure"
- go ("--chain":h:[]) = return $ Chain h
- go ("--docker":h:[]) = return $ Docker h
- go (h:[])
- | "--" `isPrefixOf` h = usage
- | otherwise = return $ Run h
- go [] = do
- s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
- if null s
- then errorMessage "Cannot determine hostname! Pass it on the command line."
- else return $ Run s
- go _ = usage
-
-defaultMain :: [Host] -> IO ()
-defaultMain hostlist = do
- DockerShim.cleanEnv
- checkDebugMode
- cmdline <- processCmdLine
- debug ["command line: ", show cmdline]
- go True cmdline
- where
- go _ (Continue cmdline) = go False cmdline
- go _ (Set hn field) = setPrivData hn field
- go _ (AddKey keyid) = addKey keyid
- go _ (Chain hn) = withprops hn $ \attr ps -> do
- r <- runPropellor attr $ ensureProperties ps
- putStrLn $ "\n" ++ show r
- go _ (Docker hn) = Docker.chain hn
- go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
- go True cmdline = updateFirst cmdline $ go False cmdline
- go False (Spin hn) = withprops hn $ const . const $ spin hn
- go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
- ( onlyProcess $ withprops hn mainProperties
- , go True (Spin hn)
- )
- go False (Boot hn) = onlyProcess $ withprops hn boot
-
- withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO ()
- withprops hn a = maybe
- (unknownhost hn)
- (\h -> a (hostAttr h) (hostProperties h))
- (findHost hostlist hn)
-
-onlyProcess :: IO a -> IO a
-onlyProcess a = bracket lock unlock (const a)
- where
- lock = do
- l <- createFile lockfile stdFileMode
- setLock l (WriteLock, AbsoluteSeek, 0, 0)
- `catchIO` const alreadyrunning
- return l
- unlock = closeFd
- alreadyrunning = error "Propellor is already running on this host!"
- lockfile = localdir </> ".lock"
-
-unknownhost :: HostName -> IO a
-unknownhost h = errorMessage $ unlines
- [ "Propellor does not know about host: " ++ h
- , "(Perhaps you should specify the real hostname on the command line?)"
- , "(Or, edit propellor's config.hs to configure this host)"
- ]
-
-buildFirst :: CmdLine -> IO () -> IO ()
-buildFirst cmdline next = do
- oldtime <- getmtime
- ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
- ( do
- newtime <- getmtime
- if newtime == oldtime
- then next
- else void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
- , errorMessage "Propellor build failed!"
- )
- where
- getmtime = catchMaybeIO $ getModificationTime "propellor"
-
-getCurrentBranch :: IO String
-getCurrentBranch = takeWhile (/= '\n')
- <$> readProcess "git" ["symbolic-ref", "--short", "HEAD"]
-
-updateFirst :: CmdLine -> IO () -> IO ()
-updateFirst cmdline next = do
- branchref <- getCurrentBranch
- let originbranch = "origin" </> branchref
-
- void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"]
-
- whenM (doesFileExist keyring) $ do
- {- To verify origin branch commit's signature, have to
- - convince gpg to use our keyring. While running git log.
- - Which has no way to pass options to gpg.
- - Argh! -}
- let gpgconf = privDataDir </> "gpg.conf"
- writeFile gpgconf $ unlines
- [ " keyring " ++ keyring
- , "no-auto-check-trustdb"
- ]
- -- gpg is picky about perms
- modifyFileMode privDataDir (removeModes otherGroupModes)
- s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch]
- (Just [("GNUPGHOME", privDataDir)])
- nukeFile $ privDataDir </> "trustdb.gpg"
- nukeFile $ privDataDir </> "pubring.gpg"
- nukeFile $ privDataDir </> "gpg.conf"
- if s == "U\n" || s == "G\n"
- then do
- putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"
- hFlush stdout
- else errorMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it!"
-
- oldsha <- getCurrentGitSha1 branchref
- void $ boolSystem "git" [Param "merge", Param originbranch]
- newsha <- getCurrentGitSha1 branchref
-
- if oldsha == newsha
- then next
- else ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
- ( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
- , errorMessage "Propellor build failed!"
- )
-
-getCurrentGitSha1 :: String -> IO String
-getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]
-
-spin :: HostName -> IO ()
-spin hn = do
- url <- getUrl
- void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
- void $ boolSystem "git" [Param "push"]
- cacheparams <- toCommand <$> sshCachingParams hn
- go cacheparams url =<< gpgDecrypt (privDataFile hn)
- where
- go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do
- let finish = do
- senddata toh (privDataFile hn) privDataMarker privdata
- hClose toh
-
- -- Display remaining output.
- void $ tryIO $ forever $
- showremote =<< hGetLine fromh
- hClose fromh
- status <- getstatus fromh `catchIO` (const $ errorMessage "protocol error (perhaps the remote propellor failed to run?)")
- case status of
- Ready -> finish
- NeedGitClone -> do
- hClose toh
- hClose fromh
- sendGitClone hn url
- go cacheparams url privdata
-
- user = "root@"++hn
-
- bootstrapcmd = shellWrap $ intercalate " ; "
- [ "if [ ! -d " ++ localdir ++ " ]"
- , "then " ++ intercalate " && "
- [ "apt-get --no-install-recommends --no-upgrade -y install git make"
- , "echo " ++ toMarked statusMarker (show NeedGitClone)
- ]
- , "else " ++ intercalate " && "
- [ "cd " ++ localdir
- , "if ! test -x ./propellor; then make deps build; fi"
- , "./propellor --boot " ++ hn
- ]
- , "fi"
- ]
-
- getstatus :: Handle -> IO BootStrapStatus
- getstatus h = do
- l <- hGetLine h
- case readish =<< fromMarked statusMarker l of
- Nothing -> do
- showremote l
- getstatus h
- Just status -> return status
-
- showremote s = putStrLn s
- senddata toh f marker s = void $
- actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do
- sendMarked toh marker s
- return True
-
-sendGitClone :: HostName -> String -> IO ()
-sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
- branch <- getCurrentBranch
- cacheparams <- sshCachingParams hn
- withTmpFile "propellor.git" $ \tmp _ -> allM id
- [ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
- , boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
- , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
- ]
- where
- remotebundle = "/usr/local/propellor.git"
- unpackcmd branch = shellWrap $ intercalate " && "
- [ "git clone " ++ remotebundle ++ " " ++ localdir
- , "cd " ++ localdir
- , "git checkout -b " ++ branch
- , "git remote rm origin"
- , "rm -f " ++ remotebundle
- , "git remote add origin " ++ url
- -- same as --set-upstream-to, except origin branch
- -- has not been pulled yet
- , "git config branch."++branch++".remote origin"
- , "git config branch."++branch++".merge refs/heads/"++branch
- ]
-
-data BootStrapStatus = Ready | NeedGitClone
- deriving (Read, Show, Eq)
-
-type Marker = String
-type Marked = String
-
-statusMarker :: Marker
-statusMarker = "STATUS"
-
-privDataMarker :: String
-privDataMarker = "PRIVDATA "
-
-toMarked :: Marker -> String -> String
-toMarked marker = intercalate "\n" . map (marker ++) . lines
-
-sendMarked :: Handle -> Marker -> String -> IO ()
-sendMarked h marker s = do
- -- Prefix string with newline because sometimes a
- -- incomplete line is output.
- hPutStrLn h ("\n" ++ toMarked marker s)
- hFlush h
-
-fromMarked :: Marker -> Marked -> Maybe String
-fromMarked marker s
- | null matches = Nothing
- | otherwise = Just $ intercalate "\n" $
- map (drop len) matches
- where
- len = length marker
- matches = filter (marker `isPrefixOf`) $ lines s
-
-boot :: Attr -> [Property] -> IO ()
-boot attr ps = do
- sendMarked stdout statusMarker $ show Ready
- reply <- hGetContentsStrict stdin
-
- makePrivDataDir
- maybe noop (writeFileProtected privDataLocal) $
- fromMarked privDataMarker reply
- mainProperties attr ps
-
-addKey :: String -> IO ()
-addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitconfig, gitcommit ]
- where
- gpg = do
- createDirectoryIfMissing True privDataDir
- boolSystem "sh"
- [ Param "-c"
- , Param $ "gpg --export " ++ keyid ++ " | gpg " ++
- unwords (gpgopts ++ ["--import"])
- ]
- gitadd = boolSystem "git"
- [ Param "add"
- , File keyring
- ]
-
- gitconfig = boolSystem "git"
- [ Param "config"
- , Param "user.signingkey"
- , Param keyid
- ]
-
- gitcommit = gitCommit
- [ File keyring
- , Param "-m"
- , Param "propellor addkey"
- ]
-
-{- Automatically sign the commit if there'a a keyring. -}
-gitCommit :: [CommandParam] -> IO Bool
-gitCommit ps = do
- k <- doesFileExist keyring
- boolSystem "git" $ catMaybes $
- [ Just (Param "commit")
- , if k then Just (Param "--gpg-sign") else Nothing
- ] ++ map Just ps
-
-keyring :: FilePath
-keyring = privDataDir </> "keyring.gpg"
-
-gpgopts :: [String]
-gpgopts = ["--options", "/dev/null", "--no-default-keyring", "--keyring", keyring]
-
-getUrl :: IO String
-getUrl = maybe nourl return =<< getM get urls
- where
- urls = ["remote.deploy.url", "remote.origin.url"]
- nourl = errorMessage $ "Cannot find deploy url in " ++ show urls
- get u = do
- v <- catchMaybeIO $
- takeWhile (/= '\n')
- <$> readProcess "git" ["config", u]
- return $ case v of
- Just url | not (null url) -> Just url
- _ -> Nothing
-
-checkDebugMode :: IO ()
-checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
- where
- go (Just s)
- | s == "1" = do
- f <- setFormatter
- <$> streamHandler stderr DEBUG
- <*> pure (simpleLogFormatter "[$time] $msg")
- updateGlobalLogger rootLoggerName $
- setLevel DEBUG . setHandlers [f]
- go _ = noop
-
--- Parameters can be passed to both ssh and scp, to enable a ssh connection
--- caching socket.
---
--- If the socket already exists, check if its mtime is older than 10
--- minutes, and if so stop that ssh process, in order to not try to
--- use an old stale connection. (atime would be nicer, but there's
--- a good chance a laptop uses noatime)
-sshCachingParams :: HostName -> IO [CommandParam]
-sshCachingParams hn = do
- home <- myHomeDir
- let cachedir = home </> ".ssh" </> "propellor"
- createDirectoryIfMissing False cachedir
- let socketfile = cachedir </> hn ++ ".sock"
- let ps =
- [ Param "-o", Param ("ControlPath=" ++ socketfile)
- , Params "-o ControlMaster=auto -o ControlPersist=yes"
- ]
-
- maybe noop (expireold ps socketfile)
- =<< catchMaybeIO (getFileStatus socketfile)
-
- return ps
-
- where
- expireold ps f s = do
- now <- truncate <$> getPOSIXTime :: IO Integer
- if modificationTime s > fromIntegral now - tenminutes
- then touchFile f
- else do
- void $ boolSystem "ssh" $
- [ Params "-O stop" ] ++ ps ++
- [ Param "localhost" ]
- nukeFile f
- tenminutes = 600
diff --git a/Propellor/Engine.hs b/Propellor/Engine.hs
deleted file mode 100644
index 55ce7f77..00000000
--- a/Propellor/Engine.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-
-module Propellor.Engine where
-
-import System.Exit
-import System.IO
-import Data.Monoid
-import System.Console.ANSI
-import "mtl" Control.Monad.Reader
-
-import Propellor.Types
-import Propellor.Message
-import Propellor.Exception
-
-runPropellor :: Attr -> Propellor a -> IO a
-runPropellor attr a = runReaderT (runWithAttr a) attr
-
-mainProperties :: Attr -> [Property] -> IO ()
-mainProperties attr ps = do
- r <- runPropellor attr $
- ensureProperties [Property "overall" (ensureProperties ps) id]
- setTitle "propellor: done"
- hFlush stdout
- case r of
- FailedChange -> exitWith (ExitFailure 1)
- _ -> exitWith ExitSuccess
-
-ensureProperties :: [Property] -> Propellor Result
-ensureProperties ps = ensure ps NoChange
- where
- ensure [] rs = return rs
- ensure (l:ls) rs = do
- r <- actionMessage (propertyDesc l) (ensureProperty l)
- ensure ls (r <> rs)
-
-ensureProperty :: Property -> Propellor Result
-ensureProperty = catchPropellor . propertySatisfy
diff --git a/Propellor/Exception.hs b/Propellor/Exception.hs
deleted file mode 100644
index f6fd15f1..00000000
--- a/Propellor/Exception.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-
-module Propellor.Exception where
-
-import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M
-import Control.Exception
-
-import Propellor.Types
-import Propellor.Message
-
--- | Catches IO exceptions and returns FailedChange.
-catchPropellor :: Propellor Result -> Propellor Result
-catchPropellor a = either err return =<< tryPropellor a
- where
- err e = warningMessage (show e) >> return FailedChange
-
-tryPropellor :: Propellor a -> Propellor (Either IOException a)
-tryPropellor = M.try
diff --git a/Propellor/Message.hs b/Propellor/Message.hs
deleted file mode 100644
index 780471c3..00000000
--- a/Propellor/Message.hs
+++ /dev/null
@@ -1,51 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-
-module Propellor.Message where
-
-import System.Console.ANSI
-import System.IO
-import System.Log.Logger
-import "mtl" Control.Monad.Reader
-
-import Propellor.Types
-
--- | Shows a message while performing an action, with a colored status
--- display.
-actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r
-actionMessage desc a = do
- liftIO $ do
- setTitle $ "propellor: " ++ desc
- hFlush stdout
-
- r <- a
-
- liftIO $ do
- setTitle "propellor: running"
- let (msg, intensity, color) = getActionResult r
- putStr $ desc ++ " ... "
- colorLine intensity color msg
- hFlush stdout
-
- return r
-
-warningMessage :: MonadIO m => String -> m ()
-warningMessage s = liftIO $ colorLine Vivid Magenta $ "** warning: " ++ s
-
-colorLine :: ColorIntensity -> Color -> String -> IO ()
-colorLine intensity color msg = do
- setSGR [SetColor Foreground intensity color]
- putStr msg
- setSGR []
- -- Note this comes after the color is reset, so that
- -- the color set and reset happen in the same line.
- putStrLn ""
- hFlush stdout
-
-errorMessage :: String -> IO a
-errorMessage s = do
- liftIO $ colorLine Vivid Red $ "** error: " ++ s
- error "Cannot continue!"
-
--- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1
-debug :: [String] -> IO ()
-debug = debugM "propellor" . unwords
diff --git a/Propellor/PrivData.hs b/Propellor/PrivData.hs
deleted file mode 100644
index ad2c8d22..00000000
--- a/Propellor/PrivData.hs
+++ /dev/null
@@ -1,91 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-
-module Propellor.PrivData where
-
-import qualified Data.Map as M
-import Control.Applicative
-import System.FilePath
-import System.IO
-import System.Directory
-import Data.Maybe
-import Data.List
-import Control.Monad
-import "mtl" Control.Monad.Reader
-
-import Propellor.Types
-import Propellor.Attr
-import Propellor.Message
-import Utility.Monad
-import Utility.PartialPrelude
-import Utility.Exception
-import Utility.Process
-import Utility.Tmp
-import Utility.SafeCommand
-import Utility.Misc
-
--- | When the specified PrivDataField is available on the host Propellor
--- is provisioning, it provies the data to the action. Otherwise, it prints
--- a message to help the user make the necessary private data available.
-withPrivData :: PrivDataField -> (String -> Propellor Result) -> Propellor Result
-withPrivData field a = maybe missing a =<< liftIO (getPrivData field)
- where
- missing = do
- host <- getHostName
- let host' = if ".docker" `isSuffixOf` host
- then "$parent_host"
- else host
- liftIO $ do
- warningMessage $ "Missing privdata " ++ show field
- putStrLn $ "Fix this by running: propellor --set "++host'++" '" ++ show field ++ "'"
- return FailedChange
-
-getPrivData :: PrivDataField -> IO (Maybe String)
-getPrivData field = do
- m <- catchDefaultIO Nothing $ readish <$> readFile privDataLocal
- return $ maybe Nothing (M.lookup field) m
-
-setPrivData :: HostName -> PrivDataField -> IO ()
-setPrivData host field = do
- putStrLn "Enter private data on stdin; ctrl-D when done:"
- value <- chomp <$> hGetContentsStrict stdin
- makePrivDataDir
- let f = privDataFile host
- m <- fromMaybe M.empty . readish <$> gpgDecrypt f
- let m' = M.insert field value m
- gpgEncrypt f (show m')
- putStrLn "Private data set."
- void $ boolSystem "git" [Param "add", File f]
- where
- chomp s
- | end s == "\n" = chomp (beginning s)
- | otherwise = s
-
-makePrivDataDir :: IO ()
-makePrivDataDir = createDirectoryIfMissing False privDataDir
-
-privDataDir :: FilePath
-privDataDir = "privdata"
-
-privDataFile :: HostName -> FilePath
-privDataFile host = privDataDir </> host ++ ".gpg"
-
-privDataLocal :: FilePath
-privDataLocal = privDataDir </> "local"
-
-gpgDecrypt :: FilePath -> IO String
-gpgDecrypt f = ifM (doesFileExist f)
- ( readProcess "gpg" ["--decrypt", f]
- , return ""
- )
-
-gpgEncrypt :: FilePath -> String -> IO ()
-gpgEncrypt f s = do
- encrypted <- writeReadProcessEnv "gpg"
- [ "--default-recipient-self"
- , "--armor"
- , "--encrypt"
- ]
- Nothing
- (Just $ flip hPutStr s)
- Nothing
- viaTmp writeFile f encrypted
diff --git a/Propellor/Property.hs b/Propellor/Property.hs
deleted file mode 100644
index 24494654..00000000
--- a/Propellor/Property.hs
+++ /dev/null
@@ -1,163 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-
-module Propellor.Property where
-
-import System.Directory
-import Control.Monad
-import Data.Monoid
-import Data.List
-import Control.Monad.IfElse
-import "mtl" Control.Monad.Reader
-
-import Propellor.Types
-import Propellor.Types.Attr
-import Propellor.Attr
-import Propellor.Engine
-import Utility.Monad
-import System.FilePath
-
--- Constructs a Property.
-property :: Desc -> Propellor Result -> Property
-property d s = Property d s id
-
--- | Combines a list of properties, resulting in a single property
--- that when run will run each property in the list in turn,
--- and print out the description of each as it's run. Does not stop
--- on failure; does propigate overall success/failure.
-propertyList :: Desc -> [Property] -> Property
-propertyList desc ps = Property desc (ensureProperties ps) (combineSetAttrs ps)
-
--- | Combines a list of properties, resulting in one property that
--- ensures each in turn, stopping on failure.
-combineProperties :: Desc -> [Property] -> Property
-combineProperties desc ps = Property desc (go ps NoChange) (combineSetAttrs ps)
- where
- go [] rs = return rs
- go (l:ls) rs = do
- r <- ensureProperty l
- case r of
- FailedChange -> return FailedChange
- _ -> go ls (r <> rs)
-
--- | Combines together two properties, resulting in one property
--- that ensures the first, and if the first succeeds, ensures the second.
--- The property uses the description of the first property.
-before :: Property -> Property -> Property
-p1 `before` p2 = p2 `requires` p1
- `describe` (propertyDesc p1)
-
--- | Makes a perhaps non-idempotent Property be idempotent by using a flag
--- file to indicate whether it has run before.
--- Use with caution.
-flagFile :: Property -> FilePath -> Property
-flagFile p = flagFile' p . return
-
-flagFile' :: Property -> IO FilePath -> Property
-flagFile' p getflagfile = adjustProperty p $ \satisfy -> do
- flagfile <- liftIO getflagfile
- go satisfy flagfile =<< liftIO (doesFileExist flagfile)
- where
- go _ _ True = return NoChange
- go satisfy flagfile False = do
- r <- satisfy
- when (r == MadeChange) $ liftIO $
- unlessM (doesFileExist flagfile) $ do
- createDirectoryIfMissing True (takeDirectory flagfile)
- writeFile flagfile ""
- return r
-
---- | Whenever a change has to be made for a Property, causes a hook
--- Property to also be run, but not otherwise.
-onChange :: Property -> Property -> Property
-p `onChange` hook = Property (propertyDesc p) satisfy (combineSetAttr p hook)
- where
- satisfy = do
- r <- ensureProperty p
- case r of
- MadeChange -> do
- r' <- ensureProperty hook
- return $ r <> r'
- _ -> return r
-
-(==>) :: Desc -> Property -> Property
-(==>) = flip describe
-infixl 1 ==>
-
--- | Makes a Property only need to do anything when a test succeeds.
-check :: IO Bool -> Property -> Property
-check c p = adjustProperty p $ \satisfy -> ifM (liftIO c)
- ( satisfy
- , return NoChange
- )
-
--- | Marks a Property as trivial. It can only return FailedChange or
--- NoChange.
---
--- Useful when it's just as expensive to check if a change needs
--- to be made as it is to just idempotently assure the property is
--- satisfied. For example, chmodding a file.
-trivial :: Property -> Property
-trivial p = adjustProperty p $ \satisfy -> do
- r <- satisfy
- if r == MadeChange
- then return NoChange
- else return r
-
--- | Makes a property that is satisfied differently depending on the host's
--- operating system.
---
--- Note that the operating system may not be declared for some hosts.
-withOS :: Desc -> (Maybe System -> Propellor Result) -> Property
-withOS desc a = property desc $ a =<< getOS
-
-boolProperty :: Desc -> IO Bool -> Property
-boolProperty desc a = property desc $ ifM (liftIO a)
- ( return MadeChange
- , return FailedChange
- )
-
--- | Undoes the effect of a property.
-revert :: RevertableProperty -> RevertableProperty
-revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
-
--- | Starts accumulating the properties of a Host.
---
--- > host "example.com"
--- > & someproperty
--- > ! oldproperty
--- > & otherproperty
-host :: HostName -> Host
-host hn = Host [] (\_ -> newAttr hn)
-
--- | Adds a property to a Host
---
--- Can add Properties and RevertableProperties
-(&) :: IsProp p => Host -> p -> Host
-(Host ps as) & p = Host (ps ++ [toProp p]) (setAttr p . as)
-
-infixl 1 &
-
--- | Adds a property to the Host in reverted form.
-(!) :: Host -> RevertableProperty -> Host
-(Host ps as) ! p = Host (ps ++ [toProp q]) (setAttr q . as)
- where
- q = revert p
-
-infixl 1 !
-
--- Changes the action that is performed to satisfy a property.
-adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property
-adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) }
-
--- Combines the Attr settings of two properties.
-combineSetAttr :: (IsProp p, IsProp q) => p -> q -> SetAttr
-combineSetAttr p q = setAttr p . setAttr q
-
-combineSetAttrs :: IsProp p => [p] -> SetAttr
-combineSetAttrs = foldl' (.) id . map setAttr
-
-makeChange :: IO () -> Propellor Result
-makeChange a = liftIO a >> return MadeChange
-
-noChange :: Propellor Result
-noChange = return NoChange
diff --git a/Propellor/Property/Apache.hs b/Propellor/Property/Apache.hs
deleted file mode 100644
index cf3e62cc..00000000
--- a/Propellor/Property/Apache.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-module Propellor.Property.Apache where
-
-import Propellor
-import qualified Propellor.Property.File as File
-import qualified Propellor.Property.Apt as Apt
-import qualified Propellor.Property.Service as Service
-
-type ConfigFile = [String]
-
-siteEnabled :: HostName -> ConfigFile -> RevertableProperty
-siteEnabled hn cf = RevertableProperty enable disable
- where
- enable = trivial $ cmdProperty "a2ensite" ["--quiet", hn]
- `describe` ("apache site enabled " ++ hn)
- `requires` siteAvailable hn cf
- `requires` installed
- `onChange` reloaded
- disable = trivial $ File.notPresent (siteCfg hn)
- `describe` ("apache site disabled " ++ hn)
- `onChange` cmdProperty "a2dissite" ["--quiet", hn]
- `requires` installed
- `onChange` reloaded
-
-siteAvailable :: HostName -> ConfigFile -> Property
-siteAvailable hn cf = siteCfg hn `File.hasContent` (comment:cf)
- `describe` ("apache site available " ++ hn)
- where
- comment = "# deployed with propellor, do not modify"
-
-modEnabled :: String -> RevertableProperty
-modEnabled modname = RevertableProperty enable disable
- where
- enable = trivial $ cmdProperty "a2enmod" ["--quiet", modname]
- `describe` ("apache module enabled " ++ modname)
- `requires` installed
- `onChange` reloaded
- disable = trivial $ cmdProperty "a2dismod" ["--quiet", modname]
- `describe` ("apache module disabled " ++ modname)
- `requires` installed
- `onChange` reloaded
-
-siteCfg :: HostName -> FilePath
-siteCfg hn = "/etc/apache2/sites-available/" ++ hn
-
-installed :: Property
-installed = Apt.installed ["apache2"]
-
-restarted :: Property
-restarted = cmdProperty "service" ["apache2", "restart"]
-
-reloaded :: Property
-reloaded = Service.reloaded "apache2"
-
--- | Configure apache to use SNI to differentiate between
--- https hosts.
-multiSSL :: Property
-multiSSL = "/etc/apache2/conf.d/ssl" `File.hasContent`
- [ "NameVirtualHost *:443"
- , "SSLStrictSNIVHostCheck off"
- ]
- `describe` "apache SNI enabled"
- `onChange` reloaded
diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs
deleted file mode 100644
index 7329c7a8..00000000
--- a/Propellor/Property/Apt.hs
+++ /dev/null
@@ -1,256 +0,0 @@
-module Propellor.Property.Apt where
-
-import Data.Maybe
-import Control.Applicative
-import Data.List
-import System.IO
-import Control.Monad
-
-import Propellor
-import qualified Propellor.Property.File as File
-import qualified Propellor.Property.Service as Service
-import Propellor.Property.File (Line)
-
-sourcesList :: FilePath
-sourcesList = "/etc/apt/sources.list"
-
-type Url = String
-type Section = String
-
-type SourcesGenerator = DebianSuite -> [Line]
-
-showSuite :: DebianSuite -> String
-showSuite Stable = "stable"
-showSuite Testing = "testing"
-showSuite Unstable = "unstable"
-showSuite Experimental = "experimental"
-showSuite (DebianRelease r) = r
-
-backportSuite :: String
-backportSuite = showSuite stableRelease ++ "-backports"
-
-debLine :: String -> Url -> [Section] -> Line
-debLine suite mirror sections = unwords $
- ["deb", mirror, suite] ++ sections
-
-srcLine :: Line -> Line
-srcLine l = case words l of
- ("deb":rest) -> unwords $ "deb-src" : rest
- _ -> ""
-
-stdSections :: [Section]
-stdSections = ["main", "contrib", "non-free"]
-
-binandsrc :: String -> SourcesGenerator
-binandsrc url suite
- | isStable suite = [l, srcLine l, bl, srcLine bl]
- | otherwise = [l, srcLine l]
- where
- l = debLine (showSuite suite) url stdSections
- bl = debLine backportSuite url stdSections
-
-debCdn :: SourcesGenerator
-debCdn = binandsrc "http://cdn.debian.net/debian"
-
-kernelOrg :: SourcesGenerator
-kernelOrg = binandsrc "http://mirrors.kernel.org/debian"
-
--- | Only available for Stable and Testing
-securityUpdates :: SourcesGenerator
-securityUpdates suite
- | isStable suite || suite == Testing =
- let l = "deb http://security.debian.org/ " ++ showSuite suite ++ "/updates " ++ unwords stdSections
- in [l, srcLine l]
- | otherwise = []
-
--- | Makes sources.list have a standard content using the mirror CDN,
--- with a particular DebianSuite.
---
--- Since the CDN is sometimes unreliable, also adds backup lines using
--- kernel.org.
-stdSourcesList :: DebianSuite -> Property
-stdSourcesList suite = stdSourcesList' suite []
-
--- | Adds additional sources.list generators.
---
--- Note that if a Property needs to enable an apt source, it's better
--- to do so via a separate file in /etc/apt/sources.list.d/
-stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property
-stdSourcesList' suite more = setSourcesList
- (concatMap (\gen -> gen suite) generators)
- `describe` ("standard sources.list for " ++ show suite)
- where
- generators = [debCdn, kernelOrg, securityUpdates] ++ more
-
-setSourcesList :: [Line] -> Property
-setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update
-
-setSourcesListD :: [Line] -> FilePath -> Property
-setSourcesListD ls basename = f `File.hasContent` ls `onChange` update
- where
- f = "/etc/apt/sources.list.d/" ++ basename ++ ".list"
-
-runApt :: [String] -> Property
-runApt ps = cmdProperty' "apt-get" ps noninteractiveEnv
-
-noninteractiveEnv :: [(String, String)]
-noninteractiveEnv =
- [ ("DEBIAN_FRONTEND", "noninteractive")
- , ("APT_LISTCHANGES_FRONTEND", "none")
- ]
-
-update :: Property
-update = runApt ["update"]
- `describe` "apt update"
-
-upgrade :: Property
-upgrade = runApt ["-y", "dist-upgrade"]
- `describe` "apt dist-upgrade"
-
-type Package = String
-
-installed :: [Package] -> Property
-installed = installed' ["-y"]
-
-installed' :: [String] -> [Package] -> Property
-installed' params ps = robustly $ check (isInstallable ps) go
- `describe` (unwords $ "apt installed":ps)
- where
- go = runApt $ params ++ ["install"] ++ ps
-
-installedBackport :: [Package] -> Property
-installedBackport ps = trivial $ withOS desc $ \o -> case o of
- Nothing -> error "cannot install backports; os not declared"
- (Just (System (Debian suite) _))
- | isStable suite ->
- ensureProperty $ runApt $
- ["install", "-t", backportSuite, "-y"] ++ ps
- _ -> error $ "backports not supported on " ++ show o
- where
- desc = (unwords $ "apt installed backport":ps)
-
--- | Minimal install of package, without recommends.
-installedMin :: [Package] -> Property
-installedMin = installed' ["--no-install-recommends", "-y"]
-
-removed :: [Package] -> Property
-removed ps = check (or <$> isInstalled' ps) go
- `describe` (unwords $ "apt removed":ps)
- where
- go = runApt $ ["-y", "remove"] ++ ps
-
-buildDep :: [Package] -> Property
-buildDep ps = robustly go
- `describe` (unwords $ "apt build-dep":ps)
- where
- go = runApt $ ["-y", "build-dep"] ++ ps
-
--- | Installs the build deps for the source package unpacked
--- in the specifed directory, with a dummy package also
--- installed so that autoRemove won't remove them.
-buildDepIn :: FilePath -> Property
-buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"]
- where
- go = cmdProperty' "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"]
- noninteractiveEnv
-
--- | Package installation may fail becuse the archive has changed.
--- Run an update in that case and retry.
-robustly :: Property -> Property
-robustly p = adjustProperty p $ \satisfy -> do
- r <- satisfy
- if r == FailedChange
- then ensureProperty $ p `requires` update
- else return r
-
-isInstallable :: [Package] -> IO Bool
-isInstallable ps = do
- l <- isInstalled' ps
- return $ any (== False) l && not (null l)
-
-isInstalled :: Package -> IO Bool
-isInstalled p = (== [True]) <$> isInstalled' [p]
-
--- | Note that the order of the returned list will not always
--- correspond to the order of the input list. The number of items may
--- even vary. If apt does not know about a package at all, it will not
--- be included in the result list.
-isInstalled' :: [Package] -> IO [Bool]
-isInstalled' ps = catMaybes . map parse . lines
- <$> readProcess "apt-cache" ("policy":ps)
- where
- parse l
- | "Installed: (none)" `isInfixOf` l = Just False
- | "Installed: " `isInfixOf` l = Just True
- | otherwise = Nothing
-
-autoRemove :: Property
-autoRemove = runApt ["-y", "autoremove"]
- `describe` "apt autoremove"
-
--- | Enables unattended upgrades. Revert to disable.
-unattendedUpgrades :: RevertableProperty
-unattendedUpgrades = RevertableProperty enable disable
- where
- enable = setup True
- `before` Service.running "cron"
- `before` configure
- disable = setup False
-
- setup enabled = (if enabled then installed else removed) ["unattended-upgrades"]
- `onChange` reConfigure "unattended-upgrades"
- [("unattended-upgrades/enable_auto_updates" , "boolean", v)]
- `describe` ("unattended upgrades " ++ v)
- where
- v
- | enabled = "true"
- | otherwise = "false"
-
- configure = withOS "unattended upgrades configured" $ \o ->
- case o of
- -- the package defaults to only upgrading stable
- (Just (System (Debian suite) _))
- | not (isStable suite) -> ensureProperty $
- "/etc/apt/apt.conf.d/50unattended-upgrades"
- `File.containsLine`
- ("\t\"o=Debian,a="++showSuite suite++"\";")
- _ -> noChange
-
--- | Preseeds debconf values and reconfigures the package so it takes
--- effect.
-reConfigure :: Package -> [(String, String, String)] -> Property
-reConfigure package vals = reconfigure `requires` setselections
- `describe` ("reconfigure " ++ package)
- where
- setselections = property "preseed" $ makeChange $
- withHandle StdinHandle createProcessSuccess
- (proc "debconf-set-selections" []) $ \h -> do
- forM_ vals $ \(tmpl, tmpltype, value) ->
- hPutStrLn h $ unwords [package, tmpl, tmpltype, value]
- hClose h
- reconfigure = cmdProperty' "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv
-
--- | Ensures that a service is installed and running.
---
--- Assumes that there is a 1:1 mapping between service names and apt
--- package names.
-serviceInstalledRunning :: Package -> Property
-serviceInstalledRunning svc = Service.running svc `requires` installed [svc]
-
-data AptKey = AptKey
- { keyname :: String
- , pubkey :: String
- }
-
-trustsKey :: AptKey -> RevertableProperty
-trustsKey k = RevertableProperty trust untrust
- where
- desc = "apt trusts key " ++ keyname k
- f = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"
- untrust = File.notPresent f
- trust = check (not <$> doesFileExist f) $ property desc $ makeChange $ do
- withHandle StdinHandle createProcessSuccess
- (proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do
- hPutStr h (pubkey k)
- hClose h
- nukeFile $ f ++ "~" -- gpg dropping
diff --git a/Propellor/Property/Cmd.hs b/Propellor/Property/Cmd.hs
deleted file mode 100644
index bcd08246..00000000
--- a/Propellor/Property/Cmd.hs
+++ /dev/null
@@ -1,49 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-
-module Propellor.Property.Cmd (
- cmdProperty,
- cmdProperty',
- scriptProperty,
- userScriptProperty,
-) where
-
-import Control.Applicative
-import Data.List
-import "mtl" Control.Monad.Reader
-
-import Propellor.Types
-import Propellor.Property
-import Utility.Monad
-import Utility.SafeCommand
-import Utility.Env
-
--- | A property that can be satisfied by running a command.
---
--- The command must exit 0 on success.
-cmdProperty :: String -> [String] -> Property
-cmdProperty cmd params = cmdProperty' cmd params []
-
--- | A property that can be satisfied by running a command,
--- with added environment.
-cmdProperty' :: String -> [String] -> [(String, String)] -> Property
-cmdProperty' cmd params env = property desc $ liftIO $ do
- env' <- addEntries env <$> getEnvironment
- ifM (boolSystemEnv cmd (map Param params) (Just env'))
- ( return MadeChange
- , return FailedChange
- )
- where
- desc = unwords $ cmd : params
-
--- | A property that can be satisfied by running a series of shell commands.
-scriptProperty :: [String] -> Property
-scriptProperty script = cmdProperty "sh" ["-c", shellcmd]
- where
- shellcmd = intercalate " ; " ("set -e" : script)
-
--- | A property that can satisfied by running a series of shell commands,
--- as user (cd'd to their home directory).
-userScriptProperty :: UserName -> [String] -> Property
-userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user]
- where
- shellcmd = intercalate " ; " ("set -e" : "cd" : script)
diff --git a/Propellor/Property/Cron.hs b/Propellor/Property/Cron.hs
deleted file mode 100644
index 5b070eff..00000000
--- a/Propellor/Property/Cron.hs
+++ /dev/null
@@ -1,49 +0,0 @@
-module Propellor.Property.Cron where
-
-import Propellor
-import qualified Propellor.Property.File as File
-import qualified Propellor.Property.Apt as Apt
-import Utility.SafeCommand
-
-import Data.Char
-
-type CronTimes = String
-
--- | Installs a cron job, run as a specified user, in a particular
--- directory. Note that the Desc must be unique, as it is used for the
--- cron.d/ filename.
---
--- Only one instance of the cron job is allowed to run at a time, no matter
--- how long it runs. This is accomplished using flock locking of the cron
--- job file.
---
--- The cron job's output will only be emailed if it exits nonzero.
-job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property
-job desc times user cddir command = cronjobfile `File.hasContent`
- [ "# Generated by propellor"
- , ""
- , "SHELL=/bin/sh"
- , "PATH=/usr/local/sbin:/usr/local/bin:/sbin:/bin:/usr/sbin:/usr/bin"
- , ""
- , times ++ "\t" ++ user ++ "\t"
- ++ "chronic flock -n " ++ shellEscape cronjobfile
- ++ " sh -c " ++ shellEscape cmdline
- ]
- `requires` Apt.serviceInstalledRunning "cron"
- `requires` Apt.installed ["util-linux", "moreutils"]
- `describe` ("cronned " ++ desc)
- where
- cmdline = "cd " ++ cddir ++ " && ( " ++ command ++ " )"
- cronjobfile = "/etc/cron.d/" ++ map sanitize desc
- sanitize c
- | isAlphaNum c = c
- | otherwise = '_'
-
--- | Installs a cron job, and runs it niced and ioniced.
-niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property
-niceJob desc times user cddir command = job desc times user cddir
- ("nice ionice -c 3 " ++ command)
-
--- | Installs a cron job to run propellor.
-runPropellor :: CronTimes -> Property
-runPropellor times = niceJob "propellor" times "root" localdir "make"
diff --git a/Propellor/Property/Dns.hs b/Propellor/Property/Dns.hs
deleted file mode 100644
index 5c3162cb..00000000
--- a/Propellor/Property/Dns.hs
+++ /dev/null
@@ -1,405 +0,0 @@
-module Propellor.Property.Dns (
- module Propellor.Types.Dns,
- primary,
- secondary,
- secondaryFor,
- mkSOA,
- writeZoneFile,
- nextSerialNumber,
- adjustSerialNumber,
- serialNumberOffset,
- WarningMessage,
- genZone,
-) where
-
-import Propellor
-import Propellor.Types.Dns
-import Propellor.Property.File
-import Propellor.Types.Attr
-import qualified Propellor.Property.Apt as Apt
-import qualified Propellor.Property.Service as Service
-import Utility.Applicative
-
-import qualified Data.Map as M
-import qualified Data.Set as S
-import Data.List
-
--- | Primary dns server for a domain.
---
--- Most of the content of the zone file is configured by setting properties
--- of hosts. For example,
---
--- > host "foo.example.com"
--- > & ipv4 "192.168.1.1"
--- > & alias "mail.exmaple.com"
---
--- Will cause that hostmame and its alias to appear in the zone file,
--- with the configured IP address.
---
--- 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
--- not control.
---
--- The primary server is configured to only allow zone transfers to
--- secondary dns servers. These are determined in two ways:
---
--- 1. By looking at the properties of other hosts, to find hosts that
--- are configured as the secondary dns server.
---
--- 2. By looking for NS Records in the passed list of records.
---
--- In either case, the secondary dns server Host should have an ipv4 and/or
--- ipv6 property defined.
-primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty
-primary hosts domain soa rs = RevertableProperty setup cleanup
- where
- setup = withwarnings (check needupdate baseprop)
- `requires` servingZones
- `onChange` Service.reloaded "bind9"
- cleanup = check (doesFileExist zonefile) $
- property ("removed dns primary for " ++ domain)
- (makeChange $ removeZoneFile zonefile)
- `requires` namedConfWritten
- `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)
- (addNamedConf conf)
- withwarnings p = adjustProperty p $ \satisfy -> do
- mapM_ warningMessage $ zonewarnings ++ secondarywarnings
- satisfy
- conf = NamedConf
- { confDomain = domain
- , confDnsServerType = Master
- , confFile = zonefile
- , confMasters = []
- , confAllowTransfer = nub $
- concatMap (\h -> hostAddresses h hosts) $
- secondaries ++ nssecondaries
- , confLines = []
- }
- secondaries = otherServers Secondary hosts domain
- secondarywarnings = map (\h -> "No IP address defined for DNS seconary " ++ h) $
- filter (\h -> null (hostAddresses h hosts)) secondaries
- nssecondaries = mapMaybe (domainHostName <=< getNS) rootRecords
- rootRecords = map snd $
- filter (\(d, _r) -> d == RootDomain || d == AbsDomain domain) rs
- needupdate = do
- v <- readZonePropellorFile zonefile
- return $ case v of
- Nothing -> True
- Just oldzone ->
- -- compare everything except serial
- let oldserial = sSerial (zSOA oldzone)
- z = zone { zSOA = (zSOA zone) { sSerial = oldserial } }
- in z /= oldzone || oldserial < sSerial (zSOA zone)
-
--- | Secondary dns server for a domain.
---
--- The primary server is determined by looking at the properties of other
--- hosts to find which one is configured as the primary.
---
--- Note that if a host is declared to be a primary and a secondary dns
--- server for the same domain, the primary server config always wins.
-secondary :: [Host] -> Domain -> RevertableProperty
-secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain
-
--- | This variant is useful if the primary server does not have its DNS
--- configured via propellor.
-secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty
-secondaryFor masters hosts domain = RevertableProperty setup cleanup
- where
- setup = pureAttrProperty desc (addNamedConf conf)
- `requires` servingZones
- cleanup = namedConfWritten
-
- desc = "dns secondary for " ++ domain
- conf = NamedConf
- { confDomain = domain
- , confDnsServerType = Secondary
- , confFile = "db." ++ domain
- , confMasters = concatMap (\m -> hostAddresses m hosts) masters
- , confAllowTransfer = []
- , confLines = []
- }
-
-otherServers :: DnsServerType -> [Host] -> Domain -> [HostName]
-otherServers wantedtype hosts domain =
- M.keys $ M.filter wanted $ hostAttrMap hosts
- where
- wanted attr = case M.lookup domain (_namedconf attr) of
- Nothing -> False
- Just conf -> confDnsServerType conf == wantedtype
- && confDomain conf == domain
-
--- | Rewrites the whole named.conf.local file to serve the zones
--- configured by `primary` and `secondary`, and ensures that bind9 is
--- running.
-servingZones :: Property
-servingZones = namedConfWritten
- `onChange` Service.reloaded "bind9"
- `requires` Apt.serviceInstalledRunning "bind9"
-
-namedConfWritten :: Property
-namedConfWritten = property "named.conf configured" $ do
- zs <- getNamedConf
- ensureProperty $
- hasContent namedConfFile $
- concatMap confStanza $ M.elems zs
-
-confStanza :: NamedConf -> [Line]
-confStanza c =
- [ "// automatically generated by propellor"
- , "zone \"" ++ confDomain c ++ "\" {"
- , cfgline "type" (if confDnsServerType c == Master then "master" else "slave")
- , cfgline "file" ("\"" ++ confFile c ++ "\"")
- ] ++
- mastersblock ++
- allowtransferblock ++
- (map (\l -> "\t" ++ l ++ ";") (confLines c)) ++
- [ "};"
- , ""
- ]
- where
- cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"
- ipblock name l =
- [ "\t" ++ name ++ " {" ] ++
- (map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") l) ++
- [ "\t};" ]
- mastersblock
- | null (confMasters c) = []
- | otherwise = ipblock "masters" (confMasters c)
- -- an empty block prohibits any transfers
- allowtransferblock = ipblock "allow-transfer" (confAllowTransfer c)
-
-namedConfFile :: FilePath
-namedConfFile = "/etc/bind/named.conf.local"
-
--- | Generates a SOA with some fairly sane numbers in it.
---
--- The Domain is the domain to use in the SOA record. Typically
--- something like ns1.example.com. So, not the domain that this is the SOA
--- record for.
---
--- The SerialNumber can be whatever serial number was used by the domain
--- before propellor started managing it. Or 0 if the domain has only ever
--- been managed by propellor.
---
--- You do not need to increment the SerialNumber when making changes!
--- Propellor will automatically add the number of commits in the git
--- repository to the SerialNumber.
-mkSOA :: Domain -> SerialNumber -> SOA
-mkSOA d sn = SOA
- { sDomain = AbsDomain d
- , sSerial = sn
- , sRefresh = hours 4
- , sRetry = hours 1
- , sExpire = 2419200 -- 4 weeks
- , sNegativeCacheTTL = hours 8
- }
- where
- hours n = n * 60 * 60
-
-dValue :: BindDomain -> String
-dValue (RelDomain d) = d
-dValue (AbsDomain d) = d ++ "."
-dValue (RootDomain) = "@"
-
-rField :: Record -> String
-rField (Address (IPv4 _)) = "A"
-rField (Address (IPv6 _)) = "AAAA"
-rField (CNAME _) = "CNAME"
-rField (MX _ _) = "MX"
-rField (NS _) = "NS"
-rField (TXT _) = "TXT"
-rField (SRV _ _ _ _) = "SRV"
-
-rValue :: Record -> String
-rValue (Address (IPv4 addr)) = addr
-rValue (Address (IPv6 addr)) = addr
-rValue (CNAME d) = dValue d
-rValue (MX pri d) = show pri ++ " " ++ dValue d
-rValue (NS d) = dValue d
-rValue (SRV priority weight port target) = unwords
- [ show priority
- , show weight
- , show port
- , dValue target
- ]
-rValue (TXT s) = [q] ++ filter (/= q) s ++ [q]
- where
- q = '"'
-
--- | Adjusts the serial number of the zone to always be larger
--- than the serial number in the Zone record,
--- and always be larger than the passed SerialNumber.
-nextSerialNumber :: Zone -> SerialNumber -> Zone
-nextSerialNumber z serial = adjustSerialNumber z $ \sn -> succ $ max sn serial
-
-adjustSerialNumber :: Zone -> (SerialNumber -> SerialNumber) -> Zone
-adjustSerialNumber (Zone d soa l) f = Zone d soa' l
- where
- soa' = soa { sSerial = f (sSerial soa) }
-
--- | Count the number of git commits made to the current branch.
-serialNumberOffset :: IO SerialNumber
-serialNumberOffset = fromIntegral . length . lines
- <$> readProcess "git" ["log", "--pretty=%H"]
-
--- | Write a Zone out to a to a file.
---
--- The serial number in the Zone automatically has the serialNumberOffset
--- added to it. Also, just in case, the old serial number used in the zone
--- file is checked, and if it is somehow larger, its succ is used.
-writeZoneFile :: Zone -> FilePath -> IO ()
-writeZoneFile z f = do
- oldserial <- oldZoneFileSerialNumber f
- offset <- serialNumberOffset
- let z' = nextSerialNumber
- (adjustSerialNumber z (+ offset))
- oldserial
- createDirectoryIfMissing True (takeDirectory f)
- writeFile f (genZoneFile z')
- writeZonePropellorFile f z'
-
-removeZoneFile :: FilePath -> IO ()
-removeZoneFile f = do
- nukeFile f
- nukeFile (zonePropellorFile f)
-
--- | Next to the zone file, is a ".propellor" file, which contains
--- the serialized Zone. This saves the bother of parsing
--- the horrible bind zone file format.
-zonePropellorFile :: FilePath -> FilePath
-zonePropellorFile f = f ++ ".propellor"
-
-oldZoneFileSerialNumber :: FilePath -> IO SerialNumber
-oldZoneFileSerialNumber = maybe 0 (sSerial . zSOA) <$$> readZonePropellorFile
-
-writeZonePropellorFile :: FilePath -> Zone -> IO ()
-writeZonePropellorFile f z = writeFile (zonePropellorFile f) (show z)
-
-readZonePropellorFile :: FilePath -> IO (Maybe Zone)
-readZonePropellorFile f = catchDefaultIO Nothing $
- readish <$> readFileStrict (zonePropellorFile f)
-
--- | Generating a zone file.
-genZoneFile :: Zone -> String
-genZoneFile (Zone zdomain soa rs) = unlines $
- header : genSOA soa ++ map (genRecord zdomain) rs
- where
- header = com $ "BIND zone file for " ++ zdomain ++ ". Generated by propellor, do not edit."
-
-genRecord :: Domain -> (BindDomain, Record) -> String
-genRecord zdomain (domain, record) = intercalate "\t"
- [ domainHost zdomain domain
- , "IN"
- , rField record
- , rValue record
- ]
-
-genSOA :: SOA -> [String]
-genSOA soa =
- -- "@ IN SOA ns1.example.com. root ("
- [ intercalate "\t"
- [ dValue RootDomain
- , "IN"
- , "SOA"
- , dValue (sDomain soa)
- , "root"
- , "("
- ]
- , headerline sSerial "Serial"
- , headerline sRefresh "Refresh"
- , headerline sRetry "Retry"
- , headerline sExpire "Expire"
- , headerline sNegativeCacheTTL "Negative Cache TTL"
- , inheader ")"
- ]
- where
- headerline r comment = inheader $ show (r soa) ++ "\t\t" ++ com comment
- inheader l = "\t\t\t" ++ l
-
--- | Comment line in a zone file.
-com :: String -> String
-com s = "; " ++ s
-
-type WarningMessage = String
-
--- | 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 =
- let (warnings, zhosts) = partitionEithers $ concat $ map concat
- [ map hostips inzdomain
- , map hostrecords inzdomain
- , map addcnames (M.elems m)
- ]
- in (Zone zdomain soa (nub zhosts), warnings)
- where
- m = hostAttrMap 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 Attr.
- --
- -- If a host lacks any IPAddr, it's probably a misconfiguration,
- -- so warn.
- hostips :: Attr -> [Either WarningMessage (BindDomain, Record)]
- hostips attr
- | null l = [Left $ "no IP address defined for host " ++ _hostname attr]
- | otherwise = map Right l
- where
- l = zip (repeat $ AbsDomain $ _hostname attr)
- (map Address $ getAddresses attr)
-
- -- Any host, whether its hostname is in the zdomain or not,
- -- may have cnames which are in the zdomain. The cname may even be
- -- the same as the root of the zdomain, which is a nice way to
- -- specify IP addresses for a SOA record.
- --
- -- Add Records for those.. But not actually, usually, cnames!
- -- Why not? Well, using cnames doesn't allow doing some things,
- -- including MX and round robin DNS, and certianly CNAMES
- -- shouldn't be used in SOA records.
- --
- -- We typically know the host's IPAddrs anyway.
- -- So we can just use the IPAddrs.
- addcnames :: Attr -> [Either WarningMessage (BindDomain, Record)]
- addcnames attr = concatMap gen $ filter (inDomain zdomain) $
- mapMaybe getCNAME $ S.toList (_dns attr)
- where
- gen c = case getAddresses attr of
- [] -> [ret (CNAME c)]
- l -> map (ret . Address) l
- where
- ret record = Right (c, record)
-
- -- Adds any other DNS records for a host located in the zdomain.
- hostrecords :: Attr -> [Either WarningMessage (BindDomain, Record)]
- hostrecords attr = map Right l
- where
- l = zip (repeat $ AbsDomain $ _hostname attr)
- (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns attr))
-
-inDomain :: Domain -> BindDomain -> Bool
-inDomain domain (AbsDomain d) = domain == d || ('.':domain) `isSuffixOf` d
-inDomain _ _ = False -- can't tell, so assume not
-
--- | Gets the hostname of the second domain, relative to the first domain,
--- suitable for using in a zone file.
-domainHost :: Domain -> BindDomain -> String
-domainHost _ (RelDomain d) = d
-domainHost _ RootDomain = "@"
-domainHost base (AbsDomain d)
- | dotbase `isSuffixOf` d = take (length d - length dotbase) d
- | base == d = "@"
- | otherwise = d
- where
- dotbase = '.':base
-
diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs
deleted file mode 100644
index 09d7d6a4..00000000
--- a/Propellor/Property/Docker.hs
+++ /dev/null
@@ -1,456 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-
--- | Docker support for propellor
---
--- The existance of a docker container is just another Property of a system,
--- which propellor can set up. See config.hs for an example.
-
-module Propellor.Property.Docker where
-
-import Propellor
-import Propellor.SimpleSh
-import Propellor.Types.Attr
-import qualified Propellor.Property.File as File
-import qualified Propellor.Property.Apt as Apt
-import qualified Propellor.Property.Docker.Shim as Shim
-import Utility.SafeCommand
-import Utility.Path
-
-import Control.Concurrent.Async
-import System.Posix.Directory
-import System.Posix.Process
-import Data.List
-import Data.List.Utils
-
--- | Configures docker with an authentication file, so that images can be
--- pushed to index.docker.io.
-configured :: Property
-configured = property "docker configured" go `requires` installed
- where
- go = withPrivData DockerAuthentication $ \cfg -> ensureProperty $
- "/root/.dockercfg" `File.hasContent` (lines cfg)
-
-installed :: Property
-installed = Apt.installed ["docker.io"]
-
--- | A short descriptive name for a container.
--- Should not contain whitespace or other unusual characters,
--- only [a-zA-Z0-9_-] are allowed
-type ContainerName = String
-
--- | Starts accumulating the properties of a Docker container.
---
--- > container "web-server" "debian"
--- > & publish "80:80"
--- > & Apt.installed {"apache2"]
--- > & ...
-container :: ContainerName -> Image -> Host
-container cn image = Host [] (\_ -> attr)
- where
- attr = (newAttr (cn2hn cn)) { _dockerImage = Just image }
-
-cn2hn :: ContainerName -> HostName
-cn2hn cn = cn ++ ".docker"
-
--- | Ensures that a docker container is set up and running. The container
--- has its own Properties which are handled by running propellor
--- inside the container.
---
--- Reverting this property ensures that the container is stopped and
--- removed.
-docked
- :: [Host]
- -> ContainerName
- -> RevertableProperty
-docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown)
- where
- go desc a = property (desc ++ " " ++ cn) $ do
- hn <- getHostName
- let cid = ContainerId hn cn
- ensureProperties [findContainer hosts cid cn $ a cid]
-
- setup cid (Container image runparams) =
- provisionContainer cid
- `requires`
- runningContainer cid image runparams
- `requires`
- installed
-
- teardown cid (Container image _runparams) =
- combineProperties ("undocked " ++ fromContainerId cid)
- [ stoppedContainer cid
- , property ("cleaned up " ++ fromContainerId cid) $
- liftIO $ report <$> mapM id
- [ removeContainer cid
- , removeImage image
- ]
- ]
-
-findContainer
- :: [Host]
- -> ContainerId
- -> ContainerName
- -> (Container -> Property)
- -> Property
-findContainer hosts cid cn mk = case findHost hosts (cn2hn cn) of
- Nothing -> cantfind
- Just h -> maybe cantfind mk (mkContainer cid h)
- where
- cantfind = containerDesc cid $ property "" $ do
- liftIO $ warningMessage $
- "missing definition for docker container \"" ++ cn2hn cn
- return FailedChange
-
-mkContainer :: ContainerId -> Host -> Maybe Container
-mkContainer cid@(ContainerId hn _cn) h = Container
- <$> _dockerImage attr
- <*> pure (map (\a -> a hn) (_dockerRunParams attr))
- where
- attr = hostAttr h'
- h' = h
- -- expose propellor directory inside the container
- & volume (localdir++":"++localdir)
- -- name the container in a predictable way so we
- -- and the user can easily find it later
- & name (fromContainerId cid)
-
--- | Causes *any* docker images that are not in use by running containers to
--- be deleted. And deletes any containers that propellor has set up
--- before that are not currently running. Does not delete any containers
--- that were not set up using propellor.
---
--- Generally, should come after the properties for the desired containers.
-garbageCollected :: Property
-garbageCollected = propertyList "docker garbage collected"
- [ gccontainers
- , gcimages
- ]
- where
- gccontainers = property "docker containers garbage collected" $
- liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
- gcimages = property "docker images garbage collected" $ do
- liftIO $ report <$> (mapM removeImage =<< listImages)
-
-data Container = Container Image [RunParam]
-
--- | Parameters to pass to `docker run` when creating a container.
-type RunParam = String
-
--- | A docker image, that can be used to run a container.
-type Image = String
-
--- | Set custom dns server for container.
-dns :: String -> Property
-dns = runProp "dns"
-
--- | Set container host name.
-hostname :: String -> Property
-hostname = runProp "hostname"
-
--- | Set name for container. (Normally done automatically.)
-name :: String -> Property
-name = runProp "name"
-
--- | Publish a container's port to the host
--- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)
-publish :: String -> Property
-publish = runProp "publish"
-
--- | Username or UID for container.
-user :: String -> Property
-user = runProp "user"
-
--- | Mount a volume
--- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro]
--- With just a directory, creates a volume in the container.
-volume :: String -> Property
-volume = runProp "volume"
-
--- | Mount a volume from the specified container into the current
--- container.
-volumes_from :: ContainerName -> Property
-volumes_from cn = genProp "volumes-from" $ \hn ->
- fromContainerId (ContainerId hn cn)
-
--- | Work dir inside the container.
-workdir :: String -> Property
-workdir = runProp "workdir"
-
--- | Memory limit for container.
---Format: <number><optional unit>, where unit = b, k, m or g
-memory :: String -> Property
-memory = runProp "memory"
-
--- | Link with another container on the same host.
-link :: ContainerName -> ContainerAlias -> Property
-link linkwith calias = genProp "link" $ \hn ->
- fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias
-
--- | A short alias for a linked container.
--- Each container has its own alias namespace.
-type ContainerAlias = String
-
--- | A container is identified by its name, and the host
--- on which it's deployed.
-data ContainerId = ContainerId HostName ContainerName
- deriving (Eq, Read, Show)
-
--- | Two containers with the same ContainerIdent were started from
--- the same base image (possibly a different version though), and
--- with the same RunParams.
-data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam]
- deriving (Read, Show, Eq)
-
-ident2id :: ContainerIdent -> ContainerId
-ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn
-
-toContainerId :: String -> Maybe ContainerId
-toContainerId s
- | myContainerSuffix `isSuffixOf` s = case separate (== '.') (desuffix s) of
- (cn, hn)
- | null hn || null cn -> Nothing
- | otherwise -> Just $ ContainerId hn cn
- | otherwise = Nothing
- where
- desuffix = reverse . drop len . reverse
- len = length myContainerSuffix
-
-fromContainerId :: ContainerId -> String
-fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix
-
-containerHostName :: ContainerId -> HostName
-containerHostName (ContainerId _ cn) = cn2hn cn
-
-myContainerSuffix :: String
-myContainerSuffix = ".propellor"
-
-containerDesc :: ContainerId -> Property -> Property
-containerDesc cid p = p `describe` desc
- where
- desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p
-
-runningContainer :: ContainerId -> Image -> [RunParam] -> Property
-runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
- l <- liftIO $ listContainers RunningContainers
- if cid `elem` l
- then do
- -- Check if the ident has changed; if so the
- -- parameters of the container differ and it must
- -- be restarted.
- runningident <- liftIO $ getrunningident
- if runningident == Just ident
- then noChange
- else do
- void $ liftIO $ stopContainer cid
- restartcontainer
- else ifM (liftIO $ elem cid <$> listContainers AllContainers)
- ( restartcontainer
- , go image
- )
- where
- ident = ContainerIdent image hn cn runps
-
- restartcontainer = do
- oldimage <- liftIO $ fromMaybe image <$> commitContainer cid
- void $ liftIO $ removeContainer cid
- go oldimage
-
- getrunningident :: IO (Maybe ContainerIdent)
- getrunningident = simpleShClient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do
- let !v = extractident rs
- return v
-
- extractident :: [Resp] -> Maybe ContainerIdent
- extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout
-
- go img = do
- liftIO $ do
- clearProvisionedFlag cid
- createDirectoryIfMissing True (takeDirectory $ identFile cid)
- shim <- liftIO $ Shim.setup (localdir </> "propellor") (localdir </> shimdir cid)
- liftIO $ writeFile (identFile cid) (show ident)
- ensureProperty $ boolProperty "run" $ runContainer img
- (runps ++ ["-i", "-d", "-t"])
- [shim, "--docker", fromContainerId cid]
-
--- | Called when propellor is running inside a docker container.
--- The string should be the container's ContainerId.
---
--- This process is effectively init inside the container.
--- It even needs to wait on zombie processes!
---
--- Fork a thread to run the SimpleSh server in the background.
--- In the foreground, run an interactive bash (or sh) shell,
--- so that the user can interact with it when attached to the container.
---
--- When the system reboots, docker restarts the container, and this is run
--- again. So, to make the necessary services get started on boot, this needs
--- to provision the container then. However, if the container is already
--- being provisioned by the calling propellor, it would be redundant and
--- problimatic to also provisoon it here.
---
--- The solution is a flag file. If the flag file exists, then the container
--- was already provisioned. So, it must be a reboot, and time to provision
--- again. If the flag file doesn't exist, don't provision here.
-chain :: String -> IO ()
-chain s = case toContainerId s of
- Nothing -> error $ "Invalid ContainerId: " ++ s
- Just cid -> do
- changeWorkingDirectory localdir
- writeFile propellorIdent . show =<< readIdentFile cid
- -- Run boot provisioning before starting simpleSh,
- -- to avoid ever provisioning twice at the same time.
- whenM (checkProvisionedFlag cid) $ do
- let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
- unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ containerHostName cid]) $
- warningMessage "Boot provision failed!"
- void $ async $ job reapzombies
- void $ async $ job $ simpleSh $ namedPipe cid
- job $ do
- void $ tryIO $ ifM (inPath "bash")
- ( boolSystem "bash" [Param "-l"]
- , boolSystem "/bin/sh" []
- )
- putStrLn "Container is still running. Press ^P^Q to detach."
- where
- job = forever . void . tryIO
- reapzombies = void $ getAnyProcessStatus True False
-
--- | Once a container is running, propellor can be run inside
--- it to provision it.
---
--- Note that there is a race here, between the simplesh
--- server starting up in the container, and this property
--- being run. So, retry connections to the client for up to
--- 1 minute.
-provisionContainer :: ContainerId -> Property
-provisionContainer cid = containerDesc cid $ property "provision" $ liftIO $ do
- let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
- r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
- when (r /= FailedChange) $
- setProvisionedFlag cid
- return r
- where
- params = ["--continue", show $ Chain $ containerHostName cid]
-
- go lastline (v:rest) = case v of
- StdoutLine s -> do
- maybe noop putStrLn lastline
- hFlush stdout
- go (Just s) rest
- StderrLine s -> do
- maybe noop putStrLn lastline
- hFlush stdout
- hPutStrLn stderr s
- hFlush stderr
- go Nothing rest
- Done -> ret lastline
- go lastline [] = ret lastline
-
- ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline
-
-stopContainer :: ContainerId -> IO Bool
-stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]
-
-stoppedContainer :: ContainerId -> Property
-stoppedContainer cid = containerDesc cid $ property desc $
- ifM (liftIO $ elem cid <$> listContainers RunningContainers)
- ( liftIO cleanup `after` ensureProperty
- (boolProperty desc $ stopContainer cid)
- , return NoChange
- )
- where
- desc = "stopped"
- cleanup = do
- nukeFile $ namedPipe cid
- nukeFile $ identFile cid
- removeDirectoryRecursive $ shimdir cid
- clearProvisionedFlag cid
-
-removeContainer :: ContainerId -> IO Bool
-removeContainer cid = catchBoolIO $
- snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing
-
-removeImage :: Image -> IO Bool
-removeImage image = catchBoolIO $
- snd <$> processTranscript dockercmd ["rmi", image ] Nothing
-
-runContainer :: Image -> [RunParam] -> [String] -> IO Bool
-runContainer image ps cmd = boolSystem dockercmd $ map Param $
- "run" : (ps ++ image : cmd)
-
-commitContainer :: ContainerId -> IO (Maybe Image)
-commitContainer cid = catchMaybeIO $
- takeWhile (/= '\n')
- <$> readProcess dockercmd ["commit", fromContainerId cid]
-
-data ContainerFilter = RunningContainers | AllContainers
- deriving (Eq)
-
--- | Only lists propellor managed containers.
-listContainers :: ContainerFilter -> IO [ContainerId]
-listContainers status =
- catMaybes . map toContainerId . concat . map (split ",")
- . catMaybes . map (lastMaybe . words) . lines
- <$> readProcess dockercmd ps
- where
- ps
- | status == AllContainers = baseps ++ ["--all"]
- | otherwise = baseps
- baseps = ["ps", "--no-trunc"]
-
-listImages :: IO [Image]
-listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
-
-runProp :: String -> RunParam -> Property
-runProp field val = pureAttrProperty (param) $ \attr ->
- attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] }
- where
- param = field++"="++val
-
-genProp :: String -> (HostName -> RunParam) -> Property
-genProp field mkval = pureAttrProperty field $ \attr ->
- attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] }
-
--- | The ContainerIdent of a container is written to
--- /.propellor-ident inside it. This can be checked to see if
--- the container has the same ident later.
-propellorIdent :: FilePath
-propellorIdent = "/.propellor-ident"
-
--- | Named pipe used for communication with the container.
-namedPipe :: ContainerId -> FilePath
-namedPipe cid = "docker" </> fromContainerId cid
-
-provisionedFlag :: ContainerId -> FilePath
-provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned"
-
-clearProvisionedFlag :: ContainerId -> IO ()
-clearProvisionedFlag = nukeFile . provisionedFlag
-
-setProvisionedFlag :: ContainerId -> IO ()
-setProvisionedFlag cid = do
- createDirectoryIfMissing True (takeDirectory (provisionedFlag cid))
- writeFile (provisionedFlag cid) "1"
-
-checkProvisionedFlag :: ContainerId -> IO Bool
-checkProvisionedFlag = doesFileExist . provisionedFlag
-
-shimdir :: ContainerId -> FilePath
-shimdir cid = "docker" </> fromContainerId cid ++ ".shim"
-
-identFile :: ContainerId -> FilePath
-identFile cid = "docker" </> fromContainerId cid ++ ".ident"
-
-readIdentFile :: ContainerId -> IO ContainerIdent
-readIdentFile cid = fromMaybe (error "bad ident in identFile")
- . readish <$> readFile (identFile cid)
-
-dockercmd :: String
-dockercmd = "docker.io"
-
-report :: [Bool] -> Result
-report rmed
- | or rmed = MadeChange
- | otherwise = NoChange
-
diff --git a/Propellor/Property/Docker/Shim.hs b/Propellor/Property/Docker/Shim.hs
deleted file mode 100644
index c2f35d0c..00000000
--- a/Propellor/Property/Docker/Shim.hs
+++ /dev/null
@@ -1,61 +0,0 @@
--- | Support for running propellor, as built outside a docker container,
--- inside the container.
---
--- Note: This is currently Debian specific, due to glibcLibs.
-
-module Propellor.Property.Docker.Shim (setup, cleanEnv, file) where
-
-import Propellor
-import Utility.LinuxMkLibs
-import Utility.SafeCommand
-import Utility.Path
-import Utility.FileMode
-
-import Data.List
-import System.Posix.Files
-
--- | Sets up a shimmed version of the program, in a directory, and
--- returns its path.
-setup :: FilePath -> FilePath -> IO FilePath
-setup propellorbin dest = do
- createDirectoryIfMissing True dest
-
- libs <- parseLdd <$> readProcess "ldd" [propellorbin]
- glibclibs <- glibcLibs
- let libs' = nub $ libs ++ glibclibs
- libdirs <- map (dest ++) . nub . catMaybes
- <$> mapM (installLib installFile dest) libs'
-
- let linker = (dest ++) $
- fromMaybe (error "cannot find ld-linux linker") $
- headMaybe $ filter ("ld-linux" `isInfixOf`) libs'
- let gconvdir = (dest ++) $ parentDir $
- fromMaybe (error "cannot find gconv directory") $
- headMaybe $ filter ("/gconv/" `isInfixOf`) glibclibs
- let linkerparams = ["--library-path", intercalate ":" libdirs ]
- let shim = file propellorbin dest
- writeFile shim $ unlines
- [ "#!/bin/sh"
- , "GCONV_PATH=" ++ shellEscape gconvdir
- , "export GCONV_PATH"
- , "exec " ++ unwords (map shellEscape $ linker : linkerparams) ++
- " " ++ shellEscape propellorbin ++ " \"$@\""
- ]
- modifyFileMode shim (addModes executeModes)
- return shim
-
-cleanEnv :: IO ()
-cleanEnv = void $ unsetEnv "GCONV_PATH"
-
-file :: FilePath -> FilePath -> FilePath
-file propellorbin dest = dest </> takeFileName propellorbin
-
-installFile :: FilePath -> FilePath -> IO ()
-installFile top f = do
- createDirectoryIfMissing True destdir
- nukeFile dest
- createLink f dest `catchIO` (const copy)
- where
- copy = void $ boolSystem "cp" [Param "-a", Param f, Param dest]
- destdir = inTop top $ parentDir f
- dest = inTop top f
diff --git a/Propellor/Property/File.hs b/Propellor/Property/File.hs
deleted file mode 100644
index 0b060177..00000000
--- a/Propellor/Property/File.hs
+++ /dev/null
@@ -1,94 +0,0 @@
-module Propellor.Property.File where
-
-import Propellor
-import Utility.FileMode
-
-import System.Posix.Files
-import System.PosixCompat.Types
-
-type Line = String
-
--- | Replaces all the content of a file.
-hasContent :: FilePath -> [Line] -> Property
-f `hasContent` newcontent = fileProperty ("replace " ++ f)
- (\_oldcontent -> newcontent) f
-
--- | Ensures a file has contents that comes from PrivData.
---
--- The file's permissions are preserved if the file already existed.
--- Otherwise, they're set to 600.
-hasPrivContent :: FilePath -> Property
-hasPrivContent f = property desc $ withPrivData (PrivFile f) $ \privcontent ->
- ensureProperty $ fileProperty' writeFileProtected desc
- (\_oldcontent -> lines privcontent) f
- where
- desc = "privcontent " ++ f
-
--- | Leaves the file world-readable.
-hasPrivContentExposed :: FilePath -> Property
-hasPrivContentExposed f = hasPrivContent f `onChange`
- mode f (combineModes (ownerWriteMode:readModes))
-
--- | Ensures that a line is present in a file, adding it to the end if not.
-containsLine :: FilePath -> Line -> Property
-f `containsLine` l = f `containsLines` [l]
-
-containsLines :: FilePath -> [Line] -> Property
-f `containsLines` l = fileProperty (f ++ " contains:" ++ show l) go f
- where
- go ls
- | all (`elem` ls) l = ls
- | otherwise = ls++l
-
--- | Ensures that a line is not present in a file.
--- Note that the file is ensured to exist, so if it doesn't, an empty
--- file will be written.
-lacksLine :: FilePath -> Line -> Property
-f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f
-
--- | Removes a file. Does not remove symlinks or non-plain-files.
-notPresent :: FilePath -> Property
-notPresent f = check (doesFileExist f) $ property (f ++ " not present") $
- makeChange $ nukeFile f
-
-fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property
-fileProperty = fileProperty' writeFile
-fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property
-fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)
- where
- go True = do
- ls <- liftIO $ lines <$> readFile f
- let ls' = a ls
- if ls' == ls
- then noChange
- else makeChange $ viaTmp updatefile f (unlines ls')
- go False = makeChange $ writer f (unlines $ a [])
-
- -- viaTmp makes the temp file mode 600.
- -- Replicate the original file's owner and mode.
- updatefile f' content = do
- writer f' content
- s <- getFileStatus f
- setFileMode f' (fileMode s)
- setOwnerAndGroup f' (fileOwner s) (fileGroup s)
-
--- | Ensures a directory exists.
-dirExists :: FilePath -> Property
-dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $
- makeChange $ createDirectoryIfMissing True d
-
--- | Ensures that a file/dir has the specified owner and group.
-ownerGroup :: FilePath -> UserName -> GroupName -> Property
-ownerGroup f owner group = property (f ++ " owner " ++ og) $ do
- r <- ensureProperty $ cmdProperty "chown" [og, f]
- if r == FailedChange
- then return r
- else noChange
- where
- og = owner ++ ":" ++ group
-
--- | Ensures that a file/dir has the specfied mode.
-mode :: FilePath -> FileMode -> Property
-mode f v = property (f ++ " mode " ++ show v) $ do
- liftIO $ modifyFileMode f (\_old -> v)
- noChange
diff --git a/Propellor/Property/Git.hs b/Propellor/Property/Git.hs
deleted file mode 100644
index e5df7e48..00000000
--- a/Propellor/Property/Git.hs
+++ /dev/null
@@ -1,93 +0,0 @@
-module Propellor.Property.Git where
-
-import Propellor
-import Propellor.Property.File
-import qualified Propellor.Property.Apt as Apt
-import qualified Propellor.Property.Service as Service
-import Utility.SafeCommand
-
-import Data.List
-
--- | Exports all git repos in a directory (that user nobody can read)
--- using git-daemon, run from inetd.
---
--- Note that reverting this property does not remove or stop inetd.
-daemonRunning :: FilePath -> RevertableProperty
-daemonRunning exportdir = RevertableProperty setup unsetup
- where
- setup = containsLine conf (mkl "tcp4")
- `requires`
- containsLine conf (mkl "tcp6")
- `requires`
- dirExists exportdir
- `requires`
- Apt.serviceInstalledRunning "openbsd-inetd"
- `onChange`
- Service.running "openbsd-inetd"
- `describe` ("git-daemon exporting " ++ exportdir)
- unsetup = lacksLine conf (mkl "tcp4")
- `requires`
- lacksLine conf (mkl "tcp6")
- `onChange`
- Service.reloaded "openbsd-inetd"
-
- conf = "/etc/inetd.conf"
-
- mkl tcpv = intercalate "\t"
- [ "git"
- , "stream"
- , tcpv
- , "nowait"
- , "nobody"
- , "/usr/bin/git"
- , "git"
- , "daemon"
- , "--inetd"
- , "--export-all"
- , "--base-path=" ++ exportdir
- , exportdir
- ]
-
-installed :: Property
-installed = Apt.installed ["git"]
-
-type RepoUrl = String
-
-type Branch = String
-
--- | Specified git repository is cloned to the specified directory.
---
--- If the firectory exists with some other content, it will be recursively
--- deleted.
---
--- A branch can be specified, to check out.
-cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property
-cloned owner url dir mbranch = check originurl (property desc checkout)
- `requires` installed
- where
- desc = "git cloned " ++ url ++ " to " ++ dir
- gitconfig = dir </> ".git/config"
- originurl = ifM (doesFileExist gitconfig)
- ( do
- v <- catchDefaultIO Nothing $ headMaybe . lines <$>
- readProcess "git" ["config", "--file", gitconfig, "remote.origin.url"]
- return (v /= Just url)
- , return True
- )
- checkout = do
- liftIO $ do
- whenM (doesDirectoryExist dir) $
- removeDirectoryRecursive dir
- createDirectoryIfMissing True (takeDirectory dir)
- ensureProperty $ userScriptProperty owner $ catMaybes
- -- The </dev/null fixes an intermittent
- -- "fatal: read error: Bad file descriptor"
- -- when run across ssh with propellor --spin
- [ Just $ "git clone " ++ shellEscape url ++ " " ++ shellEscape dir ++ " < /dev/null"
- , Just $ "cd " ++ shellEscape dir
- , ("git checkout " ++) <$> mbranch
- -- In case this repo is exposted via the web,
- -- although the hook to do this ongoing is not
- -- installed here.
- , Just "git update-server-info"
- ]
diff --git a/Propellor/Property/Gpg.hs b/Propellor/Property/Gpg.hs
deleted file mode 100644
index 64ea9fea..00000000
--- a/Propellor/Property/Gpg.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-module Propellor.Property.Gpg where
-
-import Propellor
-import qualified Propellor.Property.Apt as Apt
-import Utility.FileSystemEncoding
-
-import System.PosixCompat
-
-installed :: Property
-installed = Apt.installed ["gnupg"]
-
--- | Sets up a user with a gpg key from the privdata.
---
--- Note that if a secret key is exported using gpg -a --export-secret-key,
--- the public key is also included. Or just a public key could be
--- exported, and this would set it up just as well.
---
--- Recommend only using this for low-value dedicated role keys.
--- No attempt has been made to scrub the key out of memory once it's used.
---
--- The GpgKeyId does not have to be a numeric id; it can just as easily
--- be a description of the key.
-keyImported :: GpgKeyId -> UserName -> Property
-keyImported keyid user = flagFile' (property desc go) genflag
- `requires` installed
- where
- desc = user ++ " has gpg key " ++ show keyid
- genflag = do
- d <- dotDir user
- return $ d </> ".propellor-imported-keyid-" ++ keyid
- go = withPrivData (GpgKey keyid) $ \key -> makeChange $
- withHandle StdinHandle createProcessSuccess
- (proc "su" ["-c", "gpg --import", user]) $ \h -> do
- fileEncoding h
- hPutStr h key
- hClose h
-
-dotDir :: UserName -> IO FilePath
-dotDir user = do
- home <- homeDirectory <$> getUserEntryForName user
- return $ home </> ".gnupg"
diff --git a/Propellor/Property/Hostname.hs b/Propellor/Property/Hostname.hs
deleted file mode 100644
index 031abb9d..00000000
--- a/Propellor/Property/Hostname.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-module Propellor.Property.Hostname where
-
-import Propellor
-import qualified Propellor.Property.File as File
-
--- | Ensures that the hostname is set to the HostAttr value.
--- Configures /etc/hostname and the current hostname.
---
--- A FQDN also configures /etc/hosts, with an entry for 127.0.1.1, which is
--- standard at least on Debian to set the FDQN (127.0.0.1 is localhost).
-sane :: Property
-sane = property ("sane hostname") (ensureProperty . setTo =<< getHostName)
-
-setTo :: HostName -> Property
-setTo hn = combineProperties desc go
- `onChange` cmdProperty "hostname" [basehost]
- where
- desc = "hostname " ++ hn
- (basehost, domain) = separate (== '.') hn
-
- go = catMaybes
- [ Just $ "/etc/hostname" `File.hasContent` [basehost]
- , if null domain
- then Nothing
- else Just $ File.fileProperty desc
- addhostline "/etc/hosts"
- ]
-
- hostip = "127.0.1.1"
- hostline = hostip ++ "\t" ++ hn ++ " " ++ basehost
-
- addhostline ls = hostline : filter (not . hashostip) ls
- hashostip l = headMaybe (words l) == Just hostip
diff --git a/Propellor/Property/Network.hs b/Propellor/Property/Network.hs
deleted file mode 100644
index 6009778a..00000000
--- a/Propellor/Property/Network.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-module Propellor.Property.Network where
-
-import Propellor
-import Propellor.Property.File
-
-interfaces :: FilePath
-interfaces = "/etc/network/interfaces"
-
--- | 6to4 ipv6 connection, should work anywhere
-ipv6to4 :: Property
-ipv6to4 = fileProperty "ipv6to4" go interfaces
- `onChange` ifUp "sit0"
- where
- go ls
- | all (`elem` ls) stanza = ls
- | otherwise = ls ++ stanza
- stanza =
- [ "# Automatically added by propeller"
- , "iface sit0 inet6 static"
- , "\taddress 2002:5044:5531::1"
- , "\tnetmask 64"
- , "\tgateway ::192.88.99.1"
- , "auto sit0"
- , "# End automatically added by propeller"
- ]
-
-type Interface = String
-
-ifUp :: Interface -> Property
-ifUp iface = cmdProperty "ifup" [iface]
diff --git a/Propellor/Property/Obnam.hs b/Propellor/Property/Obnam.hs
deleted file mode 100644
index 32374b57..00000000
--- a/Propellor/Property/Obnam.hs
+++ /dev/null
@@ -1,155 +0,0 @@
-module Propellor.Property.Obnam where
-
-import Propellor
-import qualified Propellor.Property.Apt as Apt
-import qualified Propellor.Property.Cron as Cron
-import Utility.SafeCommand
-
-import Data.List
-
-type ObnamParam = String
-
--- | An obnam repository can be used by multiple clients. Obnam uses
--- locking to allow only one client to write at a time. Since stale lock
--- files can prevent backups from happening, it's more robust, if you know
--- a repository has only one client, to force the lock before starting a
--- backup. Using OnlyClient allows propellor to do so when running obnam.
-data NumClients = OnlyClient | MultipleClients
- deriving (Eq)
-
--- | Installs a cron job that causes a given directory to be backed
--- up, by running obnam with some parameters.
---
--- If the directory does not exist, or exists but is completely empty,
--- this Property will immediately restore it from an existing backup.
---
--- So, this property can be used to deploy a directory of content
--- to a host, while also ensuring any changes made to it get backed up.
--- And since Obnam encrypts, just make this property depend on a gpg
--- key, and tell obnam to use the key, and your data will be backed
--- up securely. For example:
---
--- > & Obnam.backup "/srv/git" "33 3 * * *"
--- > [ "--repository=sftp://2318@usw-s002.rsync.net/~/mygitrepos.obnam"
--- > , "--encrypt-with=1B169BE1"
--- > ] Obnam.OnlyClient
--- > `requires` Gpg.keyImported "1B169BE1" "root"
--- > `requires` Ssh.keyImported SshRsa "root"
---
--- How awesome is that?
-backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property
-backup dir crontimes params numclients = cronjob `describe` desc
- `requires` restored dir params
- where
- desc = dir ++ " backed up by obnam"
- cronjob = Cron.niceJob ("obnam_backup" ++ dir) crontimes "root" "/" $
- intercalate ";" $ catMaybes
- [ if numclients == OnlyClient
- then Just $ unwords $
- [ "obnam"
- , "force-lock"
- ] ++ map shellEscape params
- else Nothing
- , Just $ unwords $
- [ "obnam"
- , "backup"
- , shellEscape dir
- ] ++ map shellEscape params
- ]
-
--- | Restores a directory from an obnam backup.
---
--- Only does anything if the directory does not exist, or exists,
--- but is completely empty.
---
--- The restore is performed atomically; restoring to a temp directory
--- and then moving it to the directory.
-restored :: FilePath -> [ObnamParam] -> Property
-restored dir params = property (dir ++ " restored by obnam") go
- `requires` installed
- where
- go = ifM (liftIO needsRestore)
- ( do
- warningMessage $ dir ++ " is empty/missing; restoring from backup ..."
- liftIO restore
- , noChange
- )
-
- needsRestore = null <$> catchDefaultIO [] (dirContents dir)
-
- restore = withTmpDirIn (takeDirectory dir) "obnam-restore" $ \tmpdir -> do
- ok <- boolSystem "obnam" $
- [ Param "restore"
- , Param "--to"
- , Param tmpdir
- ] ++ map Param params
- let restoreddir = tmpdir ++ "/" ++ dir
- ifM (pure ok <&&> doesDirectoryExist restoreddir)
- ( do
- void $ tryIO $ removeDirectory dir
- renameDirectory restoreddir dir
- return MadeChange
- , return FailedChange
- )
-
-installed :: Property
-installed = Apt.installed ["obnam"]
-
--- | Ensures that a recent version of obnam gets installed.
---
--- Only does anything for Debian Stable.
-latestVersion :: Property
-latestVersion = withOS "obnam latest version" $ \o -> case o of
- (Just (System (Debian suite) _)) | isStable suite -> ensureProperty $
- Apt.setSourcesListD (sources suite) "obnam"
- `requires` toProp (Apt.trustsKey key)
- _ -> noChange
- where
- sources suite =
- [ "deb http://code.liw.fi/debian " ++ Apt.showSuite suite ++ " main"
- ]
- -- gpg key used by the code.liw.fi repository.
- key = Apt.AptKey "obnam" $ unlines
- [ "-----BEGIN PGP PUBLIC KEY BLOCK-----"
- , "Version: GnuPG v1.4.9 (GNU/Linux)"
- , ""
- , "mQGiBEfzuTgRBACcVNG/H6QJqLx5qiQs2zmPe6D6BWOWHfgNgG4IWzNstm21YDxb"
- , "KqwFG0gxcnZJGHkXAhkSfqTokYd0lc5eBemcA1pkceNjzMEX8wwiZ810HzJD4eEH"
- , "sjoWR8+qKrZeixzZqReAfqztcXoBGKQ0u1R1vpg1txUa75OM4BUqaUbsmwCgmS4x"
- , "DjMxSaUSPuu6vQ7ZGZBXSP0D/RQw8DBHMfsv3DiaqFqk8tkuUkpMFPIekHidSHlO"
- , "EACbncqbbyHksyCpFNVNcQIDHrOLjOZK9BAXkSd8I3ww7U+nLdDcCblrW8CZnJtm"
- , "ZYrxfaXaHZ/It9/RCAsQ+c8xtmyUPjsf//4Vf8olxNQHzgBSe5/LJRi4Vd53he+K"
- , "YP4LA/9IZbjvVmm8+8Y0pQrTHlI6nTImtzdBXHc4+T3lLBj9XODHLozC2kSBOQky"
- , "q/EisTITHTXL8vYg4NsKm5RTbPAuBwdtxcny8CXfOqKtGOdrebmKotGllTozzdPv"
- , "9p53cuce6oJ2oMUodc074JOGTWwDSgLiJX4nViGcU1wy/vtQnrQkY29kZS5saXcu"
- , "ZmkgYXJjaGl2ZSBrZXkgPGxpd0BsaXcuZmk+iGAEExECACAFAkfzuTgCGwMGCwkI"
- , "BwMCBBUCCAMEFgIDAQIeAQIXgAAKCRBG53tJR95LscKrAJ0ZtKqa2x6Kplwa2mzx"
- , "ItImbIGMJACdETqofDYzUN91yLAFlOnxAyrE+UyIRgQQEQIABgUCSFd5GgAKCRAf"
- , "u5W/LZrMjqr8AJ4xPVHpW8ZNlgMwDSVb075RnA2DiACgg2SR69jAHFQOWV6xfLRr"
- , "vh0bLKGJAhwEEAEIAAYFAktEyIwACgkQ61zh116FEfm7Lg//Wiy3TjWAk8YHUddv"
- , "zOioYzCxQ985GsVhJGAVPqSGOc9vfTWBJZ8J3l0NnYTRpEGucmbF9G+mAt9iGXu6"
- , "7yZkxyFdvbo7EDsqMU1wLOM6PiU+Un63MKlbTNmFn7OKE8aXPRAFgcyUO/qjdqoD"
- , "sa9FgU5Z0f60m9qah6BPXH6IzMLHYoiP7t8rCBIwLgyl3w2w+Fjt1DFpbW9Kb7jz"
- , "i8jFvC8jPmxV8xh2OSgVZyNk4qg6hIV8GVQY7AJt8OurZSckgQd7ifHK9JTGohtF"
- , "tXCiqeDEvnMF4A9HI/TcXJBzonZ8ds1JCq42nSSKmL+8TyjtUSD/xHygazuc0CK0"
- , "hFnQWBub60IfyV6F0oTagJ8cmARv2sezHAeHDkzPHE8RdjgktazH1eJrA4LheEd6"
- , "KeSnVtYWpw8dgMv5PleFyQiAj/t3C/N50fd15tUyfnH15G7nFjMQV2Yx35uwSxOj"
- , "376OWnDN/YGTNk283XXULbyVJYR8Q2unso20XQ94yQ2A5EpHHPrHoLxrL/ydM08d"
- , "nvKstLZIZtal1seiMkymtlSiGz25A5oqsclwS6VZCKdWA8HO/wlElOMcaHyl6Y1y"
- , "gYP7y9O5yFYKFOrCH0nFjJbwmkRiBLsxuuWsYgJigVGq/atSrtawkHdshpCw0HCY"
- , "N/RFcWkJ864BdsO0C0sDzueNkQO5Ag0ER/O5RBAIAJiwPH9tyJTgXcC2Y4XWboOq"
- , "rx5CkOnr5b45oS9cK2eIJ8TKxE3XgKLxUr3mIH0QR2kZgDOwNl0WY+7/CXjn+Spn"
- , "BokPg54rafEUePodGpGdUXdgrHhAMHYjh8fXFJ1SlQcg46/zc1wDI7jBCkGrK3V8"
- , "5cXDqwTFTN5LcjoSRWeM4Voa6pEfDdL3rMlnOw9R9gDHRBBb6CDSjWXqM86pR889"
- , "5QrR0SDwiJNrMoyxSjMXFKGBQAsYHJ82myZrlbuZbroZjVp5Uh7eB1ZiPljNVtcr"
- , "sksACIWBCo1rvLzrPXsLYOeV3cDDtYAkSwGfuzC1Etbe+qgfIroFTOqdefMw4s8A"
- , "AwUH/0KLXm4MS54QQspg3evu4Q4U/E8Hem5/FqB0GhBCitQ4rUsucKyY8/ItpUn5"
- , "ismLE60bQqka+Mzd/Zw18TCTzImv0ozAaZ2sNtBado7f6jcC8EDfY5zzK1ukcsAr"
- , "Qc5hdLHYuTQW5KpA6fKaW969OUzIwPbdVaCOLOBpxKC6N6iBspQYd6uiQtLw6EUO"
- , "50oQqUiJABf0eOocvdw5e2KQQpuC3205+VMYtyl4w3pdJihK8NK0AikGXzDVsbQt"
- , "l8kmB5ZrN4WIKhMke1FxbqQC5Q3XATvYRzpzzisZb/HYGNti8W6du5EUwJ0D2NRh"
- , "cu+twocOzW0VKfmrDApfifJ9OsSISQQYEQIACQUCR/O5RAIbDAAKCRBG53tJR95L"
- , "seQOAJ95KUyzjRjdYgZkDC69Mgu25L86UACdGduINUaRly43ag4kwUXxpqswBBM="
- , "=i2c3"
- , "-----END PGP PUBLIC KEY BLOCK-----"
- ]
diff --git a/Propellor/Property/OpenId.hs b/Propellor/Property/OpenId.hs
deleted file mode 100644
index 051d6425..00000000
--- a/Propellor/Property/OpenId.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-module Propellor.Property.OpenId where
-
-import Propellor
-import qualified Propellor.Property.File as File
-import qualified Propellor.Property.Apt as Apt
-import qualified Propellor.Property.Service as Service
-
-import Data.List
-
-providerFor :: [UserName] -> String -> Property
-providerFor users baseurl = propertyList desc $
- [ Apt.serviceInstalledRunning "apache2"
- , Apt.installed ["simpleid"]
- `onChange` Service.restarted "apache2"
- , File.fileProperty (desc ++ " configured")
- (map setbaseurl) "/etc/simpleid/config.inc"
- ] ++ map identfile users
- where
- url = "http://"++baseurl++"/simpleid"
- desc = "openid provider " ++ url
- setbaseurl l
- | "SIMPLEID_BASE_URL" `isInfixOf` l =
- "define('SIMPLEID_BASE_URL', '"++url++"');"
- | otherwise = l
-
- -- the identitites directory controls access, so open up
- -- file mode
- identfile u = File.hasPrivContentExposed $
- concat $ [ "/var/lib/simpleid/identities/", u, ".identity" ]
diff --git a/Propellor/Property/Postfix.hs b/Propellor/Property/Postfix.hs
deleted file mode 100644
index 9fa4a2c3..00000000
--- a/Propellor/Property/Postfix.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-module Propellor.Property.Postfix where
-
-import Propellor
-import qualified Propellor.Property.Apt as Apt
-
-installed :: Property
-installed = Apt.serviceInstalledRunning "postfix"
-
--- | Configures postfix as a satellite system, which
--- relats all mail through a relay host, which defaults to smtp.domain.
---
--- The smarthost may refuse to relay mail on to other domains, without
--- futher coniguration/keys. But this should be enough to get cron job
--- mail flowing to a place where it will be seen.
-satellite :: Property
-satellite = setup `requires` installed
- where
- setup = trivial $ property "postfix satellite system" $ do
- hn <- getHostName
- ensureProperty $ Apt.reConfigure "postfix"
- [ ("postfix/main_mailer_type", "select", "Satellite system")
- , ("postfix/root_address", "string", "root")
- , ("postfix/destinations", "string", " ")
- , ("postfix/mailname", "string", hn)
- ]
diff --git a/Propellor/Property/Reboot.hs b/Propellor/Property/Reboot.hs
deleted file mode 100644
index 25e53159..00000000
--- a/Propellor/Property/Reboot.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Propellor.Property.Reboot where
-
-import Propellor
-
-now :: Property
-now = cmdProperty "reboot" []
- `describe` "reboot now"
diff --git a/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs
deleted file mode 100644
index f2911e50..00000000
--- a/Propellor/Property/Scheduled.hs
+++ /dev/null
@@ -1,67 +0,0 @@
-module Propellor.Property.Scheduled
- ( period
- , periodParse
- , Recurrance(..)
- , WeekDay
- , MonthDay
- , YearDay
- ) where
-
-import Propellor
-import Utility.Scheduled
-
-import Data.Time.Clock
-import Data.Time.LocalTime
-import qualified Data.Map as M
-
--- | Makes a Property only be checked every so often.
---
--- This uses the description of the Property to keep track of when it was
--- last run.
-period :: Property -> Recurrance -> Property
-period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy -> do
- lasttime <- liftIO $ getLastChecked (propertyDesc prop)
- nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
- t <- liftIO localNow
- if Just t >= nexttime
- then do
- r <- satisfy
- liftIO $ setLastChecked t (propertyDesc prop)
- return r
- else noChange
- where
- schedule = Schedule recurrance AnyTime
- desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"
-
--- | Like period, but parse a human-friendly string.
-periodParse :: Property -> String -> Property
-periodParse prop s = case toRecurrance s of
- Just recurrance -> period prop recurrance
- Nothing -> property "periodParse" $ do
- liftIO $ warningMessage $ "failed periodParse: " ++ s
- noChange
-
-lastCheckedFile :: FilePath
-lastCheckedFile = localdir </> ".lastchecked"
-
-getLastChecked :: Desc -> IO (Maybe LocalTime)
-getLastChecked desc = M.lookup desc <$> readLastChecked
-
-localNow :: IO LocalTime
-localNow = do
- now <- getCurrentTime
- tz <- getTimeZone now
- return $ utcToLocalTime tz now
-
-setLastChecked :: LocalTime -> Desc -> IO ()
-setLastChecked time desc = do
- m <- readLastChecked
- writeLastChecked (M.insert desc time m)
-
-readLastChecked :: IO (M.Map Desc LocalTime)
-readLastChecked = fromMaybe M.empty <$> catchDefaultIO Nothing go
- where
- go = readish <$> readFileStrict lastCheckedFile
-
-writeLastChecked :: M.Map Desc LocalTime -> IO ()
-writeLastChecked = writeFile lastCheckedFile . show
diff --git a/Propellor/Property/Service.hs b/Propellor/Property/Service.hs
deleted file mode 100644
index 14e769d0..00000000
--- a/Propellor/Property/Service.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-module Propellor.Property.Service where
-
-import Propellor
-import Utility.SafeCommand
-
-type ServiceName = String
-
--- | Ensures that a service is running. Does not ensure that
--- any package providing that service is installed. See
--- Apt.serviceInstalledRunning
---
--- Note that due to the general poor state of init scripts, the best
--- we can do is try to start the service, and if it fails, assume
--- this means it's already running.
-running :: ServiceName -> Property
-running svc = property ("running " ++ svc) $ do
- void $ ensureProperty $
- scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"]
- return NoChange
-
-restarted :: ServiceName -> Property
-restarted svc = property ("restarted " ++ svc) $ do
- void $ ensureProperty $
- scriptProperty ["service " ++ shellEscape svc ++ " restart >/dev/null 2>&1 || true"]
- return NoChange
-
-reloaded :: ServiceName -> Property
-reloaded svc = property ("reloaded " ++ svc) $ do
- void $ ensureProperty $
- scriptProperty ["service " ++ shellEscape svc ++ " reload >/dev/null 2>&1 || true"]
- return NoChange
diff --git a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
deleted file mode 100644
index 677aa760..00000000
--- a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ /dev/null
@@ -1,57 +0,0 @@
-module Propellor.Property.SiteSpecific.GitAnnexBuilder where
-
-import Propellor
-import qualified Propellor.Property.Apt as Apt
-import qualified Propellor.Property.User as User
-import qualified Propellor.Property.Cron as Cron
-import Propellor.Property.Cron (CronTimes)
-
-builduser :: UserName
-builduser = "builder"
-
-homedir :: FilePath
-homedir = "/home/builder"
-
-gitbuilderdir :: FilePath
-gitbuilderdir = homedir </> "gitbuilder"
-
-builddir :: FilePath
-builddir = gitbuilderdir </> "build"
-
-builder :: Architecture -> CronTimes -> Bool -> Property
-builder arch crontimes rsyncupload = combineProperties "gitannexbuilder"
- [ Apt.stdSourcesList Unstable
- , Apt.buildDep ["git-annex"]
- , Apt.installed ["git", "rsync", "moreutils", "ca-certificates",
- "liblockfile-simple-perl", "cabal-install", "vim", "less"]
- , Apt.serviceInstalledRunning "cron"
- , User.accountFor builduser
- , check (not <$> doesDirectoryExist gitbuilderdir) $ userScriptProperty builduser
- [ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir
- , "cd " ++ gitbuilderdir
- , "git checkout " ++ arch
- ]
- `describe` "gitbuilder setup"
- , check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser
- [ "git clone git://git-annex.branchable.com/ " ++ builddir
- ]
- , "git-annex source build deps installed" ==> Apt.buildDepIn builddir
- , Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir "git pull ; ./autobuild"
- -- The builduser account does not have a password set,
- -- instead use the password privdata to hold the rsync server
- -- password used to upload the built image.
- , property "rsync password" $ do
- let f = homedir </> "rsyncpassword"
- if rsyncupload
- then withPrivData (Password builduser) $ \p -> do
- oldp <- liftIO $ catchDefaultIO "" $
- readFileStrict f
- if p /= oldp
- then makeChange $ writeFile f p
- else noChange
- else do
- ifM (liftIO $ doesFileExist f)
- ( noChange
- , makeChange $ writeFile f "no password configured"
- )
- ]
diff --git a/Propellor/Property/SiteSpecific/GitHome.hs b/Propellor/Property/SiteSpecific/GitHome.hs
deleted file mode 100644
index 6ed02146..00000000
--- a/Propellor/Property/SiteSpecific/GitHome.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-module Propellor.Property.SiteSpecific.GitHome where
-
-import Propellor
-import qualified Propellor.Property.Apt as Apt
-import Propellor.Property.User
-import Utility.SafeCommand
-
--- | Clones Joey Hess's git home directory, and runs its fixups script.
-installedFor :: UserName -> Property
-installedFor user = check (not <$> hasGitDir user) $
- property ("githome " ++ user) (go =<< liftIO (homedir user))
- `requires` Apt.installed ["git"]
- where
- go home = do
- let tmpdir = home </> "githome"
- ensureProperty $ combineProperties "githome setup"
- [ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir]
- , property "moveout" $ makeChange $ void $
- moveout tmpdir home
- , property "rmdir" $ makeChange $ void $
- catchMaybeIO $ removeDirectory tmpdir
- , userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; bin/mr checkout; bin/fixups"]
- ]
- moveout tmpdir home = do
- fs <- dirContents tmpdir
- forM fs $ \f -> boolSystem "mv" [File f, File home]
-
-url :: String
-url = "git://git.kitenet.net/joey/home"
-
-hasGitDir :: UserName -> IO Bool
-hasGitDir user = go =<< homedir user
- where
- go home = doesDirectoryExist (home </> ".git")
diff --git a/Propellor/Property/SiteSpecific/JoeySites.hs b/Propellor/Property/SiteSpecific/JoeySites.hs
deleted file mode 100644
index 28b3dffd..00000000
--- a/Propellor/Property/SiteSpecific/JoeySites.hs
+++ /dev/null
@@ -1,314 +0,0 @@
--- | Specific configuation for Joey Hess's sites. Probably not useful to
--- others except as an example.
-
-module Propellor.Property.SiteSpecific.JoeySites where
-
-import Propellor
-import qualified Propellor.Property.Apt as Apt
-import qualified Propellor.Property.File as File
-import qualified Propellor.Property.Gpg as Gpg
-import qualified Propellor.Property.Ssh as Ssh
-import qualified Propellor.Property.Git as Git
-import qualified Propellor.Property.Cron as Cron
-import qualified Propellor.Property.Service as Service
-import qualified Propellor.Property.User as User
-import qualified Propellor.Property.Obnam as Obnam
-import qualified Propellor.Property.Apache as Apache
-import Utility.SafeCommand
-import Utility.FileMode
-
-import Data.List
-import System.Posix.Files
-
-oldUseNetServer :: [Host] -> Property
-oldUseNetServer hosts = propertyList ("olduse.net server")
- [ oldUseNetInstalled "oldusenet-server"
- , Obnam.latestVersion
- , Obnam.backup datadir "33 4 * * *"
- [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net"
- , "--client-name=spool"
- ] Obnam.OnlyClient
- `requires` Ssh.keyImported SshRsa "root"
- `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
- , check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $
- property "olduse.net spool in place" $ makeChange $ do
- removeDirectoryRecursive newsspool
- createSymbolicLink (datadir </> "news") newsspool
- , Apt.installed ["leafnode"]
- , "/etc/news/leafnode/config" `File.hasContent`
- [ "# olduse.net configuration (deployed by propellor)"
- , "expire = 1000000" -- no expiry via texpire
- , "server = " -- no upstream server
- , "debugmode = 1"
- , "allowSTRANGERS = 42" -- lets anyone connect
- , "nopost = 1" -- no new posting (just gather them)
- ]
- , "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL"
- , Apt.serviceInstalledRunning "openbsd-inetd"
- , File.notPresent "/etc/cron.daily/leafnode"
- , File.notPresent "/etc/cron.d/leafnode"
- , Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool $ intercalate ";"
- [ "find \\( -path ./out.going -or -path ./interesting.groups -or -path './*/.overview' \\) -prune -or -type f -ctime +60 -print | xargs --no-run-if-empty rm"
- , "find -type d -empty | xargs --no-run-if-empty rmdir"
- ]
- , Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" $
- "/usr/bin/uucp " ++ datadir
- , toProp $ Apache.siteEnabled "nntp.olduse.net" $ apachecfg "nntp.olduse.net" False
- [ " DocumentRoot " ++ datadir ++ "/"
- , " <Directory " ++ datadir ++ "/>"
- , " Options Indexes FollowSymlinks"
- , " AllowOverride None"
- -- I had this in the file before.
- -- This may be needed by a newer version of apache?
- --, " Require all granted"
- , " </Directory>"
- ]
- ]
- where
- newsspool = "/var/spool/news"
- datadir = "/var/spool/oldusenet"
-
-oldUseNetShellBox :: Property
-oldUseNetShellBox = oldUseNetInstalled "oldusenet"
-
-oldUseNetInstalled :: Apt.Package -> Property
-oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
- propertyList ("olduse.net " ++ pkg)
- [ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev")
- `describe` "olduse.net build deps"
- , scriptProperty
- [ "rm -rf /root/tmp/oldusenet" -- idenpotency
- , "git clone git://olduse.net/ /root/tmp/oldusenet/source"
- , "cd /root/tmp/oldusenet/source/"
- , "dpkg-buildpackage -us -uc"
- , "dpkg -i ../" ++ pkg ++ "_*.deb || true"
- , "apt-get -fy install" -- dependencies
- , "rm -rf /root/tmp/oldusenet"
- ] `describe` "olduse.net built"
- ]
-
-
-kgbServer :: Property
-kgbServer = withOS desc $ \o -> case o of
- (Just (System (Debian Unstable) _)) ->
- ensureProperty $ propertyList desc
- [ Apt.serviceInstalledRunning "kgb-bot"
- , File.hasPrivContent "/etc/kgb-bot/kgb.conf"
- `onChange` Service.restarted "kgb-bot"
- , "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1"
- `describe` "kgb bot enabled"
- `onChange` Service.running "kgb-bot"
- ]
- _ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)"
- where
- desc = "kgb.kitenet.net setup"
-
-mumbleServer :: [Host] -> Property
-mumbleServer hosts = combineProperties "mumble.debian.net"
- [ Apt.serviceInstalledRunning "mumble-server"
- , Obnam.latestVersion
- , Obnam.backup "/var/lib/mumble-server" "55 5 * * *"
- [ "--repository=sftp://joey@turtle.kitenet.net/~/lib/backup/mumble.debian.net.obnam"
- , "--client-name=mumble"
- ] Obnam.OnlyClient
- `requires` Ssh.keyImported SshRsa "root"
- `requires` Ssh.knownHost hosts "turtle.kitenet.net" "root"
- , trivial $ cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"]
- ]
-
-obnamLowMem :: Property
-obnamLowMem = combineProperties "obnam tuned for low memory use"
- [ Obnam.latestVersion
- , "/etc/obnam.conf" `File.containsLines`
- [ "[config]"
- , "# Suggested by liw to keep Obnam memory consumption down (at some speed cost)."
- , "upload-queue-size = 128"
- , "lru-size = 128"
- ]
- ]
-
--- git.kitenet.net and git.joeyh.name
-gitServer :: [Host] -> Property
-gitServer hosts = propertyList "git.kitenet.net setup"
- [ Obnam.latestVersion
- , Obnam.backup "/srv/git" "33 3 * * *"
- [ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net"
- , "--encrypt-with=1B169BE1"
- , "--client-name=wren"
- ] Obnam.OnlyClient
- `requires` Gpg.keyImported "1B169BE1" "root"
- `requires` Ssh.keyImported SshRsa "root"
- `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
- `requires` Ssh.authorizedKeys "family"
- `requires` User.accountFor "family"
- , Apt.installed ["git", "rsync", "kgb-client-git", "gitweb"]
- , Apt.installedBackport ["git-annex"]
- , File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf"
- , toProp $ Git.daemonRunning "/srv/git"
- , "/etc/gitweb.conf" `File.containsLines`
- [ "$projectroot = '/srv/git';"
- , "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');"
- , "# disable snapshot download; overloads server"
- , "$feature{'snapshot'}{'default'} = [];"
- ]
- `describe` "gitweb configured"
- -- Repos push on to github.
- , Ssh.knownHost hosts "github.com" "joey"
- -- I keep the website used for gitweb checked into git..
- , Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing
- , website "git.kitenet.net"
- , website "git.joeyh.name"
- , toProp $ Apache.modEnabled "cgi"
- ]
- where
- website hn = toProp $ Apache.siteEnabled hn $ apachecfg hn True
- [ " DocumentRoot /srv/web/git.kitenet.net/"
- , " <Directory /srv/web/git.kitenet.net/>"
- , " Options Indexes ExecCGI FollowSymlinks"
- , " AllowOverride None"
- , " AddHandler cgi-script .cgi"
- , " DirectoryIndex index.cgi"
- , " </Directory>"
- , ""
- , " ScriptAlias /cgi-bin/ /usr/lib/cgi-bin/"
- , " <Directory /usr/lib/cgi-bin>"
- , " SetHandler cgi-script"
- , " Options ExecCGI"
- , " </Directory>"
- ]
-
-type AnnexUUID = String
-
--- | A website, with files coming from a git-annex repository.
-annexWebSite :: [Host] -> Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property
-annexWebSite hosts origin hn uuid remotes = propertyList (hn ++" website using git-annex")
- [ Git.cloned "joey" origin dir Nothing
- `onChange` setup
- , postupdatehook `File.hasContent`
- [ "#!/bin/sh"
- , "exec git update-server-info"
- ] `onChange`
- (postupdatehook `File.mode` (combineModes (ownerWriteMode:readModes ++ executeModes)))
- , setupapache
- ]
- where
- dir = "/srv/web/" ++ hn
- postupdatehook = dir </> ".git/hooks/post-update"
- setup = userScriptProperty "joey" setupscript
- `requires` Ssh.keyImported SshRsa "joey"
- `requires` Ssh.knownHost hosts "turtle.kitenet.net" "joey"
- setupscript =
- [ "cd " ++ shellEscape dir
- , "git config annex.uuid " ++ shellEscape uuid
- ] ++ map addremote remotes ++
- [ "git annex get"
- ]
- addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url
- setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $
- [ " ServerAlias www."++hn
- , ""
- , " DocumentRoot /srv/web/"++hn
- , " <Directory /srv/web/"++hn++">"
- , " Options FollowSymLinks"
- , " AllowOverride None"
- , " </Directory>"
- , " <Directory /srv/web/"++hn++">"
- , " Options Indexes FollowSymLinks ExecCGI"
- , " AllowOverride None"
- , " AddHandler cgi-script .cgi"
- , " DirectoryIndex index.html index.cgi"
- , " Order allow,deny"
- , " allow from all"
- , " </Directory>"
- ]
-
-apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile
-apachecfg hn withssl middle
- | withssl = vhost False ++ vhost True
- | otherwise = vhost False
- where
- vhost ssl =
- [ "<VirtualHost *:"++show port++">"
- , " ServerAdmin grue@joeyh.name"
- , " ServerName "++hn++":"++show port
- ]
- ++ mainhttpscert ssl
- ++ middle ++
- [ ""
- , " ErrorLog /var/log/apache2/error.log"
- , " LogLevel warn"
- , " CustomLog /var/log/apache2/access.log combined"
- , " ServerSignature On"
- , " "
- , " <Directory \"/usr/share/apache2/icons\">"
- , " Options Indexes MultiViews"
- , " AllowOverride None"
- , " Order allow,deny"
- , " Allow from all"
- , " </Directory>"
- , "</VirtualHost>"
- ]
- where
- port = if ssl then 443 else 80 :: Int
-
-mainhttpscert :: Bool -> Apache.ConfigFile
-mainhttpscert False = []
-mainhttpscert True =
- [ " SSLEngine on"
- , " SSLCertificateFile /etc/ssl/certs/web.pem"
- , " SSLCertificateKeyFile /etc/ssl/private/web.pem"
- , " SSLCertificateChainFile /etc/ssl/certs/startssl.pem"
- ]
-
-gitAnnexDistributor :: Property
-gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer"
- [ Apt.installed ["rsync"]
- , File.hasPrivContent "/etc/rsyncd.conf"
- , File.hasPrivContent "/etc/rsyncd.secrets"
- , "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true"
- `onChange` Service.running "rsync"
- , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild"
- , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks"
- -- git-annex distribution signing key
- , Gpg.keyImported "89C809CB" "joey"
- ]
- where
- endpoint d = combineProperties ("endpoint " ++ d)
- [ File.dirExists d
- , File.ownerGroup d "joey" "joey"
- ]
-
--- Twitter, you kill us.
-twitRss :: Property
-twitRss = combineProperties "twitter rss"
- [ Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing
- , check (not <$> doesFileExist (dir </> "twitRss")) $
- userScriptProperty "joey"
- [ "cd " ++ dir
- , "ghc --make twitRss"
- ]
- `requires` Apt.installed
- [ "libghc-xml-dev"
- , "libghc-feed-dev"
- , "libghc-tagsoup-dev"
- ]
- , feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter"
- , feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep"
- ]
- where
- dir = "/srv/web/tmp.kitenet.net/twitrss"
- crontime = "15 * * * *"
- feed url desc = Cron.job desc crontime "joey" dir $
- "./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss")
-
-ircBouncer :: Property
-ircBouncer = propertyList "IRC bouncer"
- [ Apt.installed ["znc"]
- , User.accountFor "znc"
- , File.hasPrivContent conf
- , File.ownerGroup conf "znc" "znc"
- , Cron.job "znconboot" "@reboot" "znc" "~" "znc"
- , Cron.job "zncrunning" "@hourly" "znc" "~" "znc || true"
- ]
- where
- conf = "/home/znc/.znc/configs/znc.conf"
diff --git a/Propellor/Property/Ssh.hs b/Propellor/Property/Ssh.hs
deleted file mode 100644
index a4f87678..00000000
--- a/Propellor/Property/Ssh.hs
+++ /dev/null
@@ -1,152 +0,0 @@
-module Propellor.Property.Ssh (
- setSshdConfig,
- permitRootLogin,
- passwordAuthentication,
- hasAuthorizedKeys,
- restartSshd,
- randomHostKeys,
- hostKey,
- keyImported,
- knownHost,
- authorizedKeys
-) where
-
-import Propellor
-import qualified Propellor.Property.File as File
-import Propellor.Property.User
-import Utility.SafeCommand
-import Utility.FileMode
-
-import System.PosixCompat
-
-sshBool :: Bool -> String
-sshBool True = "yes"
-sshBool False = "no"
-
-sshdConfig :: FilePath
-sshdConfig = "/etc/ssh/sshd_config"
-
-setSshdConfig :: String -> Bool -> Property
-setSshdConfig setting allowed = combineProperties "sshd config"
- [ sshdConfig `File.lacksLine` (sshline $ not allowed)
- , sshdConfig `File.containsLine` (sshline allowed)
- ]
- `onChange` restartSshd
- `describe` unwords [ "ssh config:", setting, sshBool allowed ]
- where
- sshline v = setting ++ " " ++ sshBool v
-
-permitRootLogin :: Bool -> Property
-permitRootLogin = setSshdConfig "PermitRootLogin"
-
-passwordAuthentication :: Bool -> Property
-passwordAuthentication = setSshdConfig "PasswordAuthentication"
-
-dotDir :: UserName -> IO FilePath
-dotDir user = do
- h <- homedir user
- return $ h </> ".ssh"
-
-dotFile :: FilePath -> UserName -> IO FilePath
-dotFile f user = do
- d <- dotDir user
- return $ d </> f
-
-hasAuthorizedKeys :: UserName -> IO Bool
-hasAuthorizedKeys = go <=< dotFile "authorized_keys"
- where
- go f = not . null <$> catchDefaultIO "" (readFile f)
-
-restartSshd :: Property
-restartSshd = cmdProperty "service" ["ssh", "restart"]
-
--- | Blows away existing host keys and make new ones.
--- Useful for systems installed from an image that might reuse host keys.
--- A flag file is used to only ever do this once.
-randomHostKeys :: Property
-randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
- `onChange` restartSshd
- where
- prop = property "ssh random host keys" $ do
- void $ liftIO $ boolSystem "sh"
- [ Param "-c"
- , Param "rm -f /etc/ssh/ssh_host_*"
- ]
- ensureProperty $
- cmdProperty "/var/lib/dpkg/info/openssh-server.postinst"
- ["configure"]
-
--- | Sets ssh host keys from the site's PrivData.
---
--- (Uses a null username for host keys.)
-hostKey :: SshKeyType -> Property
-hostKey keytype = combineProperties desc
- [ property desc (install writeFile (SshPubKey keytype "") ".pub")
- , property desc (install writeFileProtected (SshPrivKey keytype "") "")
- ]
- `onChange` restartSshd
- where
- desc = "known ssh host key (" ++ fromKeyType keytype ++ ")"
- install writer p ext = withPrivData p $ \key -> do
- let f = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext
- s <- liftIO $ readFileStrict f
- if s == key
- then noChange
- else makeChange $ writer f key
-
--- | Sets up a user with a ssh private key and public key pair
--- from the site's PrivData.
-keyImported :: SshKeyType -> UserName -> Property
-keyImported keytype user = combineProperties desc
- [ property desc (install writeFile (SshPubKey keytype user) ".pub")
- , property desc (install writeFileProtected (SshPrivKey keytype user) "")
- ]
- where
- desc = user ++ " has ssh key (" ++ fromKeyType keytype ++ ")"
- install writer p ext = do
- f <- liftIO $ keyfile ext
- ifM (liftIO $ doesFileExist f)
- ( noChange
- , ensureProperty $ combineProperties desc
- [ property desc $
- withPrivData p $ \key -> makeChange $
- writer f key
- , File.ownerGroup f user user
- ]
- )
- keyfile ext = do
- home <- homeDirectory <$> getUserEntryForName user
- return $ home </> ".ssh" </> "id_" ++ fromKeyType keytype ++ ext
-
-fromKeyType :: SshKeyType -> String
-fromKeyType SshRsa = "rsa"
-fromKeyType SshDsa = "dsa"
-fromKeyType SshEcdsa = "ecdsa"
-fromKeyType SshEd25519 = "ed25519"
-
--- | Puts some host's ssh public key into the known_hosts file for a user.
-knownHost :: [Host] -> HostName -> UserName -> Property
-knownHost hosts hn user = property desc $
- go =<< fromHost hosts hn getSshPubKey
- where
- desc = user ++ " knows ssh key for " ++ hn
- go (Just (Just k)) = do
- f <- liftIO $ dotFile "known_hosts" user
- ensureProperty $ combineProperties desc
- [ File.dirExists (takeDirectory f)
- , f `File.containsLine` (hn ++ " " ++ k)
- , File.ownerGroup f user user
- ]
- go _ = do
- warningMessage $ "no configred sshPubKey for " ++ hn
- return FailedChange
-
--- | Makes a user have authorized_keys from the PrivData
-authorizedKeys :: UserName -> Property
-authorizedKeys user = property (user ++ " has authorized_keys") $
- withPrivData (SshAuthorizedKeys user) $ \v -> do
- f <- liftIO $ dotFile "authorized_keys" user
- liftIO $ do
- createDirectoryIfMissing True (takeDirectory f)
- writeFileProtected f v
- ensureProperty $ File.ownerGroup f user user
diff --git a/Propellor/Property/Sudo.hs b/Propellor/Property/Sudo.hs
deleted file mode 100644
index 68b56608..00000000
--- a/Propellor/Property/Sudo.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-module Propellor.Property.Sudo where
-
-import Data.List
-
-import Propellor
-import Propellor.Property.File
-import qualified Propellor.Property.Apt as Apt
-import Propellor.Property.User
-
--- | Allows a user to sudo. If the user has a password, sudo is configured
--- to require it. If not, NOPASSWORD is enabled for the user.
-enabledFor :: UserName -> Property
-enabledFor user = property desc go `requires` Apt.installed ["sudo"]
- where
- go = do
- locked <- liftIO $ isLockedPassword user
- ensureProperty $
- fileProperty desc
- (modify locked . filter (wanted locked))
- "/etc/sudoers"
- desc = user ++ " is sudoer"
- sudobaseline = user ++ " ALL=(ALL:ALL)"
- sudoline True = sudobaseline ++ " NOPASSWD:ALL"
- sudoline False = sudobaseline ++ " ALL"
- wanted locked l
- -- TOOD: Full sudoers file format parse..
- | not (sudobaseline `isPrefixOf` l) = True
- | "NOPASSWD" `isInfixOf` l = locked
- | otherwise = True
- modify locked ls
- | sudoline locked `elem` ls = ls
- | otherwise = ls ++ [sudoline locked]
diff --git a/Propellor/Property/Tor.hs b/Propellor/Property/Tor.hs
deleted file mode 100644
index 78e35c89..00000000
--- a/Propellor/Property/Tor.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module Propellor.Property.Tor where
-
-import Propellor
-import qualified Propellor.Property.File as File
-import qualified Propellor.Property.Apt as Apt
-
-isBridge :: Property
-isBridge = setup `requires` Apt.installed ["tor"]
- `describe` "tor bridge"
- where
- setup = "/etc/tor/torrc" `File.hasContent`
- [ "SocksPort 0"
- , "ORPort 443"
- , "BridgeRelay 1"
- , "Exitpolicy reject *:*"
- ] `onChange` restartTor
-
-restartTor :: Property
-restartTor = cmdProperty "service" ["tor", "restart"]
diff --git a/Propellor/Property/User.hs b/Propellor/Property/User.hs
deleted file mode 100644
index eef2a57e..00000000
--- a/Propellor/Property/User.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-module Propellor.Property.User where
-
-import System.Posix
-
-import Propellor
-
-data Eep = YesReallyDeleteHome
-
-accountFor :: UserName -> Property
-accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser"
- [ "--disabled-password"
- , "--gecos", ""
- , user
- ]
- `describe` ("account for " ++ user)
-
--- | Removes user home directory!! Use with caution.
-nuked :: UserName -> Eep -> Property
-nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "userdel"
- [ "-r"
- , user
- ]
- `describe` ("nuked user " ++ user)
-
--- | Only ensures that the user has some password set. It may or may
--- not be the password from the PrivData.
-hasSomePassword :: UserName -> Property
-hasSomePassword user = check ((/= HasPassword) <$> getPasswordStatus user) $
- hasPassword user
-
-hasPassword :: UserName -> Property
-hasPassword user = property (user ++ " has password") $
- withPrivData (Password user) $ \password -> makeChange $
- withHandle StdinHandle createProcessSuccess
- (proc "chpasswd" []) $ \h -> do
- hPutStrLn h $ user ++ ":" ++ password
- hClose h
-
-lockedPassword :: UserName -> Property
-lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd"
- [ "--lock"
- , user
- ]
- `describe` ("locked " ++ user ++ " password")
-
-data PasswordStatus = NoPassword | LockedPassword | HasPassword
- deriving (Eq)
-
-getPasswordStatus :: UserName -> IO PasswordStatus
-getPasswordStatus user = parse . words <$> readProcess "passwd" ["-S", user]
- where
- parse (_:"L":_) = LockedPassword
- parse (_:"NP":_) = NoPassword
- parse (_:"P":_) = HasPassword
- parse _ = NoPassword
-
-isLockedPassword :: UserName -> IO Bool
-isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user
-
-homedir :: UserName -> IO FilePath
-homedir user = homeDirectory <$> getUserEntryForName user
diff --git a/Propellor/SimpleSh.hs b/Propellor/SimpleSh.hs
deleted file mode 100644
index 7ba30b0e..00000000
--- a/Propellor/SimpleSh.hs
+++ /dev/null
@@ -1,101 +0,0 @@
--- | Simple server, using a named pipe. Client connects, sends a command,
--- and gets back all the output from the command, in a stream.
---
--- This is useful for eg, docker.
-
-module Propellor.SimpleSh where
-
-import Network.Socket
-import Control.Concurrent
-import Control.Concurrent.Async
-import System.Process (std_in, std_out, std_err)
-
-import Propellor
-import Utility.FileMode
-import Utility.ThreadScheduler
-
-data Cmd = Cmd String [String]
- deriving (Read, Show)
-
-data Resp = StdoutLine String | StderrLine String | Done
- deriving (Read, Show)
-
-simpleSh :: FilePath -> IO ()
-simpleSh namedpipe = do
- nukeFile namedpipe
- let dir = takeDirectory namedpipe
- createDirectoryIfMissing True dir
- modifyFileMode dir (removeModes otherGroupModes)
- s <- socket AF_UNIX Stream defaultProtocol
- bindSocket s (SockAddrUnix namedpipe)
- listen s 2
- forever $ do
- (client, _addr) <- accept s
- forkIO $ do
- h <- socketToHandle client ReadWriteMode
- maybe noop (run h) . readish =<< hGetLine h
- where
- run h (Cmd cmd params) = do
- chan <- newChan
- let runwriter = do
- v <- readChan chan
- hPutStrLn h (show v)
- hFlush h
- case v of
- Done -> noop
- _ -> runwriter
- writer <- async runwriter
-
- flip catchIO (\_e -> writeChan chan Done) $ do
- let p = (proc cmd params)
- { std_in = Inherit
- , std_out = CreatePipe
- , std_err = CreatePipe
- }
- (Nothing, Just outh, Just errh, pid) <- createProcess p
-
- let mkreader t from = maybe noop (const $ mkreader t from)
- =<< catchMaybeIO (writeChan chan . t =<< hGetLine from)
- void $ concurrently
- (mkreader StdoutLine outh)
- (mkreader StderrLine errh)
-
- void $ tryIO $ waitForProcess pid
-
- writeChan chan Done
-
- hClose outh
- hClose errh
-
- wait writer
- hClose h
-
-simpleShClient :: FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a
-simpleShClient namedpipe cmd params handler = do
- s <- socket AF_UNIX Stream defaultProtocol
- connect s (SockAddrUnix namedpipe)
- h <- socketToHandle s ReadWriteMode
- hPutStrLn h $ show $ Cmd cmd params
- hFlush h
- resps <- catMaybes . map readish . lines <$> hGetContents h
- v <- hClose h `after` handler resps
- return v
-
-simpleShClientRetry :: Int -> FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a
-simpleShClientRetry retries namedpipe cmd params handler = go retries
- where
- run = simpleShClient namedpipe cmd params handler
- go n
- | n < 1 = run
- | otherwise = do
- v <- tryIO run
- case v of
- Right r -> return r
- Left e -> do
- debug ["simplesh connection retry", show e]
- threadDelaySeconds (Seconds 1)
- go (n - 1)
-
-getStdout :: Resp -> Maybe String
-getStdout (StdoutLine s) = Just s
-getStdout _ = Nothing
diff --git a/Propellor/Types.hs b/Propellor/Types.hs
deleted file mode 100644
index 22df9ddb..00000000
--- a/Propellor/Types.hs
+++ /dev/null
@@ -1,153 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ExistentialQuantification #-}
-
-module Propellor.Types
- ( Host(..)
- , Attr
- , SetAttr
- , Propellor(..)
- , Property(..)
- , RevertableProperty(..)
- , IsProp
- , describe
- , toProp
- , setAttr
- , requires
- , Desc
- , Result(..)
- , ActionResult(..)
- , CmdLine(..)
- , PrivDataField(..)
- , GpgKeyId
- , SshKeyType(..)
- , module Propellor.Types.OS
- , module Propellor.Types.Dns
- ) where
-
-import Data.Monoid
-import Control.Applicative
-import System.Console.ANSI
-import "mtl" Control.Monad.Reader
-import "MonadCatchIO-transformers" Control.Monad.CatchIO
-
-import Propellor.Types.Attr
-import Propellor.Types.OS
-import Propellor.Types.Dns
-
-data Host = Host [Property] SetAttr
-
--- | Propellor's monad provides read-only access to attributes of the
--- system.
-newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p }
- deriving
- ( Monad
- , Functor
- , Applicative
- , MonadReader Attr
- , MonadIO
- , MonadCatchIO
- )
-
--- | The core data type of Propellor, this represents a property
--- that the system should have, and an action to ensure it has the
--- property.
-data Property = Property
- { propertyDesc :: Desc
- , propertySatisfy :: Propellor Result
- -- ^ must be idempotent; may run repeatedly
- , propertyAttr :: SetAttr
- -- ^ a property can set an Attr on the host that has the property.
- }
-
--- | A property that can be reverted.
-data RevertableProperty = RevertableProperty Property Property
-
-class IsProp p where
- -- | Sets description.
- describe :: p -> Desc -> p
- toProp :: p -> Property
- -- | Indicates that the first property can only be satisfied
- -- once the second one is.
- requires :: p -> Property -> p
- setAttr :: p -> SetAttr
-
-instance IsProp Property where
- describe p d = p { propertyDesc = d }
- toProp p = p
- setAttr = propertyAttr
- x `requires` y = Property (propertyDesc x) satisfy attr
- where
- attr = propertyAttr x . propertyAttr y
- satisfy = do
- r <- propertySatisfy y
- case r of
- FailedChange -> return FailedChange
- _ -> propertySatisfy x
-
-
-instance IsProp RevertableProperty where
- -- | Sets the description of both sides.
- describe (RevertableProperty p1 p2) d =
- RevertableProperty (describe p1 d) (describe p2 ("not " ++ d))
- toProp (RevertableProperty p1 _) = p1
- (RevertableProperty p1 p2) `requires` y =
- RevertableProperty (p1 `requires` y) p2
- -- | Return the SetAttr of the currently active side.
- setAttr (RevertableProperty p1 _p2) = setAttr p1
-
-type Desc = String
-
-data Result = NoChange | MadeChange | FailedChange
- deriving (Read, Show, Eq)
-
-instance Monoid Result where
- mempty = NoChange
-
- mappend FailedChange _ = FailedChange
- mappend _ FailedChange = FailedChange
- mappend MadeChange _ = MadeChange
- mappend _ MadeChange = MadeChange
- mappend NoChange NoChange = NoChange
-
--- | Results of actions, with color.
-class ActionResult a where
- getActionResult :: a -> (String, ColorIntensity, Color)
-
-instance ActionResult Bool where
- getActionResult False = ("failed", Vivid, Red)
- getActionResult True = ("done", Dull, Green)
-
-instance ActionResult Result where
- getActionResult NoChange = ("ok", Dull, Green)
- getActionResult MadeChange = ("done", Vivid, Green)
- getActionResult FailedChange = ("failed", Vivid, Red)
-
-data CmdLine
- = Run HostName
- | Spin HostName
- | Boot HostName
- | Set HostName PrivDataField
- | AddKey String
- | Continue CmdLine
- | Chain HostName
- | Docker HostName
- deriving (Read, Show, Eq)
-
--- | Note that removing or changing field names will break the
--- serialized privdata files, so don't do that!
--- It's fine to add new fields.
-data PrivDataField
- = DockerAuthentication
- | SshPubKey SshKeyType UserName
- | SshPrivKey SshKeyType UserName
- | SshAuthorizedKeys UserName
- | Password UserName
- | PrivFile FilePath
- | GpgKey GpgKeyId
- deriving (Read, Show, Ord, Eq)
-
-type GpgKeyId = String
-
-data SshKeyType = SshRsa | SshDsa | SshEcdsa | SshEd25519
- deriving (Read, Show, Ord, Eq)
diff --git a/Propellor/Types/Attr.hs b/Propellor/Types/Attr.hs
deleted file mode 100644
index 8b7d3b09..00000000
--- a/Propellor/Types/Attr.hs
+++ /dev/null
@@ -1,48 +0,0 @@
-module Propellor.Types.Attr where
-
-import Propellor.Types.OS
-import qualified Propellor.Types.Dns as Dns
-
-import qualified Data.Set as S
-import qualified Data.Map as M
-
--- | The attributes of a host. For example, its hostname.
-data Attr = Attr
- { _hostname :: HostName
- , _os :: Maybe System
- , _sshPubKey :: Maybe String
- , _dns :: S.Set Dns.Record
- , _namedconf :: M.Map Dns.Domain Dns.NamedConf
-
- , _dockerImage :: Maybe String
- , _dockerRunParams :: [HostName -> String]
- }
-
-instance Eq Attr where
- x == y = and
- [ _hostname x == _hostname y
- , _os x == _os y
- , _dns x == _dns y
- , _namedconf x == _namedconf y
- , _sshPubKey x == _sshPubKey y
-
- , _dockerImage x == _dockerImage y
- , let simpl v = map (\a -> a "") (_dockerRunParams v)
- in simpl x == simpl y
- ]
-
-instance Show Attr where
- show a = unlines
- [ "hostname " ++ _hostname a
- , "OS " ++ show (_os a)
- , "sshPubKey " ++ show (_sshPubKey a)
- , "dns " ++ show (_dns a)
- , "namedconf " ++ show (_namedconf a)
- , "docker image " ++ show (_dockerImage a)
- , "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
- ]
-
-newAttr :: HostName -> Attr
-newAttr hn = Attr hn Nothing Nothing S.empty M.empty Nothing []
-
-type SetAttr = Attr -> Attr
diff --git a/Propellor/Types/Dns.hs b/Propellor/Types/Dns.hs
deleted file mode 100644
index ba6a92dd..00000000
--- a/Propellor/Types/Dns.hs
+++ /dev/null
@@ -1,92 +0,0 @@
-module Propellor.Types.Dns where
-
-import Propellor.Types.OS (HostName)
-
-import Data.Word
-
-type Domain = String
-
-data IPAddr = IPv4 String | IPv6 String
- deriving (Read, Show, Eq, Ord)
-
-fromIPAddr :: IPAddr -> String
-fromIPAddr (IPv4 addr) = addr
-fromIPAddr (IPv6 addr) = addr
-
--- | Represents a bind 9 named.conf file.
-data NamedConf = NamedConf
- { confDomain :: Domain
- , confDnsServerType :: DnsServerType
- , confFile :: FilePath
- , confMasters :: [IPAddr]
- , confAllowTransfer :: [IPAddr]
- , confLines :: [String]
- }
- deriving (Show, Eq, Ord)
-
-data DnsServerType = Master | Secondary
- deriving (Show, Eq, Ord)
-
--- | Represents a bind 9 zone file.
-data Zone = Zone
- { zDomain :: Domain
- , zSOA :: SOA
- , zHosts :: [(BindDomain, Record)]
- }
- deriving (Read, Show, Eq)
-
--- | Every domain has a SOA record, which is big and complicated.
-data SOA = SOA
- { sDomain :: BindDomain
- -- ^ Typically ns1.your.domain
- , sSerial :: SerialNumber
- -- ^ The most important parameter is the serial number,
- -- which must increase after each change.
- , sRefresh :: Integer
- , sRetry :: Integer
- , sExpire :: Integer
- , sNegativeCacheTTL :: Integer
- }
- deriving (Read, Show, Eq)
-
--- | Types of DNS records.
---
--- This is not a complete list, more can be added.
-data Record
- = Address IPAddr
- | CNAME BindDomain
- | MX Int BindDomain
- | NS BindDomain
- | TXT String
- | SRV Word16 Word16 Word16 BindDomain
- deriving (Read, Show, Eq, Ord)
-
-getIPAddr :: Record -> Maybe IPAddr
-getIPAddr (Address addr) = Just addr
-getIPAddr _ = Nothing
-
-getCNAME :: Record -> Maybe BindDomain
-getCNAME (CNAME d) = Just d
-getCNAME _ = Nothing
-
-getNS :: Record -> Maybe BindDomain
-getNS (NS d) = Just d
-getNS _ = Nothing
-
--- | Bind serial numbers are unsigned, 32 bit integers.
-type SerialNumber = Word32
-
--- | Domains in the zone file must end with a period if they are absolute.
---
--- Let's use a type to keep absolute domains straight from relative
--- domains.
---
--- The RootDomain refers to the top level of the domain, so can be used
--- to add nameservers, MX's, etc to a domain.
-data BindDomain = RelDomain Domain | AbsDomain Domain | RootDomain
- deriving (Read, Show, Eq, Ord)
-
-domainHostName :: BindDomain -> Maybe HostName
-domainHostName (RelDomain d) = Just d
-domainHostName (AbsDomain d) = Just d
-domainHostName RootDomain = Nothing
diff --git a/Propellor/Types/OS.hs b/Propellor/Types/OS.hs
deleted file mode 100644
index 23cc8a29..00000000
--- a/Propellor/Types/OS.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-module Propellor.Types.OS where
-
-type HostName = String
-type UserName = String
-type GroupName = String
-
--- | High level descritption of a operating system.
-data System = System Distribution Architecture
- deriving (Show, Eq)
-
-data Distribution
- = Debian DebianSuite
- | Ubuntu Release
- deriving (Show, Eq)
-
-data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release
- deriving (Show, Eq)
-
--- | The release that currently corresponds to stable.
-stableRelease :: DebianSuite
-stableRelease = DebianRelease "wheezy"
-
-isStable :: DebianSuite -> Bool
-isStable s = s == Stable || s == stableRelease
-
-type Release = String
-type Architecture = String