summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2014-04-11 01:09:01 -0400
committerJoey Hess2014-04-11 01:09:01 -0400
commit856ce97995bc34e35fd8e0233341f26a37b19cf5 (patch)
tree1d93492b36cd07d58437d2cb0f902ad53b3abe6e
parent07a071ac7f5b2f71e376a9a1a78a84a6bf02129b (diff)
parent47ff089f844c707eaa3ffd7255dc733721fb6adf (diff)
Merge branch 'joeyconfig'
-rw-r--r--Makefile3
-rw-r--r--Propellor.hs29
-rw-r--r--Propellor/Attr.hs47
-rw-r--r--Propellor/CmdLine.hs82
-rw-r--r--Propellor/Engine.hs23
-rw-r--r--Propellor/Exception.hs16
-rw-r--r--Propellor/Message.hs25
-rw-r--r--Propellor/PrivData.hs15
-rw-r--r--Propellor/Property.hs63
-rw-r--r--Propellor/Property/Apt.hs30
-rw-r--r--Propellor/Property/Cmd.hs19
-rw-r--r--Propellor/Property/Cron.hs3
-rw-r--r--Propellor/Property/Dns.hs63
-rw-r--r--Propellor/Property/Docker.hs228
-rw-r--r--Propellor/Property/File.hs21
-rw-r--r--Propellor/Property/Git.hs48
-rw-r--r--Propellor/Property/Hostname.hs23
-rw-r--r--Propellor/Property/Network.hs1
-rw-r--r--Propellor/Property/OpenId.hs26
-rw-r--r--Propellor/Property/Scheduled.hs67
-rw-r--r--Propellor/Property/Service.hs31
-rw-r--r--Propellor/Property/SiteSpecific/GitAnnexBuilder.hs7
-rw-r--r--Propellor/Property/SiteSpecific/GitHome.hs6
-rw-r--r--Propellor/Property/SiteSpecific/JoeySites.hs4
-rw-r--r--Propellor/Property/Ssh.hs2
-rw-r--r--Propellor/Property/Sudo.hs2
-rw-r--r--Propellor/SimpleSh.hs2
-rw-r--r--Propellor/Types.hs75
-rw-r--r--Propellor/Types/Attr.hs36
-rw-r--r--TODO18
-rw-r--r--Utility/QuickCheck.hs52
-rw-r--r--Utility/Scheduled.hs358
-rw-r--r--config-joey.hs255
-rw-r--r--config-simple.hs60
-rw-r--r--debian/changelog15
-rw-r--r--debian/control4
-rw-r--r--privdata/clam.kitenet.net.gpg39
-rw-r--r--privdata/diatom.kitenet.net.gpg19
-rw-r--r--propellor.cabal21
39 files changed, 1422 insertions, 416 deletions
diff --git a/Makefile b/Makefile
index 9b4a7d82..e53de8c5 100644
--- a/Makefile
+++ b/Makefile
@@ -10,7 +10,8 @@ build: dist/setup-config
ln -sf dist/build/config/config propellor
deps:
- @if [ $$(whoami) = root ]; then apt-get -y install gnupg ghc cabal-install libghc-missingh-dev libghc-ansi-terminal-dev libghc-ifelse-dev libghc-unix-compat-dev libghc-hslogger-dev libghc-network-dev libghc-async-dev; fi || true
+ @if [ $$(whoami) = root ]; then apt-get --no-upgrade --no-install-recommends -y install gnupg ghc cabal-install libghc-missingh-dev libghc-ansi-terminal-dev libghc-ifelse-dev libghc-unix-compat-dev libghc-hslogger-dev libghc-network-dev libghc-quickcheck2-dev libghc-mtl-dev libghc-monadcatchio-transformers-dev; fi || true
+ @if [ $$(whoami) = root ]; then apt-get --no-upgrade --no-install-recommends -y install libghc-async-dev || cabal update; cabal install async; fi || true
dist/setup-config: propellor.cabal
if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi
diff --git a/Propellor.hs b/Propellor.hs
index e39fc97d..e6312248 100644
--- a/Propellor.hs
+++ b/Propellor.hs
@@ -1,7 +1,10 @@
+{-# LANGUAGE PackageImports #-}
+
-- | Pulls in lots of useful modules for building and using Properties.
--
--- Propellor enures that the system it's run in satisfies a list of
--- properties, taking action as necessary when a property is not yet met.
+-- When propellor runs on a Host, it ensures that its list of Properties
+-- is satisfied, taking action as necessary when a Property is not
+-- currently satisfied.
--
-- A simple propellor program example:
--
@@ -11,15 +14,16 @@
-- > import qualified Propellor.Property.Apt as Apt
-- >
-- > main :: IO ()
--- > main = defaultMain getProperties
+-- > main = defaultMain hosts
-- >
--- > getProperties :: HostName -> Maybe [Property]
--- > getProperties "example.com" = Just
--- > [ Apt.installed ["mydaemon"]
--- > , "/etc/mydaemon.conf" `File.containsLine` "secure=1"
--- > `onChange` cmdProperty "service" ["mydaemon", "restart"]
--- > ]
--- > getProperties _ = Nothing
+-- > hosts :: [Host]
+-- > hosts =
+-- > [ host "example.com"
+-- > & Apt.installed ["mydaemon"]
+-- > & "/etc/mydaemon.conf" `File.containsLine` "secure=1"
+-- > `onChange` cmdProperty "service" ["mydaemon", "restart"]
+-- > ! Apt.installed ["unwantedpackage"]
+-- > ]
--
-- See config.hs for a more complete example, and clone Propellor's
-- git repository for a deployable system using Propellor:
@@ -29,8 +33,10 @@ module Propellor (
module Propellor.Types
, module Propellor.Property
, module Propellor.Property.Cmd
+ , module Propellor.Attr
, module Propellor.PrivData
, module Propellor.Engine
+ , module Propellor.Exception
, module Propellor.Message
, localdir
@@ -43,6 +49,8 @@ import Propellor.Engine
import Propellor.Property.Cmd
import Propellor.PrivData
import Propellor.Message
+import Propellor.Exception
+import Propellor.Attr
import Utility.PartialPrelude as X
import Utility.Process as X
@@ -62,6 +70,7 @@ import Control.Applicative as X
import Control.Monad as X
import Data.Monoid as X
import Control.Monad.IfElse as X
+import "mtl" Control.Monad.Reader as X
-- | This is where propellor installs itself when deploying a host.
localdir :: FilePath
diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs
new file mode 100644
index 00000000..4bc1c2c7
--- /dev/null
+++ b/Propellor/Attr.hs
@@ -0,0 +1,47 @@
+{-# 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
+
+pureAttrProperty :: Desc -> (Attr -> Attr) -> AttrProperty
+pureAttrProperty desc = AttrProperty $ Property ("has " ++ desc)
+ (return NoChange)
+
+hostname :: HostName -> AttrProperty
+hostname name = pureAttrProperty ("hostname " ++ name) $
+ \d -> d { _hostname = name }
+
+getHostName :: Propellor HostName
+getHostName = asks _hostname
+
+cname :: Domain -> AttrProperty
+cname domain = pureAttrProperty ("cname " ++ domain) (addCName domain)
+
+cnameFor :: IsProp p => Domain -> (Domain -> p) -> AttrProperty
+cnameFor domain mkp =
+ let p = mkp domain
+ in AttrProperty p (addCName domain)
+
+addCName :: HostName -> Attr -> Attr
+addCName domain d = d { _cnames = S.insert domain (_cnames d) }
+
+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
+
+findHost :: [Host] -> HostName -> Maybe Host
+findHost l hn = M.lookup hn (hostMap l)
diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs
index 5ea982c3..5be91c4f 100644
--- a/Propellor/CmdLine.hs
+++ b/Propellor/CmdLine.hs
@@ -16,6 +16,7 @@ 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
@@ -54,8 +55,8 @@ processCmdLine = go =<< getArgs
else return $ Run s
go _ = usage
-defaultMain :: [HostName -> Maybe [Property]] -> IO ()
-defaultMain getprops = do
+defaultMain :: [Host] -> IO ()
+defaultMain hostlist = do
DockerShim.cleanEnv
checkDebugMode
cmdline <- processCmdLine
@@ -63,23 +64,26 @@ defaultMain getprops = do
go True cmdline
where
go _ (Continue cmdline) = go False cmdline
- go _ (Set host field) = setPrivData host field
+ go _ (Set hn field) = setPrivData hn field
go _ (AddKey keyid) = addKey keyid
- go _ (Chain host) = withprops host $ \ps -> do
- r <- ensureProperties' ps
+ go _ (Chain hn) = withprops hn $ \attr ps -> do
+ r <- runPropellor attr $ ensureProperties ps
putStrLn $ "\n" ++ show r
- go _ (Docker host) = Docker.chain host
+ 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 host) = withprops host $ const $ spin host
- go False (Run host) = ifM ((==) 0 <$> getRealUserID)
- ( onlyProcess $ withprops host ensureProperties
- , go True (Spin host)
+ 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 host) = onlyProcess $ withprops host $ boot
+ go False (Boot hn) = onlyProcess $ withprops hn boot
- withprops host a = maybe (unknownhost host) a $
- headMaybe $ catMaybes $ map (\get -> get host) getprops
+ 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)
@@ -95,7 +99,7 @@ onlyProcess a = bracket lock unlock (const a)
unknownhost :: HostName -> IO a
unknownhost h = errorMessage $ unlines
- [ "Unknown host: " ++ h
+ [ "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)"
]
@@ -163,15 +167,16 @@ getCurrentGitSha1 :: String -> IO String
getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]
spin :: HostName -> IO ()
-spin host = do
+spin hn = do
url <- getUrl
void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
void $ boolSystem "git" [Param "push"]
- go url =<< gpgDecrypt (privDataFile host)
+ cacheparams <- toCommand <$> sshCachingParams hn
+ go cacheparams url =<< gpgDecrypt (privDataFile hn)
where
- go url privdata = withBothHandles createProcessSuccess (proc "ssh" [user, bootstrapcmd]) $ \(toh, fromh) -> do
+ go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do
let finish = do
- senddata toh (privDataFile host) privDataMarker privdata
+ senddata toh (privDataFile hn) privDataMarker privdata
hClose toh
-- Display remaining output.
@@ -184,21 +189,21 @@ spin host = do
NeedGitClone -> do
hClose toh
hClose fromh
- sendGitClone host url
- go url privdata
+ sendGitClone hn url
+ go cacheparams url privdata
- user = "root@"++host
+ user = "root@"++hn
bootstrapcmd = shellWrap $ intercalate " ; "
[ "if [ ! -d " ++ localdir ++ " ]"
, "then " ++ intercalate " && "
- [ "apt-get -y install git"
+ [ "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 build; fi"
- , "./propellor --boot " ++ host
+ , "if ! test -x ./propellor; then make deps build; fi"
+ , "./propellor --boot " ++ hn
]
, "fi"
]
@@ -214,19 +219,18 @@ spin host = do
showremote s = putStrLn s
senddata toh f marker s = void $
- actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ host) $ do
+ actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do
sendMarked toh marker s
return True
sendGitClone :: HostName -> String -> IO ()
-sendGitClone host url = void $ actionMessage ("Pushing git repository to " ++ host) $ do
+sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
branch <- getCurrentBranch
+ cacheparams <- sshCachingParams hn
withTmpFile "propellor.git" $ \tmp _ -> allM id
- -- TODO: ssh connection caching, or better push method
- -- with less connections.
[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
- , boolSystem "scp" [File tmp, Param ("root@"++host++":"++remotebundle)]
- , boolSystem "ssh" [Param ("root@"++host), Param $ unpackcmd branch]
+ , boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
+ , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
]
where
remotebundle = "/usr/local/propellor.git"
@@ -274,15 +278,15 @@ fromMarked marker s
len = length marker
matches = filter (marker `isPrefixOf`) $ lines s
-boot :: [Property] -> IO ()
-boot ps = do
+boot :: Attr -> [Property] -> IO ()
+boot attr ps = do
sendMarked stdout statusMarker $ show Ready
reply <- hGetContentsStrict stdin
makePrivDataDir
maybe noop (writeFileProtected privDataLocal) $
fromMarked privDataMarker reply
- ensureProperties ps
+ mainProperties attr ps
addKey :: String -> IO ()
addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]
@@ -341,3 +345,15 @@ checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
updateGlobalLogger rootLoggerName $
setLevel DEBUG . setHandlers [f]
go _ = noop
+
+-- Parameters can be passed to both ssh and scp.
+sshCachingParams :: HostName -> IO [CommandParam]
+sshCachingParams hn = do
+ home <- myHomeDir
+ let cachedir = home </> ".ssh" </> "propellor"
+ createDirectoryIfMissing False cachedir
+ let socketfile = cachedir </> hn ++ ".sock"
+ return
+ [ Param "-o", Param ("ControlPath=" ++ socketfile)
+ , Params "-o ControlMaster=auto -o ControlPersist=yes"
+ ]
diff --git a/Propellor/Engine.hs b/Propellor/Engine.hs
index 1ae224ca..81d979ac 100644
--- a/Propellor/Engine.hs
+++ b/Propellor/Engine.hs
@@ -1,30 +1,37 @@
+{-# 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 Utility.Exception
+import Propellor.Exception
-ensureProperty :: Property -> IO Result
-ensureProperty = catchDefaultIO FailedChange . propertySatisfy
+runPropellor :: Attr -> Propellor a -> IO a
+runPropellor attr a = runReaderT (runWithAttr a) attr
-ensureProperties :: [Property] -> IO ()
-ensureProperties ps = do
- r <- ensureProperties' [Property "overall" $ ensureProperties' ps]
+mainProperties :: Attr -> [Property] -> IO ()
+mainProperties attr ps = do
+ r <- runPropellor attr $
+ ensureProperties [Property "overall" $ ensureProperties ps]
setTitle "propellor: done"
hFlush stdout
case r of
FailedChange -> exitWith (ExitFailure 1)
_ -> exitWith ExitSuccess
-ensureProperties' :: [Property] -> IO Result
-ensureProperties' ps = ensure ps NoChange
+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
new file mode 100644
index 00000000..bd9212a8
--- /dev/null
+++ b/Propellor/Exception.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE PackageImports #-}
+
+module Propellor.Exception where
+
+import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M
+import Control.Exception
+import Control.Applicative
+
+import Propellor.Types
+
+-- | Catches IO exceptions and returns FailedChange.
+catchPropellor :: Propellor Result -> Propellor Result
+catchPropellor a = either (\_ -> FailedChange) id <$> tryPropellor a
+
+tryPropellor :: Propellor a -> Propellor (Either IOException a)
+tryPropellor = M.try
diff --git a/Propellor/Message.hs b/Propellor/Message.hs
index 5a7d8c4b..2e63061e 100644
--- a/Propellor/Message.hs
+++ b/Propellor/Message.hs
@@ -1,30 +1,35 @@
+{-# 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 :: ActionResult r => Desc -> IO r -> IO r
+actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r
actionMessage desc a = do
- setTitle $ "propellor: " ++ desc
- hFlush stdout
+ liftIO $ do
+ setTitle $ "propellor: " ++ desc
+ hFlush stdout
r <- a
- setTitle "propellor: running"
- let (msg, intensity, color) = getActionResult r
- putStr $ desc ++ " ... "
- colorLine intensity color msg
- hFlush stdout
+ liftIO $ do
+ setTitle "propellor: running"
+ let (msg, intensity, color) = getActionResult r
+ putStr $ desc ++ " ... "
+ colorLine intensity color msg
+ hFlush stdout
return r
-warningMessage :: String -> IO ()
-warningMessage s = colorLine Vivid Red $ "** warning: " ++ s
+warningMessage :: MonadIO m => String -> m ()
+warningMessage s = liftIO $ colorLine Vivid Red $ "** warning: " ++ s
colorLine :: ColorIntensity -> Color -> String -> IO ()
colorLine intensity color msg = do
diff --git a/Propellor/PrivData.hs b/Propellor/PrivData.hs
index e768ae9e..5adc9e94 100644
--- a/Propellor/PrivData.hs
+++ b/Propellor/PrivData.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE PackageImports #-}
+
module Propellor.PrivData where
import qualified Data.Map as M
@@ -7,8 +9,10 @@ import System.IO
import System.Directory
import Data.Maybe
import Control.Monad
+import "mtl" Control.Monad.Reader
import Propellor.Types
+import Propellor.Attr
import Propellor.Message
import Utility.Monad
import Utility.PartialPrelude
@@ -18,12 +22,15 @@ import Utility.Tmp
import Utility.SafeCommand
import Utility.Misc
-withPrivData :: PrivDataField -> (String -> IO Result) -> IO Result
-withPrivData field a = maybe missing a =<< getPrivData field
+withPrivData :: PrivDataField -> (String -> Propellor Result) -> Propellor Result
+withPrivData field a = maybe missing a =<< liftIO (getPrivData field)
where
missing = do
- warningMessage $ "Missing privdata " ++ show field
- return FailedChange
+ host <- getHostName
+ 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
diff --git a/Propellor/Property.hs b/Propellor/Property.hs
index e7ec704d..3a3c1cb1 100644
--- a/Propellor/Property.hs
+++ b/Propellor/Property.hs
@@ -1,17 +1,22 @@
+{-# LANGUAGE PackageImports #-}
+
module Propellor.Property where
import System.Directory
import Control.Monad
import Data.Monoid
+import Control.Monad.IfElse
+import "mtl" Control.Monad.Reader
import Propellor.Types
+import Propellor.Types.Attr
import Propellor.Engine
import Utility.Monad
-makeChange :: IO () -> IO Result
-makeChange a = a >> return MadeChange
+makeChange :: IO () -> Propellor Result
+makeChange a = liftIO a >> return MadeChange
-noChange :: IO Result
+noChange :: Propellor Result
noChange = return NoChange
-- | Combines a list of properties, resulting in a single property
@@ -19,7 +24,7 @@ noChange = return NoChange
-- 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
+propertyList desc ps = Property desc $ ensureProperties ps
-- | Combines a list of properties, resulting in one property that
-- ensures each in turn, stopping on failure.
@@ -33,18 +38,29 @@ combineProperties desc ps = Property desc $ go ps NoChange
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 = Property (propertyDesc p1) $ do
+ r <- ensureProperty p1
+ case r of
+ FailedChange -> return FailedChange
+ _ -> ensureProperty p2
+
-- | 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 property flagfile = Property (propertyDesc property) $
- go =<< doesFileExist flagfile
+ go =<< liftIO (doesFileExist flagfile)
where
go True = return NoChange
go False = do
r <- ensureProperty property
- when (r == MadeChange) $
- writeFile flagfile ""
+ when (r == MadeChange) $ liftIO $
+ unlessM (doesFileExist flagfile) $
+ writeFile flagfile ""
return r
--- | Whenever a change has to be made for a Property, causes a hook
@@ -64,13 +80,13 @@ infixl 1 ==>
-- | Makes a Property only be performed when a test succeeds.
check :: IO Bool -> Property -> Property
-check c property = Property (propertyDesc property) $ ifM c
+check c property = Property (propertyDesc property) $ ifM (liftIO c)
( ensureProperty property
, return NoChange
)
boolProperty :: Desc -> IO Bool -> Property
-boolProperty desc a = Property desc $ ifM a
+boolProperty desc a = Property desc $ ifM (liftIO a)
( return MadeChange
, return FailedChange
)
@@ -79,17 +95,26 @@ boolProperty desc a = Property desc $ ifM a
revert :: RevertableProperty -> RevertableProperty
revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
--- | Starts a list of Properties
-props :: [Property]
-props = []
+-- | 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, RevertableProperties, and AttrProperties
+(&) :: IsProp p => Host -> p -> Host
+(Host ps as) & p = Host (ps ++ [toProp p]) (getAttr p . as)
--- | Adds a property to the list.
--- Can add both Properties and RevertableProperties.
-(&) :: IsProp p => [Property] -> p -> [Property]
-ps & p = ps ++ [toProp p]
infixl 1 &
--- | Adds a property to the list in reverted form.
-(!) :: [Property] -> RevertableProperty -> [Property]
-ps ! p = ps ++ [toProp $ revert p]
+-- | Adds a property to the Host in reverted form.
+(!) :: Host -> RevertableProperty -> Host
+(Host ps as) ! p = Host (ps ++ [toProp q]) (getAttr q . as)
+ where
+ q = revert p
+
infixl 1 !
diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs
index 8bbb1b19..4da13a2f 100644
--- a/Propellor/Property/Apt.hs
+++ b/Propellor/Property/Apt.hs
@@ -8,6 +8,7 @@ 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
@@ -46,13 +47,22 @@ debCdn = binandsrc "http://cdn.debian.net/debian"
kernelOrg :: DebianSuite -> [Line]
kernelOrg = binandsrc "http://mirrors.kernel.org/debian"
+-- | Only available for Stable and Testing
+securityUpdates :: DebianSuite -> [Line]
+securityUpdates suite
+ | suite == Stable || 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 = setSourcesList (debCdn suite ++ kernelOrg suite)
+stdSourcesList suite = setSourcesList
+ (debCdn suite ++ kernelOrg suite ++ securityUpdates suite)
`describe` ("standard sources.list for " ++ show suite)
setSourcesList :: [Line] -> Property
@@ -147,9 +157,12 @@ autoRemove = runApt ["-y", "autoremove"]
-- | Enables unattended upgrades. Revert to disable.
unattendedUpgrades :: RevertableProperty
-unattendedUpgrades = RevertableProperty (go True) (go False)
+unattendedUpgrades = RevertableProperty enable disable
where
- go enabled = (if enabled then installed else removed) ["unattended-upgrades"]
+ enable = setup True `before` Service.running "cron"
+ 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)
@@ -167,7 +180,14 @@ reConfigure package vals = reconfigure `requires` setselections
setselections = Property "preseed" $ makeChange $
withHandle StdinHandle createProcessSuccess
(proc "debconf-set-selections" []) $ \h -> do
- forM_ vals $ \(template, tmpltype, value) ->
- hPutStrLn h $ unwords [package, template, tmpltype, value]
+ forM_ vals $ \(tmpl, tmpltype, value) ->
+ hPutStrLn h $ unwords [package, tmpl, tmpltype, value]
hClose h
reconfigure = cmdProperty "dpkg-reconfigure" ["-fnone", package]
+
+-- | 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]
diff --git a/Propellor/Property/Cmd.hs b/Propellor/Property/Cmd.hs
index dc5073d3..875c1f9a 100644
--- a/Propellor/Property/Cmd.hs
+++ b/Propellor/Property/Cmd.hs
@@ -1,17 +1,17 @@
+{-# LANGUAGE PackageImports #-}
+
module Propellor.Property.Cmd (
cmdProperty,
cmdProperty',
scriptProperty,
userScriptProperty,
- serviceRunning,
) where
-import Control.Monad
import Control.Applicative
import Data.List
+import "mtl" Control.Monad.Reader
import Propellor.Types
-import Propellor.Engine
import Utility.Monad
import Utility.SafeCommand
import Utility.Env
@@ -25,7 +25,7 @@ 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 $ do
+cmdProperty' cmd params env = Property desc $ liftIO $ do
env' <- addEntries env <$> getEnvironment
ifM (boolSystemEnv cmd (map Param params) (Just env'))
( return MadeChange
@@ -46,14 +46,3 @@ userScriptProperty :: UserName -> [String] -> Property
userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user]
where
shellcmd = intercalate " ; " ("set -e" : "cd" : script)
-
--- | Ensures that a service is running.
---
--- 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.
-serviceRunning :: String -> Property
-serviceRunning svc = Property ("running " ++ svc) $ do
- void $ ensureProperty $
- scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"]
- return NoChange
diff --git a/Propellor/Property/Cron.hs b/Propellor/Property/Cron.hs
index 30bdb510..fa6019ea 100644
--- a/Propellor/Property/Cron.hs
+++ b/Propellor/Property/Cron.hs
@@ -18,8 +18,7 @@ job desc times user cddir command = ("/etc/cron.d/" ++ desc) `File.hasContent`
, ""
, times ++ "\t" ++ user ++ "\t" ++ "cd " ++ cddir ++ " && " ++ command
]
- `requires` Apt.installed ["cron"]
- `requires` serviceRunning "cron"
+ `requires` Apt.serviceInstalledRunning "cron"
`describe` ("cronned " ++ desc)
-- | Installs a cron job, and runs it niced and ioniced.
diff --git a/Propellor/Property/Dns.hs b/Propellor/Property/Dns.hs
new file mode 100644
index 00000000..34e790d9
--- /dev/null
+++ b/Propellor/Property/Dns.hs
@@ -0,0 +1,63 @@
+module Propellor.Property.Dns where
+
+import Propellor
+import Propellor.Property.File
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Service as Service
+
+namedconf :: FilePath
+namedconf = "/etc/bind/named.conf.local"
+
+data Zone = Zone
+ { zdomain :: Domain
+ , ztype :: Type
+ , zfile :: FilePath
+ , zmasters :: [IPAddr]
+ , zconfiglines :: [String]
+ }
+
+zoneDesc :: Zone -> String
+zoneDesc z = zdomain z ++ " (" ++ show (ztype z) ++ ")"
+
+type IPAddr = String
+
+type Domain = String
+
+data Type = Master | Secondary
+ deriving (Show, Eq)
+
+secondary :: Domain -> [IPAddr] -> Zone
+secondary domain masters = Zone
+ { zdomain = domain
+ , ztype = Secondary
+ , zfile = "db." ++ domain
+ , zmasters = masters
+ , zconfiglines = ["allow-transfer { }"]
+ }
+
+zoneStanza :: Zone -> [Line]
+zoneStanza z =
+ [ "// automatically generated by propellor"
+ , "zone \"" ++ zdomain z ++ "\" {"
+ , cfgline "type" (if ztype z == Master then "master" else "slave")
+ , cfgline "file" ("\"" ++ zfile z ++ "\"")
+ ] ++
+ (if null (zmasters z) then [] else mastersblock) ++
+ (map (\l -> "\t" ++ l ++ ";") (zconfiglines z)) ++
+ [ "};"
+ , ""
+ ]
+ where
+ cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"
+ mastersblock =
+ [ "\tmasters {" ] ++
+ (map (\ip -> "\t\t" ++ ip ++ ";") (zmasters z)) ++
+ [ "\t};" ]
+
+-- | Rewrites the whole named.conf.local file to serve the specificed
+-- zones.
+zones :: [Zone] -> Property
+zones zs = hasContent namedconf (concatMap zoneStanza zs)
+ `describe` ("dns server for zones: " ++ unwords (map zoneDesc zs))
+ `requires` Apt.serviceInstalledRunning "bind9"
+ `onChange` Service.reloaded "bind9"
diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs
index b573e641..d2555ea5 100644
--- a/Propellor/Property/Docker.hs
+++ b/Propellor/Property/Docker.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes, BangPatterns #-}
+{-# LANGUAGE BangPatterns #-}
-- | Docker support for propellor
--
@@ -9,6 +9,7 @@ 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
@@ -32,6 +33,25 @@ configured = Property "docker configured" go `requires` installed
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.
@@ -39,44 +59,61 @@ installed = Apt.installed ["docker.io"]
-- Reverting this property ensures that the container is stopped and
-- removed.
docked
- :: (HostName -> ContainerName -> Maybe (Container))
- -> HostName
+ :: [Host]
-> ContainerName
-> RevertableProperty
-docked findc hn cn = findContainer findc hn cn $
- \(Container image containerprops) ->
- let setup = provisionContainer cid
- `requires`
- runningContainer cid image containerprops
- `requires`
- installed
- teardown = combineProperties ("undocked " ++ fromContainerId cid)
- [ stoppedContainer cid
+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) $
- report <$> mapM id
+ liftIO $ report <$> mapM id
[ removeContainer cid
, removeImage image
]
]
- in RevertableProperty setup teardown
- where
- cid = ContainerId hn cn
findContainer
- :: (HostName -> ContainerName -> Maybe (Container))
- -> HostName
+ :: [Host]
+ -> ContainerId
-> ContainerName
- -> (Container -> RevertableProperty)
- -> RevertableProperty
-findContainer findc hn cn mk = case findc hn cn of
- Nothing -> RevertableProperty cantfind cantfind
- Just container -> mk container
+ -> (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
- cid = ContainerId hn cn
- cantfind = containerDesc (ContainerId hn cn) $ Property "" $ do
- warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid
+ 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
@@ -90,34 +127,11 @@ garbageCollected = propertyList "docker garbage collected"
]
where
gccontainers = Property "docker containers garbage collected" $
- report <$> (mapM removeContainer =<< listContainers AllContainers)
+ liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
gcimages = Property "docker images garbage collected" $ do
- report <$> (mapM removeImage =<< listImages)
-
--- | Pass to defaultMain to add docker containers.
--- You need to provide the function mapping from
--- HostName and ContainerName to the Container to use.
-containerProperties
- :: (HostName -> ContainerName -> Maybe (Container))
- -> (HostName -> Maybe [Property])
-containerProperties findcontainer = \h -> case toContainerId h of
- Nothing -> Nothing
- Just cid@(ContainerId hn cn) ->
- case findcontainer hn cn of
- Nothing -> Nothing
- Just (Container _ cprops) ->
- Just $ map (containerDesc cid) $
- fromContainerized cprops
-
--- | This type is used to configure a docker container.
--- It has an image, and a list of Properties, but these
--- properties are Containerized; they can specify
--- things about the container's configuration, in
--- addition to properties of the system inside the
--- container.
-data Container = Container Image [Containerized Property]
+ liftIO $ report <$> (mapM removeImage =<< listImages)
-data Containerized a = Containerized [HostName -> RunParam] a
+data Container = Container Image [RunParam]
-- | Parameters to pass to `docker run` when creating a container.
type RunParam = String
@@ -125,62 +139,50 @@ type RunParam = String
-- | A docker image, that can be used to run a container.
type Image = String
--- | 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
-
--- | Lift a Property to apply inside a container.
-inside1 :: Property -> Containerized Property
-inside1 = Containerized []
-
-inside :: [Property] -> Containerized Property
-inside = Containerized [] . combineProperties "provision"
-
-- | Set custom dns server for container.
-dns :: String -> Containerized Property
+dns :: String -> AttrProperty
dns = runProp "dns"
-- | Set container host name.
-hostname :: String -> Containerized Property
+hostname :: String -> AttrProperty
hostname = runProp "hostname"
-- | Set name for container. (Normally done automatically.)
-name :: String -> Containerized Property
+name :: String -> AttrProperty
name = runProp "name"
-- | Publish a container's port to the host
-- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)
-publish :: String -> Containerized Property
+publish :: String -> AttrProperty
publish = runProp "publish"
-- | Username or UID for container.
-user :: String -> Containerized Property
+user :: String -> AttrProperty
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 -> Containerized Property
+volume :: String -> AttrProperty
volume = runProp "volume"
-- | Mount a volume from the specified container into the current
-- container.
-volumes_from :: ContainerName -> Containerized Property
+volumes_from :: ContainerName -> AttrProperty
volumes_from cn = genProp "volumes-from" $ \hn ->
fromContainerId (ContainerId hn cn)
-- | Work dir inside the container.
-workdir :: String -> Containerized Property
+workdir :: String -> AttrProperty
workdir = runProp "workdir"
-- | Memory limit for container.
--Format: <number><optional unit>, where unit = b, k, m or g
-memory :: String -> Containerized Property
+memory :: String -> AttrProperty
memory = runProp "memory"
-- | Link with another container on the same host.
-link :: ContainerName -> ContainerAlias -> Containerized Property
+link :: ContainerName -> ContainerAlias -> AttrProperty
link linkwith alias = genProp "link" $ \hn ->
fromContainerId (ContainerId hn linkwith) ++ ":" ++ alias
@@ -199,16 +201,6 @@ data ContainerId = ContainerId HostName ContainerName
data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam]
deriving (Read, Show, Eq)
-getRunParams :: HostName -> [Containerized a] -> [RunParam]
-getRunParams hn l = concatMap get l
- where
- get (Containerized ps _) = map (\a -> a hn ) ps
-
-fromContainerized :: forall a. [Containerized a] -> [a]
-fromContainerized l = map get l
- where
- get (Containerized _ a) = a
-
ident2id :: ContainerIdent -> ContainerId
ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn
@@ -226,32 +218,32 @@ toContainerId s
fromContainerId :: ContainerId -> String
fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix
+containerHostName :: ContainerId -> HostName
+containerHostName (ContainerId _ cn) = cn2hn cn
+
myContainerSuffix :: String
myContainerSuffix = ".propellor"
-containerFrom :: Image -> [Containerized Property] -> Container
-containerFrom = Container
-
containerDesc :: ContainerId -> Property -> Property
containerDesc cid p = p `describe` desc
where
desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p
-runningContainer :: ContainerId -> Image -> [Containerized Property] -> Property
-runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc cid $ Property "running" $ do
- l <- listContainers RunningContainers
+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 <- getrunningident
+ runningident <- liftIO $ getrunningident
if runningident == Just ident
- then return NoChange
+ then noChange
else do
- void $ stopContainer cid
+ void $ liftIO $ stopContainer cid
restartcontainer
- else ifM (elem cid <$> listContainers AllContainers)
+ else ifM (liftIO $ elem cid <$> listContainers AllContainers)
( restartcontainer
, go image
)
@@ -259,8 +251,8 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci
ident = ContainerIdent image hn cn runps
restartcontainer = do
- oldimage <- fromMaybe image <$> commitContainer cid
- void $ removeContainer cid
+ oldimage <- liftIO $ fromMaybe image <$> commitContainer cid
+ void $ liftIO $ removeContainer cid
go oldimage
getrunningident :: IO (Maybe ContainerIdent)
@@ -271,19 +263,12 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci
extractident :: [Resp] -> Maybe ContainerIdent
extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout
- runps = getRunParams hn $ containerprops ++
- -- 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)
- ]
-
go img = do
- clearProvisionedFlag cid
- createDirectoryIfMissing True (takeDirectory $ identFile cid)
- shim <- Shim.setup (localdir </> "propellor") (localdir </> shimdir cid)
- writeFile (identFile cid) (show ident)
+ 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]
@@ -317,7 +302,7 @@ chain s = case toContainerId s of
-- 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 $ fromContainerId 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
@@ -339,14 +324,14 @@ chain s = case toContainerId s of
-- being run. So, retry connections to the client for up to
-- 1 minute.
provisionContainer :: ContainerId -> Property
-provisionContainer cid = containerDesc cid $ Property "provision" $ do
+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 $ fromContainerId cid]
+ params = ["--continue", show $ Chain $ containerHostName cid]
go lastline (v:rest) = case v of
StdoutLine s -> do
@@ -372,8 +357,8 @@ stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId
stoppedContainer :: ContainerId -> Property
stoppedContainer cid = containerDesc cid $ Property desc $
- ifM (elem cid <$> listContainers RunningContainers)
- ( cleanup `after` ensureProperty
+ ifM (liftIO $ elem cid <$> listContainers RunningContainers)
+ ( liftIO cleanup `after` ensureProperty
(boolProperty desc $ stopContainer cid)
, return NoChange
)
@@ -420,17 +405,18 @@ listContainers status =
listImages :: IO [Image]
listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
-runProp :: String -> RunParam -> Containerized Property
-runProp field val = Containerized
- [\_ -> "--" ++ param]
- (Property (param) (return NoChange))
+runProp :: String -> RunParam -> AttrProperty
+runProp field val = AttrProperty prop $ \attr ->
+ attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] }
where
param = field++"="++val
+ prop = Property (param) (return NoChange)
-genProp :: String -> (HostName -> RunParam) -> Containerized Property
-genProp field mkval = Containerized
- [\h -> "--" ++ field ++ "=" ++ mkval h]
- (Property field (return NoChange))
+genProp :: String -> (HostName -> RunParam) -> AttrProperty
+genProp field mkval = AttrProperty prop $ \attr ->
+ attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] }
+ where
+ prop = Property field (return NoChange)
-- | The ContainerIdent of a container is written to
-- /.propellor-ident inside it. This can be checked to see if
diff --git a/Propellor/Property/File.hs b/Propellor/Property/File.hs
index 80c69d9b..10dee75e 100644
--- a/Propellor/Property/File.hs
+++ b/Propellor/Property/File.hs
@@ -11,6 +11,13 @@ hasContent :: FilePath -> [Line] -> Property
f `hasContent` newcontent = fileProperty ("replace " ++ f)
(\_oldcontent -> newcontent) f
+-- | Ensures a file has contents that comes from PrivData.
+-- Note: Does not do anything with the permissions of the file to prevent
+-- it from being seen.
+hasPrivContent :: FilePath -> Property
+hasPrivContent f = Property ("privcontent " ++ f) $
+ withPrivData (PrivFile f) (\v -> ensureProperty $ f `hasContent` lines v)
+
-- | Ensures that a line is present in a file, adding it to the end if not.
containsLine :: FilePath -> Line -> Property
f `containsLine` l = fileProperty (f ++ " contains:" ++ l) go f
@@ -31,10 +38,10 @@ notPresent f = check (doesFileExist f) $ Property (f ++ " not present") $
makeChange $ nukeFile f
fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property
-fileProperty desc a f = Property desc $ go =<< doesFileExist f
+fileProperty desc a f = Property desc $ go =<< liftIO (doesFileExist f)
where
go True = do
- ls <- lines <$> readFile f
+ ls <- liftIO $ lines <$> readFile f
let ls' = a ls
if ls' == ls
then noChange
@@ -51,3 +58,13 @@ fileProperty desc a f = Property desc $ go =<< doesFileExist f
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
diff --git a/Propellor/Property/Git.hs b/Propellor/Property/Git.hs
new file mode 100644
index 00000000..c0494160
--- /dev/null
+++ b/Propellor/Property/Git.hs
@@ -0,0 +1,48 @@
+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 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
+ ]
diff --git a/Propellor/Property/Hostname.hs b/Propellor/Property/Hostname.hs
index 26635374..03613ac9 100644
--- a/Propellor/Property/Hostname.hs
+++ b/Propellor/Property/Hostname.hs
@@ -3,21 +3,24 @@ module Propellor.Property.Hostname where
import Propellor
import qualified Propellor.Property.File as File
--- | Sets the hostname. Configures both /etc/hostname and the current
--- hostname.
+-- | Ensures that the hostname is set to the HostAttr value.
+-- Configures both /etc/hostname and the current hostname.
--
--- When provided with a FQDN, also configures /etc/hosts,
+-- When the hostname is 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).
-set :: HostName -> Property
-set hostname = combineProperties desc go
- `onChange` cmdProperty "hostname" [host]
+sane :: Property
+sane = Property ("sane hostname") (ensureProperty . setTo =<< getHostName)
+
+setTo :: HostName -> Property
+setTo hn = combineProperties desc go
+ `onChange` cmdProperty "hostname" [basehost]
where
- desc = "hostname " ++ hostname
- (host, domain) = separate (== '.') hostname
+ desc = "hostname " ++ hn
+ (basehost, domain) = separate (== '.') hn
go = catMaybes
- [ Just $ "/etc/hostname" `File.hasContent` [host]
+ [ Just $ "/etc/hostname" `File.hasContent` [basehost]
, if null domain
then Nothing
else Just $ File.fileProperty desc
@@ -25,7 +28,7 @@ set hostname = combineProperties desc go
]
hostip = "127.0.1.1"
- hostline = hostip ++ "\t" ++ hostname ++ " " ++ host
+ 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
index eae5828f..6009778a 100644
--- a/Propellor/Property/Network.hs
+++ b/Propellor/Property/Network.hs
@@ -20,6 +20,7 @@ ipv6to4 = fileProperty "ipv6to4" go interfaces
, "\taddress 2002:5044:5531::1"
, "\tnetmask 64"
, "\tgateway ::192.88.99.1"
+ , "auto sit0"
, "# End automatically added by propeller"
]
diff --git a/Propellor/Property/OpenId.hs b/Propellor/Property/OpenId.hs
new file mode 100644
index 00000000..c397bdb8
--- /dev/null
+++ b/Propellor/Property/OpenId.hs
@@ -0,0 +1,26 @@
+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
+ (map setbaseurl) "/etc/simpleid/config.inc"
+ ] ++ map identfile users
+ where
+ identfile u = File.hasPrivContent $ concat
+ [ "/var/lib/simpleid/identities/", u, ".identity" ]
+ url = "http://"++baseurl++"/simpleid"
+ desc = "openid provider " ++ url
+ setbaseurl l
+ | "SIMPLEID_BASE_URL" `isInfixOf` l =
+ "define('SIMPLEID_BASE_URL', '"++url++"');"
+ | otherwise = l
diff --git a/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs
new file mode 100644
index 00000000..8341765e
--- /dev/null
+++ b/Propellor/Property/Scheduled.hs
@@ -0,0 +1,67 @@
+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 = Property desc $ do
+ lasttime <- liftIO $ getLastChecked (propertyDesc prop)
+ nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
+ t <- liftIO localNow
+ if Just t >= nexttime
+ then do
+ r <- ensureProperty prop
+ 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 <$> readFile lastCheckedFile
+
+writeLastChecked :: M.Map Desc LocalTime -> IO ()
+writeLastChecked = writeFile lastCheckedFile . show
diff --git a/Propellor/Property/Service.hs b/Propellor/Property/Service.hs
new file mode 100644
index 00000000..c6498e57
--- /dev/null
+++ b/Propellor/Property/Service.hs
@@ -0,0 +1,31 @@
+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
index 149c8e6c..204a9ca7 100644
--- a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -24,7 +24,7 @@ builder arch crontimes rsyncupload = combineProperties "gitannexbuilder"
, Apt.buildDep ["git-annex"]
, Apt.installed ["git", "rsync", "moreutils", "ca-certificates",
"liblockfile-simple-perl", "cabal-install", "vim", "less"]
- , serviceRunning "cron" `requires` Apt.installed ["cron"]
+ , Apt.serviceInstalledRunning "cron"
, User.accountFor builduser
, check (not <$> doesDirectoryExist gitbuilderdir) $ userScriptProperty builduser
[ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir
@@ -44,12 +44,13 @@ builder arch crontimes rsyncupload = combineProperties "gitannexbuilder"
let f = homedir </> "rsyncpassword"
if rsyncupload
then withPrivData (Password builduser) $ \p -> do
- oldp <- catchDefaultIO "" $ readFileStrict f
+ oldp <- liftIO $ catchDefaultIO "" $
+ readFileStrict f
if p /= oldp
then makeChange $ writeFile f p
else noChange
else do
- ifM (doesFileExist f)
+ 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
index 38e0cb97..1ba56b94 100644
--- a/Propellor/Property/SiteSpecific/GitHome.hs
+++ b/Propellor/Property/SiteSpecific/GitHome.hs
@@ -8,8 +8,8 @@ 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 =<< homedir user)
- `requires` Apt.installed ["git", "myrepos"]
+ Property ("githome " ++ user) (go =<< liftIO (homedir user))
+ `requires` Apt.installed ["git"]
where
go Nothing = noChange
go (Just home) = do
@@ -20,7 +20,7 @@ installedFor user = check (not <$> hasGitDir user) $
moveout tmpdir home
, Property "rmdir" $ makeChange $ void $
catchMaybeIO $ removeDirectory tmpdir
- , userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; mr checkout; bin/fixups"]
+ , userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; bin/mr checkout; bin/fixups"]
]
moveout tmpdir home = do
fs <- dirContents tmpdir
diff --git a/Propellor/Property/SiteSpecific/JoeySites.hs b/Propellor/Property/SiteSpecific/JoeySites.hs
index 029064dd..46373170 100644
--- a/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -6,8 +6,8 @@ module Propellor.Property.SiteSpecific.JoeySites where
import Propellor
import qualified Propellor.Property.Apt as Apt
-oldUseNetshellBox :: Property
-oldUseNetshellBox = check (not <$> Apt.isInstalled "oldusenet") $
+oldUseNetShellBox :: Property
+oldUseNetShellBox = check (not <$> Apt.isInstalled "oldusenet") $
propertyList ("olduse.net shellbox")
[ 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"
diff --git a/Propellor/Property/Ssh.hs b/Propellor/Property/Ssh.hs
index 36766f56..59845f8f 100644
--- a/Propellor/Property/Ssh.hs
+++ b/Propellor/Property/Ssh.hs
@@ -53,7 +53,7 @@ uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
`onChange` restartSshd
where
prop = Property "ssh unique host keys" $ do
- void $ boolSystem "sh"
+ void $ liftIO $ boolSystem "sh"
[ Param "-c"
, Param "rm -f /etc/ssh/ssh_host_*"
]
diff --git a/Propellor/Property/Sudo.hs b/Propellor/Property/Sudo.hs
index 68b8d056..66ceb580 100644
--- a/Propellor/Property/Sudo.hs
+++ b/Propellor/Property/Sudo.hs
@@ -13,7 +13,7 @@ enabledFor :: UserName -> Property
enabledFor user = Property desc go `requires` Apt.installed ["sudo"]
where
go = do
- locked <- isLockedPassword user
+ locked <- liftIO $ isLockedPassword user
ensureProperty $
fileProperty desc
(modify locked . filter (wanted locked))
diff --git a/Propellor/SimpleSh.hs b/Propellor/SimpleSh.hs
index 99a6fc24..7e0f19ff 100644
--- a/Propellor/SimpleSh.hs
+++ b/Propellor/SimpleSh.hs
@@ -27,7 +27,7 @@ simpleSh namedpipe = do
createDirectoryIfMissing True dir
modifyFileMode dir (removeModes otherGroupModes)
s <- socket AF_UNIX Stream defaultProtocol
- bind s (SockAddrUnix namedpipe)
+ bindSocket s (SockAddrUnix namedpipe)
listen s 2
forever $ do
(client, _addr) <- accept s
diff --git a/Propellor/Types.hs b/Propellor/Types.hs
index 52c0c999..e6e02126 100644
--- a/Propellor/Types.hs
+++ b/Propellor/Types.hs
@@ -1,19 +1,74 @@
-module Propellor.Types where
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Propellor.Types
+ ( Host(..)
+ , Attr
+ , HostName
+ , UserName
+ , GroupName
+ , Propellor(..)
+ , Property(..)
+ , RevertableProperty(..)
+ , AttrProperty(..)
+ , IsProp
+ , describe
+ , toProp
+ , getAttr
+ , requires
+ , Desc
+ , Result(..)
+ , System(..)
+ , Distribution(..)
+ , DebianSuite(..)
+ , Release
+ , Architecture
+ , ActionResult(..)
+ , CmdLine(..)
+ , PrivDataField(..)
+ ) where
import Data.Monoid
+import Control.Applicative
import System.Console.ANSI
+import "mtl" Control.Monad.Reader
+import "MonadCatchIO-transformers" Control.Monad.CatchIO
-type HostName = String
-type UserName = String
+import Propellor.Types.Attr
+
+data Host = Host [Property] (Attr -> Attr)
+type UserName = String
+type GroupName = String
+
+-- | 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
-- | must be idempotent; may run repeatedly
- , propertySatisfy :: IO Result
+ , propertySatisfy :: Propellor Result
}
+-- | A property that can be reverted.
data RevertableProperty = RevertableProperty Property Property
+-- | A property that affects the Attr.
+data AttrProperty = forall p. IsProp p => AttrProperty p (Attr -> Attr)
+
class IsProp p where
-- | Sets description.
describe :: p -> Desc -> p
@@ -21,6 +76,7 @@ class IsProp p where
-- | Indicates that the first property can only be satisfied
-- once the second one is.
requires :: p -> Property -> p
+ getAttr :: p -> (Attr -> Attr)
instance IsProp Property where
describe p d = p { propertyDesc = d }
@@ -30,6 +86,7 @@ instance IsProp Property where
case r of
FailedChange -> return FailedChange
_ -> propertySatisfy x
+ getAttr _ = id
instance IsProp RevertableProperty where
-- | Sets the description of both sides.
@@ -38,6 +95,13 @@ instance IsProp RevertableProperty where
toProp (RevertableProperty p1 _) = p1
(RevertableProperty p1 p2) `requires` y =
RevertableProperty (p1 `requires` y) p2
+ getAttr _ = id
+
+instance IsProp AttrProperty where
+ describe (AttrProperty p a) d = AttrProperty (describe p d) a
+ toProp (AttrProperty p _) = toProp p
+ (AttrProperty p a) `requires` y = AttrProperty (p `requires` y) a
+ getAttr (AttrProperty _ a) = a
type Desc = String
@@ -63,7 +127,7 @@ data Distribution
deriving (Show)
data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release
- deriving (Show)
+ deriving (Show, Eq)
type Release = String
@@ -100,6 +164,7 @@ data PrivDataField
= DockerAuthentication
| SshPrivKey UserName
| Password UserName
+ | PrivFile FilePath
deriving (Read, Show, Ord, Eq)
diff --git a/Propellor/Types/Attr.hs b/Propellor/Types/Attr.hs
new file mode 100644
index 00000000..c253e32b
--- /dev/null
+++ b/Propellor/Types/Attr.hs
@@ -0,0 +1,36 @@
+module Propellor.Types.Attr where
+
+import qualified Data.Set as S
+
+-- | The attributes of a host. For example, its hostname.
+data Attr = Attr
+ { _hostname :: HostName
+ , _cnames :: S.Set Domain
+
+ , _dockerImage :: Maybe String
+ , _dockerRunParams :: [HostName -> String]
+ }
+
+instance Eq Attr where
+ x == y = and
+ [ _hostname x == _hostname y
+ , _cnames x == _cnames 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
+ , "cnames " ++ show (_cnames a)
+ , "docker image " ++ show (_dockerImage a)
+ , "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
+ ]
+
+newAttr :: HostName -> Attr
+newAttr hn = Attr hn S.empty Nothing []
+
+type HostName = String
+type Domain = String
diff --git a/TODO b/TODO
index 3b816ad3..a203169c 100644
--- a/TODO
+++ b/TODO
@@ -2,15 +2,19 @@
run it once for the whole. For example, may want to restart apache,
but only once despite many config changes being made to satisfy
properties. onChange is a poor substitute.
-* --spin needs 4 ssh connections when bootstrapping a new host
- that does not have the git repo yet. Should be possible to get that
- down to 1.
* Currently only Debian and derivatives are supported by most Properties.
- One way to improve that would be to parameterize Properties with a
- Distribution witness.
+ This could be improved by making the Distribution of the system part
+ of its HostAttr.
* Display of docker container properties is a bit wonky. It always
says they are unchanged even when they changed and triggered a
reprovision.
* Should properties be a tree rather than a list?
-* Only make docker garbage collection run once a day or something
- to avoid GC after a temp fail.
+* Need a way for a dns server host to look at the properties of
+ the other hosts and generate a zone file. For example, mapping
+ openid.kitenet.net to a CNAME to clam.kitenet.net, which is where
+ the docker container for that service is located. Moving containers
+ to a different host, or duplicating a container on multiple hosts
+ would then update DNS too
+* There is no way for a property of a docker container to require
+ some property be met outside the container. For example, some servers
+ need ntp installed for a good date source.
diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
new file mode 100644
index 00000000..7f7234c7
--- /dev/null
+++ b/Utility/QuickCheck.hs
@@ -0,0 +1,52 @@
+{- QuickCheck with additional instances
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Utility.QuickCheck
+ ( module X
+ , module Utility.QuickCheck
+ ) where
+
+import Test.QuickCheck as X
+import Data.Time.Clock.POSIX
+import System.Posix.Types
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Control.Applicative
+
+instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where
+ arbitrary = M.fromList <$> arbitrary
+
+instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where
+ arbitrary = S.fromList <$> arbitrary
+
+{- Times before the epoch are excluded. -}
+instance Arbitrary POSIXTime where
+ arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral
+
+instance Arbitrary EpochTime where
+ arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral
+
+{- Pids are never negative, or 0. -}
+instance Arbitrary ProcessID where
+ arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0)
+
+{- Inodes are never negative. -}
+instance Arbitrary FileID where
+ arbitrary = nonNegative arbitrarySizedIntegral
+
+{- File sizes are never negative. -}
+instance Arbitrary FileOffset where
+ arbitrary = nonNegative arbitrarySizedIntegral
+
+nonNegative :: (Num a, Ord a) => Gen a -> Gen a
+nonNegative g = g `suchThat` (>= 0)
+
+positive :: (Num a, Ord a) => Gen a -> Gen a
+positive g = g `suchThat` (> 0)
diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs
new file mode 100644
index 00000000..11e3b569
--- /dev/null
+++ b/Utility/Scheduled.hs
@@ -0,0 +1,358 @@
+{- scheduled activities
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Scheduled (
+ Schedule(..),
+ Recurrance(..),
+ ScheduledTime(..),
+ NextTime(..),
+ WeekDay,
+ MonthDay,
+ YearDay,
+ nextTime,
+ startTime,
+ fromSchedule,
+ fromScheduledTime,
+ toScheduledTime,
+ fromRecurrance,
+ toRecurrance,
+ toSchedule,
+ parseSchedule,
+ prop_schedule_roundtrips
+) where
+
+import Utility.Data
+import Utility.QuickCheck
+import Utility.PartialPrelude
+import Utility.Misc
+
+import Control.Applicative
+import Data.List
+import Data.Time.Clock
+import Data.Time.LocalTime
+import Data.Time.Calendar
+import Data.Time.Calendar.WeekDate
+import Data.Time.Calendar.OrdinalDate
+import Data.Tuple.Utils
+import Data.Char
+
+{- Some sort of scheduled event. -}
+data Schedule = Schedule Recurrance ScheduledTime
+ deriving (Eq, Read, Show, Ord)
+
+data Recurrance
+ = Daily
+ | Weekly (Maybe WeekDay)
+ | Monthly (Maybe MonthDay)
+ | Yearly (Maybe YearDay)
+ | Divisible Int Recurrance
+ -- ^ Days, Weeks, or Months of the year evenly divisible by a number.
+ -- (Divisible Year is years evenly divisible by a number.)
+ deriving (Eq, Read, Show, Ord)
+
+type WeekDay = Int
+type MonthDay = Int
+type YearDay = Int
+
+data ScheduledTime
+ = AnyTime
+ | SpecificTime Hour Minute
+ deriving (Eq, Read, Show, Ord)
+
+type Hour = Int
+type Minute = Int
+
+{- Next time a Schedule should take effect. The NextTimeWindow is used
+ - when a Schedule is allowed to start at some point within the window. -}
+data NextTime
+ = NextTimeExactly LocalTime
+ | NextTimeWindow LocalTime LocalTime
+ deriving (Eq, Read, Show)
+
+startTime :: NextTime -> LocalTime
+startTime (NextTimeExactly t) = t
+startTime (NextTimeWindow t _) = t
+
+nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime)
+nextTime schedule lasttime = do
+ now <- getCurrentTime
+ tz <- getTimeZone now
+ return $ calcNextTime schedule lasttime $ utcToLocalTime tz now
+
+{- Calculate the next time that fits a Schedule, based on the
+ - last time it occurred, and the current time. -}
+calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime
+calcNextTime (Schedule recurrance scheduledtime) lasttime currenttime
+ | scheduledtime == AnyTime = do
+ next <- findfromtoday True
+ return $ case next of
+ NextTimeWindow _ _ -> next
+ NextTimeExactly t -> window (localDay t) (localDay t)
+ | otherwise = NextTimeExactly . startTime <$> findfromtoday False
+ where
+ findfromtoday anytime = findfrom recurrance afterday today
+ where
+ today = localDay currenttime
+ afterday = sameaslastday || toolatetoday
+ toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime
+ sameaslastday = lastday == Just today
+ lastday = localDay <$> lasttime
+ nexttime = case scheduledtime of
+ AnyTime -> TimeOfDay 0 0 0
+ SpecificTime h m -> TimeOfDay h m 0
+ exactly d = NextTimeExactly $ LocalTime d nexttime
+ window startd endd = NextTimeWindow
+ (LocalTime startd nexttime)
+ (LocalTime endd (TimeOfDay 23 59 0))
+ findfrom r afterday day = case r of
+ Daily
+ | afterday -> Just $ exactly $ addDays 1 day
+ | otherwise -> Just $ exactly day
+ Weekly Nothing
+ | afterday -> skip 1
+ | otherwise -> case (wday <$> lastday, wday day) of
+ (Nothing, _) -> Just $ window day (addDays 6 day)
+ (Just old, curr)
+ | old == curr -> Just $ window day (addDays 6 day)
+ | otherwise -> skip 1
+ Monthly Nothing
+ | afterday -> skip 1
+ | maybe True (\old -> mnum day > mday old && mday day >= (mday old `mod` minmday)) lastday ->
+ -- Window only covers current month,
+ -- in case there is a Divisible requirement.
+ Just $ window day (endOfMonth day)
+ | otherwise -> skip 1
+ Yearly Nothing
+ | afterday -> skip 1
+ | maybe True (\old -> ynum day > ynum old && yday day >= (yday old `mod` minyday)) lastday ->
+ Just $ window day (endOfYear day)
+ | otherwise -> skip 1
+ Weekly (Just w)
+ | w < 0 || w > maxwday -> Nothing
+ | w == wday day -> if afterday
+ then Just $ exactly $ addDays 7 day
+ else Just $ exactly day
+ | otherwise -> Just $ exactly $
+ addDays (fromIntegral $ (w - wday day) `mod` 7) day
+ Monthly (Just m)
+ | m < 0 || m > maxmday -> Nothing
+ -- TODO can be done more efficiently than recursing
+ | m == mday day -> if afterday
+ then skip 1
+ else Just $ exactly day
+ | otherwise -> skip 1
+ Yearly (Just y)
+ | y < 0 || y > maxyday -> Nothing
+ | y == yday day -> if afterday
+ then skip 365
+ else Just $ exactly day
+ | otherwise -> skip 1
+ Divisible n r'@Daily -> handlediv n r' yday (Just maxyday)
+ Divisible n r'@(Weekly _) -> handlediv n r' wnum (Just maxwnum)
+ Divisible n r'@(Monthly _) -> handlediv n r' mnum (Just maxmnum)
+ Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing
+ Divisible _ r'@(Divisible _ _) -> findfrom r' afterday day
+ where
+ skip n = findfrom r False (addDays n day)
+ handlediv n r' getval mmax
+ | n > 0 && maybe True (n <=) mmax =
+ findfromwhere r' (divisible n . getval) afterday day
+ | otherwise = Nothing
+ findfromwhere r p afterday day
+ | maybe True (p . getday) next = next
+ | otherwise = maybe Nothing (findfromwhere r p True . getday) next
+ where
+ next = findfrom r afterday day
+ getday = localDay . startTime
+ divisible n v = v `rem` n == 0
+
+endOfMonth :: Day -> Day
+endOfMonth day =
+ let (y,m,_d) = toGregorian day
+ in fromGregorian y m (gregorianMonthLength y m)
+
+endOfYear :: Day -> Day
+endOfYear day =
+ let (y,_m,_d) = toGregorian day
+ in endOfMonth (fromGregorian y maxmnum 1)
+
+-- extracting various quantities from a Day
+wday :: Day -> Int
+wday = thd3 . toWeekDate
+wnum :: Day -> Int
+wnum = snd3 . toWeekDate
+mday :: Day -> Int
+mday = thd3 . toGregorian
+mnum :: Day -> Int
+mnum = snd3 . toGregorian
+yday :: Day -> Int
+yday = snd . toOrdinalDate
+ynum :: Day -> Int
+ynum = fromIntegral . fst . toOrdinalDate
+
+{- Calendar max and mins. -}
+maxyday :: Int
+maxyday = 366 -- with leap days
+minyday :: Int
+minyday = 365
+maxwnum :: Int
+maxwnum = 53 -- some years have more than 52
+maxmday :: Int
+maxmday = 31
+minmday :: Int
+minmday = 28
+maxmnum :: Int
+maxmnum = 12
+maxwday :: Int
+maxwday = 7
+
+fromRecurrance :: Recurrance -> String
+fromRecurrance (Divisible n r) =
+ fromRecurrance' (++ "s divisible by " ++ show n) r
+fromRecurrance r = fromRecurrance' ("every " ++) r
+
+fromRecurrance' :: (String -> String) -> Recurrance -> String
+fromRecurrance' a Daily = a "day"
+fromRecurrance' a (Weekly n) = onday n (a "week")
+fromRecurrance' a (Monthly n) = onday n (a "month")
+fromRecurrance' a (Yearly n) = onday n (a "year")
+fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used
+
+onday :: Maybe Int -> String -> String
+onday (Just n) s = "on day " ++ show n ++ " of " ++ s
+onday Nothing s = s
+
+toRecurrance :: String -> Maybe Recurrance
+toRecurrance s = case words s of
+ ("every":"day":[]) -> Just Daily
+ ("on":"day":sd:"of":"every":something:[]) -> withday sd something
+ ("every":something:[]) -> noday something
+ ("days":"divisible":"by":sn:[]) ->
+ Divisible <$> getdivisor sn <*> pure Daily
+ ("on":"day":sd:"of":something:"divisible":"by":sn:[]) ->
+ Divisible
+ <$> getdivisor sn
+ <*> withday sd something
+ ("every":something:"divisible":"by":sn:[]) ->
+ Divisible
+ <$> getdivisor sn
+ <*> noday something
+ (something:"divisible":"by":sn:[]) ->
+ Divisible
+ <$> getdivisor sn
+ <*> noday something
+ _ -> Nothing
+ where
+ constructor "week" = Just Weekly
+ constructor "month" = Just Monthly
+ constructor "year" = Just Yearly
+ constructor u
+ | "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u
+ | otherwise = Nothing
+ withday sd u = do
+ c <- constructor u
+ d <- readish sd
+ Just $ c (Just d)
+ noday u = do
+ c <- constructor u
+ Just $ c Nothing
+ getdivisor sn = do
+ n <- readish sn
+ if n > 0
+ then Just n
+ else Nothing
+
+fromScheduledTime :: ScheduledTime -> String
+fromScheduledTime AnyTime = "any time"
+fromScheduledTime (SpecificTime h m) =
+ show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm
+ where
+ pad n s = take (n - length s) (repeat '0') ++ s
+ (h', ampm)
+ | h == 0 = (12, "AM")
+ | h < 12 = (h, "AM")
+ | h == 12 = (h, "PM")
+ | otherwise = (h - 12, "PM")
+
+toScheduledTime :: String -> Maybe ScheduledTime
+toScheduledTime "any time" = Just AnyTime
+toScheduledTime v = case words v of
+ (s:ampm:[])
+ | map toUpper ampm == "AM" ->
+ go s h0
+ | map toUpper ampm == "PM" ->
+ go s (\h -> (h0 h) + 12)
+ | otherwise -> Nothing
+ (s:[]) -> go s id
+ _ -> Nothing
+ where
+ h0 h
+ | h == 12 = 0
+ | otherwise = h
+ go :: String -> (Int -> Int) -> Maybe ScheduledTime
+ go s adjust =
+ let (h, m) = separate (== ':') s
+ in SpecificTime
+ <$> (adjust <$> readish h)
+ <*> if null m then Just 0 else readish m
+
+fromSchedule :: Schedule -> String
+fromSchedule (Schedule recurrance scheduledtime) = unwords
+ [ fromRecurrance recurrance
+ , "at"
+ , fromScheduledTime scheduledtime
+ ]
+
+toSchedule :: String -> Maybe Schedule
+toSchedule = eitherToMaybe . parseSchedule
+
+parseSchedule :: String -> Either String Schedule
+parseSchedule s = do
+ r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right
+ (toRecurrance recurrance)
+ t <- maybe (Left $ "bad time of day: " ++ scheduledtime) Right
+ (toScheduledTime scheduledtime)
+ Right $ Schedule r t
+ where
+ (rws, tws) = separate (== "at") (words s)
+ recurrance = unwords rws
+ scheduledtime = unwords tws
+
+instance Arbitrary Schedule where
+ arbitrary = Schedule <$> arbitrary <*> arbitrary
+
+instance Arbitrary ScheduledTime where
+ arbitrary = oneof
+ [ pure AnyTime
+ , SpecificTime
+ <$> choose (0, 23)
+ <*> choose (1, 59)
+ ]
+
+instance Arbitrary Recurrance where
+ arbitrary = oneof
+ [ pure Daily
+ , Weekly <$> arbday
+ , Monthly <$> arbday
+ , Yearly <$> arbday
+ , Divisible
+ <$> positive arbitrary
+ <*> oneof -- no nested Divisibles
+ [ pure Daily
+ , Weekly <$> arbday
+ , Monthly <$> arbday
+ , Yearly <$> arbday
+ ]
+ ]
+ where
+ arbday = oneof
+ [ Just <$> nonNegative arbitrary
+ , pure Nothing
+ ]
+
+prop_schedule_roundtrips :: Schedule -> Bool
+prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s
diff --git a/config-joey.hs b/config-joey.hs
index f2cc5e78..cd0583fb 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -2,6 +2,7 @@
import Propellor
import Propellor.CmdLine
+import Propellor.Property.Scheduled
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Network as Network
@@ -12,124 +13,167 @@ import qualified Propellor.Property.User as User
import qualified Propellor.Property.Hostname as Hostname
--import qualified Propellor.Property.Reboot as Reboot
import qualified Propellor.Property.Tor as Tor
+import qualified Propellor.Property.Dns as Dns
+import qualified Propellor.Property.OpenId as OpenId
import qualified Propellor.Property.Docker as Docker
+import qualified Propellor.Property.Git as Git
import qualified Propellor.Property.SiteSpecific.GitHome as GitHome
import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder
import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites
-import Data.List
-main :: IO ()
-main = defaultMain [host, Docker.containerProperties container]
-
--- | This is where the system's HostName, either as returned by uname
--- or one specified on the command line, is converted into a list of
--- Properties for that system.
---
--- Edit this to configure propellor!
-host :: HostName -> Maybe [Property]
--- Clam is a tor bridge, and an olduse.net shellbox and other fun stuff.
-host hostname@"clam.kitenet.net" = standardSystem Unstable $ props
- & cleanCloudAtCost hostname
- & Apt.unattendedUpgrades
- & Network.ipv6to4
- & Apt.installed ["git-annex", "mtr"]
- & Tor.isBridge
- & JoeySites.oldUseNetshellBox
- & Docker.configured
- & Docker.garbageCollected
--- Orca is the main git-annex build box.
-host hostname@"orca.kitenet.net" = standardSystem Unstable $ props
- & Hostname.set hostname
- & Apt.unattendedUpgrades
- & Docker.configured
- & Apt.buildDep ["git-annex"]
- & Docker.docked container hostname "amd64-git-annex-builder"
- & Docker.docked container hostname "i386-git-annex-builder"
- & Docker.docked container hostname "armel-git-annex-builder-companion"
- & Docker.docked container hostname "armel-git-annex-builder"
- & Docker.garbageCollected
--- My laptop
-host _hostname@"darkstar.kitenet.net" = Just $ props
- & Docker.configured
+hosts :: [Host]
+hosts =
+ -- My laptop
+ [ host "darkstar.kitenet.net"
+ & Docker.configured
+ & Apt.buildDep ["git-annex"] `period` Daily
+
+ -- Nothing super-important lives here.
+ , standardSystem "clam.kitenet.net" Unstable
+ & cleanCloudAtCost
+ & Apt.unattendedUpgrades
+ & Network.ipv6to4
+ & Tor.isBridge
+ & Docker.configured
+ & cname "shell.olduse.net"
+ & JoeySites.oldUseNetShellBox
+
+ & cname "openid.kitenet.net"
+ & Docker.docked hosts "openid-provider"
+ `requires` Apt.installed ["ntp"]
+
+ & cname "ancient.kitenet.net"
+ & Docker.docked hosts "ancient-kitenet"
+
+ & Docker.garbageCollected `period` Daily
+ & Apt.installed ["git-annex", "mtr", "screen"]
--- add more hosts here...
---host "foo.example.com" =
-host _ = Nothing
-
--- | This is where Docker containers are set up. A container
--- can vary by hostname where it's used, or be the same everywhere.
-container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container)
-container _host name
- | name == "webserver" = Just $ Docker.containerFrom
- (image $ System (Debian Unstable) "amd64")
- [ Docker.publish "8080:80"
- , Docker.volume "/var/www:/var/www"
- , Docker.inside $ props
- & serviceRunning "apache2"
- `requires` Apt.installed ["apache2"]
- ]
+ -- Orca is the main git-annex build box.
+ , standardSystem "orca.kitenet.net" Unstable
+ & Hostname.sane
+ & Apt.unattendedUpgrades
+ & Docker.configured
+ & Docker.docked hosts "amd64-git-annex-builder"
+ & Docker.docked hosts "i386-git-annex-builder"
+ ! Docker.docked hosts "armel-git-annex-builder-companion"
+ ! Docker.docked hosts "armel-git-annex-builder"
+ & Docker.garbageCollected `period` Daily
+ & Apt.buildDep ["git-annex"] `period` Daily
+
+ -- Important stuff that needs not too much memory or CPU.
+ , standardSystem "diatom.kitenet.net" Stable
+ & Hostname.sane
+ & Apt.unattendedUpgrades
+ & Apt.serviceInstalledRunning "ntp"
+ & Dns.zones myDnsSecondary
+ & Apt.serviceInstalledRunning "apache2"
+ & Apt.installed ["git", "git-annex", "rsync"]
+ & Apt.buildDep ["git-annex"] `period` Daily
+ & Git.daemonRunning "/srv/git"
+ & File.ownerGroup "/srv/git" "joey" "joey"
+ -- git repos restore (how?)
+ -- family annex needs family members to have accounts,
+ -- ssh host key etc.. finesse?
+ -- (also should upgrade git-annex-shell for it..)
+ -- kgb installation and setup
+ -- ssh keys for branchable and github repo hooks
+ -- gitweb
+ -- downloads.kitenet.net setup (including ssh key to turtle)
+
+ --------------------------------------------------------------------
+ -- Docker Containers ----------------------------------- \o/ -----
+ --------------------------------------------------------------------
+
+ -- Simple web server, publishing the outside host's /var/www
+ , standardContainer "webserver" Stable "amd64"
+ & Docker.publish "8080:80"
+ & Docker.volume "/var/www:/var/www"
+ & Apt.serviceInstalledRunning "apache2"
+
+ -- My own openid provider. Uses php, so containerized for security
+ -- and administrative sanity.
+ , standardContainer "openid-provider" Stable "amd64"
+ & Docker.publish "8081:80"
+ & OpenId.providerFor ["joey", "liw"]
+ "openid.kitenet.net:8081"
+
+ , standardContainer "ancient-kitenet" Stable "amd64"
+ & Docker.publish "1994:80"
+ & Apt.serviceInstalledRunning "apache2"
+ & Apt.installed ["git"]
+ & scriptProperty
+ [ "cd /var/"
+ , "rm -rf www"
+ , "git clone git://git.kitenet.net/kitewiki www"
+ , "cd www"
+ , "git checkout remotes/origin/old-kitenet.net"
+ ] `flagFile` "/var/www/blastfromthepast.html"
+ -- git-annex autobuilder containers
+ , gitAnnexBuilder "amd64" 15
+ , gitAnnexBuilder "i386" 45
-- armel builder has a companion container that run amd64 and
-- runs the build first to get TH splices. They share a home
-- directory, and need to have the same versions of all haskell
-- libraries installed.
- | name == "armel-git-annex-builder-companion" = Just $ Docker.containerFrom
+ , Docker.container "armel-git-annex-builder-companion"
(image $ System (Debian Unstable) "amd64")
- [ Docker.volume GitAnnexBuilder.homedir
- ]
- | name == "armel-git-annex-builder" = Just $ Docker.containerFrom
+ & Docker.volume GitAnnexBuilder.homedir
+ & Apt.unattendedUpgrades
+ , Docker.container "armel-git-annex-builder"
(image $ System (Debian Unstable) "armel")
- [ Docker.link (name ++ "-companion") "companion"
- , Docker.volumes_from (name ++ "-companion")
- , Docker.inside $ props
--- & GitAnnexBuilder.builder "armel" "15 * * * *" True
- ]
-
- | "-git-annex-builder" `isSuffixOf` name =
- let arch = takeWhile (/= '-') name
- in Just $ Docker.containerFrom
- (image $ System (Debian Unstable) arch)
- [ Docker.inside $ props & GitAnnexBuilder.builder arch "15 * * * *" True ]
-
- | otherwise = Nothing
+ & Docker.link "armel-git-annex-builder-companion" "companion"
+ & Docker.volumes_from "armel-git-annex-builder-companion"
+-- & GitAnnexBuilder.builder "armel" "15 * * * *" True
+ & Apt.unattendedUpgrades
+ ]
+
+gitAnnexBuilder :: Architecture -> Int -> Host
+gitAnnexBuilder arch buildminute = Docker.container (arch ++ "-git-annex-builder")
+ (image $ System (Debian Unstable) arch)
+ & GitAnnexBuilder.builder arch (show buildminute ++ " * * * *") True
+ & Apt.unattendedUpgrades
+
+-- This is my standard system setup.
+standardSystem :: HostName -> DebianSuite -> Host
+standardSystem hn suite = host hn
+ & Apt.stdSourcesList suite `onChange` Apt.upgrade
+ & Apt.installed ["etckeeper"]
+ & Apt.installed ["ssh"]
+ & GitHome.installedFor "root"
+ & User.hasSomePassword "root"
+ -- Harden the system, but only once root's authorized_keys
+ -- is safely in place.
+ & check (Ssh.hasAuthorizedKeys "root")
+ (Ssh.passwordAuthentication False)
+ & User.accountFor "joey"
+ & User.hasSomePassword "joey"
+ & Sudo.enabledFor "joey"
+ & GitHome.installedFor "joey"
+ & Apt.installed ["vim", "screen", "less"]
+ & Cron.runPropellor "30 * * * *"
+ -- I use postfix, or no MTA.
+ & Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
+ `onChange` Apt.autoRemove
+
+-- This is my standard container setup, featuring automatic upgrades.
+standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host
+standardContainer name suite arch = Docker.container name (image system)
+ & Apt.stdSourcesList suite
+ & Apt.unattendedUpgrades
+ where
+ system = System (Debian suite) arch
-- | Docker images I prefer to use.
image :: System -> Docker.Image
image (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch
+image (System (Debian Stable) arch) = "joeyh/debian-stable-" ++ arch
image _ = "debian-stable-official" -- does not currently exist!
--- This is my standard system setup
-standardSystem :: DebianSuite -> [Property] -> Maybe [Property]
-standardSystem suite customprops = Just $
- standardprops : customprops ++ endprops
- where
- standardprops = propertyList "standard system" $ props
- & Apt.stdSourcesList suite `onChange` Apt.upgrade
- & Apt.installed ["etckeeper"]
- & Apt.installed ["ssh"]
- & GitHome.installedFor "root"
- & User.hasSomePassword "root"
- -- Harden the system, but only once root's authorized_keys
- -- is safely in place.
- & check (Ssh.hasAuthorizedKeys "root")
- (Ssh.passwordAuthentication False)
- & User.accountFor "joey"
- & User.hasSomePassword "joey"
- & Sudo.enabledFor "joey"
- & GitHome.installedFor "joey"
- & Apt.installed ["vim", "screen", "less"]
- & Cron.runPropellor "30 * * * *"
- -- I use postfix, or no MTA.
- & Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
- `onChange` Apt.autoRemove
- -- May reboot, so comes last
- -- Currently not enable due to #726375
- endprops = [] -- [Apt.installed ["systemd-sysv"] `onChange` Reboot.now]
-
-- Clean up a system as installed by cloudatcost.com
-cleanCloudAtCost :: HostName -> Property
-cleanCloudAtCost hostname = propertyList "cloudatcost cleanup"
- [ Hostname.set hostname
+cleanCloudAtCost :: Property
+cleanCloudAtCost = propertyList "cloudatcost cleanup"
+ [ Hostname.sane
, Ssh.uniqueHostKeys
, "worked around grub/lvm boot bug #743126" ==>
"/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true"
@@ -141,3 +185,18 @@ cleanCloudAtCost hostname = propertyList "cloudatcost cleanup"
, User.nuked "user" User.YesReallyDeleteHome
]
]
+
+myDnsSecondary :: [Dns.Zone]
+myDnsSecondary =
+ [ Dns.secondary "kitenet.net" master
+ , Dns.secondary "joeyh.name" master
+ , Dns.secondary "ikiwiki.info" master
+ , Dns.secondary "olduse.net" master
+ , Dns.secondary "branchable.com" branchablemaster
+ ]
+ where
+ master = ["80.68.85.49", "2001:41c8:125:49::10"] -- wren
+ branchablemaster = ["66.228.46.55", "2600:3c03::f03c:91ff:fedf:c0e5"]
+
+main :: IO ()
+main = defaultMain hosts --, Docker.containerProperties container]
diff --git a/config-simple.hs b/config-simple.hs
index d5015ef3..23a760c8 100644
--- a/config-simple.hs
+++ b/config-simple.hs
@@ -3,6 +3,7 @@
import Propellor
import Propellor.CmdLine
+import Propellor.Property.Scheduled
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Network as Network
@@ -15,39 +16,32 @@ import qualified Propellor.Property.User as User
--import qualified Propellor.Property.Tor as Tor
import qualified Propellor.Property.Docker as Docker
-main :: IO ()
-main = defaultMain [host, Docker.containerProperties container]
-
--- | This is where the system's HostName, either as returned by uname
--- or one specified on the command line, is converted into a list of
--- Properties for that system.
---
+-- The hosts propellor knows about.
-- Edit this to configure propellor!
-host :: HostName -> Maybe [Property]
-host hostname@"mybox.example.com" = Just $ props
- & Apt.stdSourcesList Unstable
- `onChange` Apt.upgrade
- & Apt.unattendedUpgrades
- & Apt.installed ["etckeeper"]
- & Apt.installed ["ssh"]
- & User.hasSomePassword "root"
- & Network.ipv6to4
- & File.dirExists "/var/www"
- & Docker.docked container hostname "webserver"
- & Docker.garbageCollected
- & Cron.runPropellor "30 * * * *"
--- add more hosts here...
---host "foo.example.com" =
-host _ = Nothing
+hosts :: [Host]
+hosts =
+ [ host "mybox.example.com"
+ & Apt.stdSourcesList Unstable
+ `onChange` Apt.upgrade
+ & Apt.unattendedUpgrades
+ & Apt.installed ["etckeeper"]
+ & Apt.installed ["ssh"]
+ & User.hasSomePassword "root"
+ & Network.ipv6to4
+ & File.dirExists "/var/www"
+ & Docker.docked hosts "webserver"
+ & Docker.garbageCollected `period` Daily
+ & Cron.runPropellor "30 * * * *"
+
+ -- A generic webserver in a Docker container.
+ , Docker.container "webserver" "joeyh/debian-unstable"
+ & Docker.publish "80:80"
+ & Docker.volume "/var/www:/var/www"
+ & Apt.serviceInstalledRunning "apache2"
--- | This is where Docker containers are set up. A container
--- can vary by hostname where it's used, or be the same everywhere.
-container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container)
-container _ "webserver" = Just $ Docker.containerFrom "joeyh/debian-unstable"
- [ Docker.publish "80:80"
- , Docker.volume "/var/www:/var/www"
- , Docker.inside $ props
- & serviceRunning "apache2"
- `requires` Apt.installed ["apache2"]
+ -- add more hosts here...
+ --, host "foo.example.com" = ...
]
-container _ _ = Nothing
+
+main :: IO ()
+main = defaultMain hosts
diff --git a/debian/changelog b/debian/changelog
index 4455768f..a9a142df 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,18 @@
+propellor (0.3.0) UNRELEASED; urgency=medium
+
+ * ipv6to4: Ensure interface is brought up automatically on boot.
+ * Enabling unattended upgrades now ensures that cron is installed and
+ running to perform them.
+ * Properties can be scheduled to only be checked after a given time period.
+ * Fix bootstrapping of dependencies.
+ * Fix compilation on Debian stable.
+ * Include security updates in sources.list for stable and testing.
+ * Use ssh connection caching, especially when bootstrapping.
+ * Properties now run in a Propellor monad, which provides access to
+ attributes of the host.
+
+ -- Joey Hess <joeyh@debian.org> Tue, 08 Apr 2014 18:07:12 -0400
+
propellor (0.2.3) unstable; urgency=medium
* docker: Fix laziness bug that caused running containers to be
diff --git a/debian/control b/debian/control
index 3f5cb2da..bfdc5880 100644
--- a/debian/control
+++ b/debian/control
@@ -11,6 +11,8 @@ Build-Depends:
libghc-unix-compat-dev,
libghc-ansi-terminal-dev,
libghc-ifelse-dev,
+ libghc-mtl-dev,
+ libghc-monadcatchio-transformers-dev,
Maintainer: Joey Hess <joeyh@debian.org>
Standards-Version: 3.9.5
Vcs-Git: git://git.kitenet.net/propellor
@@ -28,6 +30,8 @@ Depends: ${misc:Depends}, ${shlibs:Depends},
libghc-unix-compat-dev,
libghc-ansi-terminal-dev,
libghc-ifelse-dev,
+ libghc-mtl-dev,
+ libghc-monadcatchio-transformers-dev,
git,
Description: property-based host configuration management in haskell
Propellor enures that the system it's run in satisfies a list of
diff --git a/privdata/clam.kitenet.net.gpg b/privdata/clam.kitenet.net.gpg
index 72f72a86..69d8f12f 100644
--- a/privdata/clam.kitenet.net.gpg
+++ b/privdata/clam.kitenet.net.gpg
@@ -1,22 +1,25 @@
-----BEGIN PGP MESSAGE-----
Version: GnuPG v1
-hQIMA7ODiaEXBlRZAQ//fmOcGRNxe/ooyFebOl54oFJtUvmWclBN8ycWb+1FEiED
-4293/YYL13OXStSDCMc1o0Rq6SxRpkD/xavcc2wqBa4rTEvOzU/YdhXRLOCr2QwQ
-Mhn4vtLmQqaQwYz5tzPkfRwtB/Wx/R4dJBfNF5vp+nl788fF+cdgLLSihY+TEPSk
-+Wo2PZ0jNvCSpVR99Rh3o3ut57shsVGGa4Z4uaXfLVOu118Z00iyKZ9pHFa7gLH4
-nU1Y8N8JPg0Z+zJvTbJGU66k5LMZx9a/cu/+dwk2KPm3uldld4dwFk9zkmnzsIzS
-UhWWsuea4OGanjDsPZzECkLY/AOWxRL7+4qC6c9vsFagktJezRNqNImeSkYi9fR5
-xw4VnhL5JwC2RF3gMC8XHYSx5C1ByGIq0gaklJjdPRn3Kj7/zSOefgNZC/O+wSfG
-V5W7kW7x6vvMv9og3k4BBpD4p2s94O8xtztLE+wOXxJclFen37FNhwuJyp7PiBN6
-T4PgekpqPfX9Xp4M1tgyUVV9m8Jeof0TtS/YsKeYqaGk1ZKPOJvqXnZTL5LOkaqE
-KTWYnWdBROwNXhsaIUnu8YHqf2mRA5VlCl1Uspd3SIyU1Xh0LL9stPnxdyJGghrG
-RTmTJsEkzPAxnjSop72sEkKjqwkHxNbEkXg690QEPon+m/FAg083yTtKH/whbQ7S
-wFIBtEWDmBQyFmc1fvi1IouM9fUij6AwtJx2JrWE2d68BqE1moFGGiRSnf7itNc0
-YFashaGMSRZAzlx6quMJtg3sE/Xw4zra1b8SkvmH6FoQnQ2rXriG5U4Hc6bW0jIX
-48O96/NbIwabZiwC5BKGmSPpQBDnyzruWR/Qsnw6uar5/ZKsIOvPhICCvChO03So
-6C6WLHFb9trLqpB+r8BOMjUG/FPqZ4lRanQ3Xn///lLD2uuhH27Pmt/XDpwRJgsz
-V+uM6TVQMBe5XyE3LOk7Yn0oosohYF0LFFzQH0mO5cykx+Ctjt1muxKoUmcN99ms
-j99fwMhrk1qlzlu2Yoe5caph4M44TXbQRGhPX7jXDJzYbRdS
-=GYf9
+hQIMA7ODiaEXBlRZARAAuRttWmrr3tFgQnbnaQpWxiAQToL94e0SctFiYqiEGRNa
+D63/ZaBhBkvKSx57+SyOloqfBaeWM63vd4Yacocypl2zOjC4aEN7/MKyQRl+xhmk
+EwQ4kFfJ3dmYrgXt7NAdIarjHsK5/Bv7PGVIrcwD3zqV+FUyuxt2L2ETG61kYo+m
+xNWl1NCvHDZ1QOfvw4ldBo7+LO2odzoZAxBF0ZgQFqo/r/6RZaqFNJRLdVTLERTq
+E4igjtgfq6blrpyeupKpFu6oy8/7WeBXthnyoduftk+aBTkXWzb+i30zIzNNsc4+
+GE68a5tM0XE8nGwKp4yz0AZHhEYzv+BZXI7HQMAZ+m0srVn637SDHeAgOBU8NjrA
+SbZt0ubQ28Qaux7C7awLJ5SjvlQyLT61jLaN6SMcpeLmgkjRVN+eiVOE/qmXzhHv
+AobUwJgBOktiN6+WtRcxq7WduNf6Jtxw8UB5gVWiEeg6o+29ZBfIKVMT/Jly4rTO
+M13HbmSVzwdGcUL1D7Gf3oY2R7eS4VR8ShCQmF8aB8TXdsw4mo71HnUa7u5N4hCP
+jLtJG24+f39TWWRjMQjtFXi5hkep4OG5CBViWdCWOjlfn4Kmr5zCXaunkO9cgDAd
+s8UZdmALu2MPoVdcVm+KLq2JQi1jBWEqRu5krx/nSi+eRRX2/y95CKPEPqZoU+rS
+wM0BzlW+pEDc7aFlcYCrWTiwO0BWT2iBmbse9/r2NyJPpuFf7GOMI2v65jXQ+avy
+1r69zPdAXNgJ19Gid/q1CXCYnYLLVHqigd8XNs12ANaVvkOnBi3gAf309SIPJtCa
+uFVBxNasLTMQ3Ta7v7TLa0PopdBuFqfcy9d3BBiOKqokvhWFJobaG/WhF85ercRJ
+F8lse9fgo5xfrDoCFk7u9rzhHl8xKLl24thKFTDzwm+yuzXOoLq8+Km/xYuzQXZK
+JCjPvIUDaCCc1E/Yeoc3RafAiOuNwnjHW15TRdlohmgXzYlTCYF491WVKQfpL2Sd
+VO8Uar094M1d52Rv8/1HCTBKJ0hnK259l4dguzw4sl2BcrFPBz9SJ0f6V/eAHE0h
+la5QtLdwDDRI2giMXKfmzRiRA/5kBW01YaK7tt0om6L7Ri4Rs3JAhVgjcWDtH6fI
+w807PpsIHaK8r3yDJoeqUnDYOsImuNgdctQkeroPsFYmV3fu5Hb5tYDkKzm5lE0z
+C6mz09PD0M5hsnqmZXaw
+=UFa1
-----END PGP MESSAGE-----
diff --git a/privdata/diatom.kitenet.net.gpg b/privdata/diatom.kitenet.net.gpg
new file mode 100644
index 00000000..7c36ab2e
--- /dev/null
+++ b/privdata/diatom.kitenet.net.gpg
@@ -0,0 +1,19 @@
+-----BEGIN PGP MESSAGE-----
+Version: GnuPG v1
+
+hQIMA7ODiaEXBlRZAQ//Qsi46/S4X9qWNSCqFUuUOdoKnuOro0SIKfR19Z0SlseL
+AH5cPWUX2eIFA3tzku5Psm8enxGc2jyMhfS5KQkVMLoV/SdgLTEfbsF2TkOGUIFf
+AMEt+HOPercftwzU+KnwyNJ6kfCinlgmehLwAHLvD8HfzsL9lD59dJGkYQ61cDZ8
+NQSOJwbLVzlXGoMjUcQ6ihmg7gOEGptO7F+p4oamOYwpzibaFGX2BsczMRDcjlGY
+B+ufxINqj2bV17lHchNs/Je8uF5Owe+5zoK2cf6TTCdtlIcWjuw6YIMUPWHhIx3C
+DCrEFS/rOJCyY+M8CwIfqS0JTJVNIKJfhP8LbbaoyRyXB2XF2eLM1bQ25p//fpav
++MRQ/0SqnGXYV7ZQE/a+/dESi8/u2yua1m1DBwXzAp468pCTaZCm9gwV+D9Ggsbr
+uCU5K/cTa7wPyzfYtki0jkM+R1uk1HqWuHHt0/CD1VnDM3Zrj2JVkoE+pR1LhiSH
+qKj8/zF935QmGrCUUjo+1bBn20BDiiFPiiPo4KN3At2uK4qQo1F0c+JUQUHGKV9r
+O/c4v0dhPj/Qq5kSp5higO8n2Afv68wAfCWBkBo6SpCS7nuR7xvLWD7pWBTS/0BG
+BcL4recUTckQHPo+VUNMYlSNeUhnlv/2TK7/qsfPMYTi0Xu/Fr+bnKn3QOPbgITS
+cgHrplzueGhsVhhy+Cpn31FptA7txwcAWuWcZmT7ych0APt/PdkZ1CdeQ3gQop0p
+BXaUlY7N4PacFyrC8Jha4p8THbbmfg6zTwaPggH8HonOIL5iA2yZz78uvZwqUd5i
+QD0LMQZ3ZgNiqlwLxA8e6heSNA==
+=V6He
+-----END PGP MESSAGE-----
diff --git a/propellor.cabal b/propellor.cabal
index 0869ef58..5497cc6b 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -1,5 +1,5 @@
Name: propellor
-Version: 0.2.3
+Version: 0.3.0
Cabal-Version: >= 1.6
License: GPL
Maintainer: Joey Hess <joey@kitenet.net>
@@ -38,7 +38,8 @@ Executable propellor
GHC-Options: -Wall
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
- containers, network, async
+ containers, network, async, time, QuickCheck, mtl,
+ MonadCatchIO-transformers
if (! os(windows))
Build-Depends: unix
@@ -48,7 +49,8 @@ Executable config
GHC-Options: -Wall -threaded
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
- containers, network, async
+ containers, network, async, time, QuickCheck, mtl,
+ MonadCatchIO-transformers
if (! os(windows))
Build-Depends: unix
@@ -57,7 +59,8 @@ Library
GHC-Options: -Wall
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
- containers, network, async
+ containers, network, async, time, QuickCheck, mtl,
+ MonadCatchIO-transformers
if (! os(windows))
Build-Depends: unix
@@ -69,10 +72,15 @@ Library
Propellor.Property.Cmd
Propellor.Property.Hostname
Propellor.Property.Cron
+ Propellor.Property.Dns
Propellor.Property.Docker
Propellor.Property.File
+ Propellor.Property.Git
Propellor.Property.Network
+ Propellor.Property.OpenId
Propellor.Property.Reboot
+ Propellor.Property.Scheduled
+ Propellor.Property.Service
Propellor.Property.Ssh
Propellor.Property.Sudo
Propellor.Property.Tor
@@ -80,11 +88,14 @@ Library
Propellor.Property.SiteSpecific.GitHome
Propellor.Property.SiteSpecific.JoeySites
Propellor.Property.SiteSpecific.GitAnnexBuilder
+ Propellor.Attr
Propellor.Message
Propellor.PrivData
Propellor.Engine
+ Propellor.Exception
Propellor.Types
Other-Modules:
+ Propellor.Types.Attr
Propellor.CmdLine
Propellor.SimpleSh
Propellor.Property.Docker.Shim
@@ -103,9 +114,11 @@ Library
Utility.PosixFiles
Utility.Process
Utility.SafeCommand
+ Utility.Scheduled
Utility.ThreadScheduler
Utility.Tmp
Utility.UserInfo
+ Utility.QuickCheck
source-repository head
type: git