Merge branch 'joeyconfig'

config-joey.hs

@@ -58,7 +58,7 @@ hosts =               --                  (o)  `
 
 		& alias "openid.kitenet.net"
 		& Docker.docked hosts "openid-provider"
-		 	`requires` Apt.installed ["ntp"]
+		 	`requires` Apt.serviceInstalledRunning "ntp"
 
 		& alias "ancient.kitenet.net"
 		& Docker.docked hosts "ancient-kitenet"

doc/README.mdwn

@@ -6,7 +6,8 @@ are satisfied.
 Propellor is configured via a git repository, which typically lives
 in `~/.propellor/` on your development machine. Propellor clones the
 repository to each host it manages, in a 
-[secure](http://propellor.branchable.com/security/) way.
+[secure](http://propellor.branchable.com/security/) way. The git repository
+contains the full source code to Propellor, along with its config file.
 
 Properties are defined using Haskell. Edit `~/.propellor/config.hs`
 to get started. There is fairly complete 
@@ -40,11 +41,12 @@ see [configuration for the Haskell newbie](https://propellor.branchable.com/hask
      `apt-get install propellor`
 2. Run propellor for the first time. It will set up a `~/.propellor/` git
    repository for you.
-3. `cd ~/.propellor/`; use git to push the repository to a central
+3. If you don't have a gpg private key already, generate one: `gpg --gen-key`
+4. Run: `propellor --add-key $KEYID`, which will make propellor trust
+   your gpg key, and will sign your `~/.propellor` repository using it.
+5. `cd ~/.propellor/`; use git to push the repository to a central
    server (github, or your own git server). Configure that central
    server as the origin remote of the repository.
-4. If you don't have a gpg private key, generate one: `gpg --gen-key`
-5. Run: `propellor --add-key $KEYID`
 6. Edit `~/.propellor/config.hs`, and add a host you want to manage.
    You can start by not adding any properties, or only a few.
 7. Pick a host and run: `propellor --spin $HOST`

doc/todo/docker_todo_list.mdwn

@@ -6,8 +6,3 @@
   need ntp installed for a good date source.
 * Docking a container in a host should add to the host any cnames that
   are assigned to the container.
-* It seems that provisionContainer sometimes hangs when the container
-  is already running. This seems likely to be a problem with the simpleSh
-  socket hack. (I think this was an uncaught exception crashing the
-  simpleSh server thread, and if so, it's fixed. Waiting some weeks to see,
-  as this bug rarely occurred..)

propellor.cabal

@@ -33,9 +33,10 @@ Description:
  .
  It is configured using haskell.
 
-Executable propellor
+Executable wrapper
   Main-Is: wrapper.hs
   GHC-Options: -Wall -threaded
+  Hs-Source-Dirs:  src
   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, 
    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
    containers, network, async, time, QuickCheck, mtl,
@@ -47,6 +48,7 @@ Executable propellor
 Executable config
   Main-Is: config.hs
   GHC-Options: -Wall -threaded
+  Hs-Source-Dirs:  src
   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, 
    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
    containers, network, async, time, QuickCheck, mtl,
@@ -57,6 +59,7 @@ Executable config
 
 Library
   GHC-Options: -Wall
+  Hs-Source-Dirs:  src
   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, 
    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
    containers, network, async, time, QuickCheck, mtl,

src/Propellor/CmdLine.hs

@@ -290,17 +290,26 @@ boot attr ps = do
 	mainProperties attr ps
 
 addKey :: String -> IO ()
-addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]
+addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitconfig, gitcommit ]
   where
-	gpg = boolSystem "sh"
-		[ Param "-c"
-		, Param $ "gpg --export " ++ keyid ++ " | gpg " ++
-			unwords (gpgopts ++ ["--import"])
-		]
+	gpg = do
+		createDirectoryIfMissing True privDataDir
+		boolSystem "sh"
+			[ Param "-c"
+			, Param $ "gpg --export " ++ keyid ++ " | gpg " ++
+				unwords (gpgopts ++ ["--import"])
+			]
 	gitadd = boolSystem "git"
 		[ Param "add"
 		, File keyring
 		]
+
+	gitconfig = boolSystem "git"
+		[ Param "config"
+		, Param "user.signingkey"
+		, Param keyid
+		]
+
 	gitcommit = gitCommit
 		[ File keyring
 		, Param "-m"
@@ -340,11 +349,11 @@ checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
   where
 	go (Just s)
 		| s == "1" = do
-			f <- setFormatter
-				<$> streamHandler stderr DEBUG
-				<*> pure (simpleLogFormatter "[$time] $msg")
-			updateGlobalLogger rootLoggerName $ 
-				setLevel DEBUG .  setHandlers [f]
+		f <- setFormatter
+			<$> streamHandler stderr DEBUG
+			<*> pure (simpleLogFormatter "[$time] $msg")
+		updateGlobalLogger rootLoggerName $ 
+			setLevel DEBUG .  setHandlers [f]
 	go _ = noop
 
 -- Parameters can be passed to both ssh and scp, to enable a ssh connection

src/Propellor/Property/Docker.hs

@@ -335,29 +335,19 @@ provisionContainer cid = containerDesc cid $ property "provision" $ liftIO $ do
 
 	go lastline (v:rest) = case v of
 		StdoutLine s -> do
-			debug ["stdout: ", show s]
 			maybe noop putStrLn lastline
 			hFlush stdout
 			go (Just s) rest
 		StderrLine s -> do
-			debug ["stderr: ", show s]
 			maybe noop putStrLn lastline
 			hFlush stdout
 			hPutStrLn stderr s
 			hFlush stderr
 			go Nothing rest
-		Done -> do
-			debug ["reached Done"]
-			ret lastline
-	go lastline [] = do
-		debug ["reached end of output"]
-		ret lastline
+		Done -> ret lastline
+	go lastline [] = ret lastline
 
-	ret lastline = do
-		let v = fromMaybe FailedChange $
-			readish =<< lastline
-		debug ["provisionContainer returning", show v]
-		return v
+	ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline
 
 stopContainer :: ContainerId -> IO Bool
 stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]

src/Propellor/SimpleSh.hs

@@ -6,7 +6,7 @@
 module Propellor.SimpleSh where
 
 import Network.Socket
-import Control.Concurrent.Chan
+import Control.Concurrent
 import Control.Concurrent.Async
 import System.Process (std_in, std_out, std_err)
 
@@ -31,8 +31,9 @@ simpleSh namedpipe = do
 	listen s 2
 	forever $ do
 		(client, _addr) <- accept s
-		h <- socketToHandle client ReadWriteMode
-		maybe noop (run h) . readish =<< hGetLine h
+		forkIO $ do
+			h <- socketToHandle client ReadWriteMode
+			maybe noop (run h) . readish =<< hGetLine h
   where
 	run h (Cmd cmd params) = do
 		chan <- newChan
@@ -71,16 +72,13 @@ simpleSh namedpipe = do
 
 simpleShClient :: FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a
 simpleShClient namedpipe cmd params handler = do
-	debug ["simplesh connecting"]
 	s <- socket AF_UNIX Stream defaultProtocol
 	connect s (SockAddrUnix namedpipe)
 	h <- socketToHandle s ReadWriteMode
 	hPutStrLn h $ show $ Cmd cmd params
 	hFlush h
-	debug ["simplesh sent command"]
 	resps <- catMaybes . map readish . lines <$> hGetContents h
 	v <- hClose h `after` handler resps
-	debug ["simplesh processed response"]
 	return v
 
 simpleShClientRetry :: Int -> FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a

src/config.hs

@@ -0,0 +1 @@
+../config.hs