moved source code to src

This is to work around OSX's brain-damange regarding filename case
insensitivity.

Avoided moving config.hs, because it's a config file. Put in a symlink to
make build work.

1 files changed, 0 insertions, 392 deletions

diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs
deleted file mode 100644
index ab1d7f9e..00000000
--- a/Propellor/CmdLine.hs
+++ /dev/null
@@ -1,392 +0,0 @@
-module Propellor.CmdLine where
-
-import System.Environment (getArgs)
-import Data.List
-import System.Exit
-import System.Log.Logger
-import System.Log.Formatter
-import System.Log.Handler (setFormatter, LogHandler)
-import System.Log.Handler.Simple
-import System.PosixCompat
-import Control.Exception (bracket)
-import System.Posix.IO
-import Data.Time.Clock.POSIX
-
-import Propellor
-import qualified Propellor.Property.Docker as Docker
-import qualified Propellor.Property.Docker.Shim as DockerShim
-import Utility.FileMode
-import Utility.SafeCommand
-import Utility.UserInfo
-
-usage :: IO a
-usage = do
-	putStrLn $ unlines 
-		[ "Usage:"
-		, "  propellor"
-		, "  propellor hostname"
-		, "  propellor --spin hostname"
-		, "  propellor --set hostname field"
-		, "  propellor --add-key keyid"
-		]
-	exitFailure
-
-processCmdLine :: IO CmdLine
-processCmdLine = go =<< getArgs
-  where
-  	go ("--help":_) = usage
-  	go ("--spin":h:[]) = return $ Spin h
-  	go ("--boot":h:[]) = return $ Boot h
-	go ("--add-key":k:[]) = return $ AddKey k
-	go ("--set":h:f:[]) = case readish f of
-		Just pf -> return $ Set h pf
-		Nothing -> errorMessage $ "Unknown privdata field " ++ f
-	go ("--continue":s:[]) = case readish s of
-		Just cmdline -> return $ Continue cmdline
-		Nothing -> errorMessage "--continue serialization failure"
-  	go ("--chain":h:[]) = return $ Chain h
-	go ("--docker":h:[]) = return $ Docker h
-	go (h:[])
-		| "--" `isPrefixOf` h = usage
-		| otherwise = return $ Run h
-	go [] = do
-		s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
-		if null s
-			then errorMessage "Cannot determine hostname! Pass it on the command line."
-			else return $ Run s
-	go _ = usage
-
-defaultMain :: [Host] -> IO ()
-defaultMain hostlist = do
-	DockerShim.cleanEnv
-	checkDebugMode
-	cmdline <- processCmdLine
-	debug ["command line: ", show cmdline]
-	go True cmdline
-  where
-	go _ (Continue cmdline) = go False cmdline
-	go _ (Set hn field) = setPrivData hn field
-	go _ (AddKey keyid) = addKey keyid
-	go _ (Chain hn) = withprops hn $ \attr ps -> do
-		r <- runPropellor attr $ ensureProperties ps
-		putStrLn $ "\n" ++ show r
-	go _ (Docker hn) = Docker.chain hn
-	go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
-	go True cmdline = updateFirst cmdline $ go False cmdline
-	go False (Spin hn) = withprops hn $ const . const $ spin hn
-	go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
-		( onlyProcess $ withprops hn mainProperties
-		, go True (Spin hn)
-		)
-	go False (Boot hn) = onlyProcess $ withprops hn boot
-
-	withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO ()
-	withprops hn a = maybe
-		(unknownhost hn)
-		(\h -> a (hostAttr h) (hostProperties h))
-		(findHost hostlist hn)
-
-onlyProcess :: IO a -> IO a
-onlyProcess a = bracket lock unlock (const a)
-  where
-	lock = do
-		l <- createFile lockfile stdFileMode
-		setLock l (WriteLock, AbsoluteSeek, 0, 0)
-			`catchIO` const alreadyrunning
-		return l
-	unlock = closeFd
-	alreadyrunning = error "Propellor is already running on this host!"
-	lockfile = localdir </> ".lock"
-
-unknownhost :: HostName -> IO a
-unknownhost h = errorMessage $ unlines
-	[ "Propellor does not know about host: " ++ h
-	, "(Perhaps you should specify the real hostname on the command line?)"
-	, "(Or, edit propellor's config.hs to configure this host)"
-	]
-
-buildFirst :: CmdLine -> IO () -> IO ()
-buildFirst cmdline next = do
-	oldtime <- getmtime
-	ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
-		( do
-			newtime <- getmtime
-			if newtime == oldtime
-				then next
-				else void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
-		, errorMessage "Propellor build failed!" 
-		)
-  where
-	getmtime = catchMaybeIO $ getModificationTime "propellor"
-
-getCurrentBranch :: IO String
-getCurrentBranch = takeWhile (/= '\n') 
-	<$> readProcess "git" ["symbolic-ref", "--short", "HEAD"]
-
-updateFirst :: CmdLine -> IO () -> IO ()
-updateFirst cmdline next = do
-	branchref <- getCurrentBranch
-	let originbranch = "origin" </> branchref
-
-	void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"]
-	
-	whenM (doesFileExist keyring) $ do
-		{- To verify origin branch commit's signature, have to
-		 - convince gpg to use our keyring. While running git log.
-		 - Which has no way to pass options to gpg.
-		 - Argh! -}
-		let gpgconf = privDataDir </> "gpg.conf"
-		writeFile gpgconf $ unlines
-			[ " keyring " ++ keyring
-			, "no-auto-check-trustdb"
-			]
-		-- gpg is picky about perms
-		modifyFileMode privDataDir (removeModes otherGroupModes)
-		s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch]
-			(Just [("GNUPGHOME", privDataDir)])
-		nukeFile $ privDataDir </> "trustdb.gpg"
-		nukeFile $ privDataDir </> "pubring.gpg"
-		nukeFile $ privDataDir </> "gpg.conf"
-		if s == "U\n" || s == "G\n"
-			then do
-				putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"
-				hFlush stdout
-			else errorMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it!"
-	
-	oldsha <- getCurrentGitSha1 branchref
-	void $ boolSystem "git" [Param "merge", Param originbranch]
-	newsha <- getCurrentGitSha1 branchref
-
-	if oldsha == newsha
-		then next
-		else ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
-			( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
-			, errorMessage "Propellor build failed!" 
-			)
-
-getCurrentGitSha1 :: String -> IO String
-getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]
-
-spin :: HostName -> IO ()
-spin hn = do
-	url <- getUrl
-	void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
-	void $ boolSystem "git" [Param "push"]
-	cacheparams <- toCommand <$> sshCachingParams hn
-	go cacheparams url =<< gpgDecrypt (privDataFile hn)
-  where
-	go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do
-		let finish = do
-			senddata toh (privDataFile hn) privDataMarker privdata
-			hClose toh
-			
-			-- Display remaining output.
-			void $ tryIO $ forever $
-				showremote =<< hGetLine fromh
-			hClose fromh
-		status <- getstatus fromh `catchIO` (const $ errorMessage "protocol error (perhaps the remote propellor failed to run?)")
-		case status of
-			Ready -> finish
-			NeedGitClone -> do
-				hClose toh
-				hClose fromh
-				sendGitClone hn url
-				go cacheparams url privdata
-	
-	user = "root@"++hn
-
-	bootstrapcmd = shellWrap $ intercalate " ; "
-		[ "if [ ! -d " ++ localdir ++ " ]"
-		, "then " ++ intercalate " && "
-			[ "apt-get --no-install-recommends --no-upgrade -y install git make"
-			, "echo " ++ toMarked statusMarker (show NeedGitClone)
-			]
-		, "else " ++ intercalate " && "
-			[ "cd " ++ localdir
-			, "if ! test -x ./propellor; then make deps build; fi"
-			, "./propellor --boot " ++ hn
-			]
-		, "fi"
-		]
-
-	getstatus :: Handle -> IO BootStrapStatus
-	getstatus h = do
-		l <- hGetLine h
-		case readish =<< fromMarked statusMarker l of
-			Nothing -> do
-				showremote l
-				getstatus h
-			Just status -> return status
-	
-	showremote s = putStrLn s
-	senddata toh f marker s = void $
-		actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do
-			sendMarked toh marker s
-			return True
-
-sendGitClone :: HostName -> String -> IO ()
-sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
-	branch <- getCurrentBranch
-	cacheparams <- sshCachingParams hn
-	withTmpFile "propellor.git" $ \tmp _ -> allM id
-		[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
-		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
-		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
-		]
-  where
-	remotebundle = "/usr/local/propellor.git"
-	unpackcmd branch = shellWrap $ intercalate " && "
-		[ "git clone " ++ remotebundle ++ " " ++ localdir
-		, "cd " ++ localdir
-		, "git checkout -b " ++ branch
-		, "git remote rm origin"
-		, "rm -f " ++ remotebundle
-		, "git remote add origin " ++ url
-		-- same as --set-upstream-to, except origin branch
-		-- has not been pulled yet
-		, "git config branch."++branch++".remote origin"
-		, "git config branch."++branch++".merge refs/heads/"++branch
-		]
-
-data BootStrapStatus = Ready | NeedGitClone
-	deriving (Read, Show, Eq)
-
-type Marker = String
-type Marked = String
-
-statusMarker :: Marker
-statusMarker = "STATUS"
-
-privDataMarker :: String
-privDataMarker = "PRIVDATA "
-
-toMarked :: Marker -> String -> String
-toMarked marker = intercalate "\n" . map (marker ++) . lines
-
-sendMarked :: Handle -> Marker -> String -> IO ()
-sendMarked h marker s = do
-	-- Prefix string with newline because sometimes a
-	-- incomplete line is output.
-	hPutStrLn h ("\n" ++ toMarked marker s)
-	hFlush h
-
-fromMarked :: Marker -> Marked -> Maybe String
-fromMarked marker s
-	| null matches = Nothing
-	| otherwise = Just $ intercalate "\n" $
-		map (drop len) matches
-  where
-	len = length marker
-	matches = filter (marker `isPrefixOf`) $ lines s
-
-boot :: Attr -> [Property] -> IO ()
-boot attr ps = do
-	sendMarked stdout statusMarker $ show Ready
-	reply <- hGetContentsStrict stdin
-
-	makePrivDataDir
-	maybe noop (writeFileProtected privDataLocal) $
-		fromMarked privDataMarker reply
-	mainProperties attr ps
-
-addKey :: String -> IO ()
-addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitconfig, gitcommit ]
-  where
-	gpg = do
-		createDirectoryIfMissing True privDataDir
-		boolSystem "sh"
-			[ Param "-c"
-			, Param $ "gpg --export " ++ keyid ++ " | gpg " ++
-				unwords (gpgopts ++ ["--import"])
-			]
-	gitadd = boolSystem "git"
-		[ Param "add"
-		, File keyring
-		]
-
-	gitconfig = boolSystem "git"
-		[ Param "config"
-		, Param "user.signingkey"
-		, Param keyid
-		]
-
-	gitcommit = gitCommit
-		[ File keyring
-		, Param "-m"
-		, Param "propellor addkey"
-		]
-
-{- Automatically sign the commit if there'a a keyring. -}
-gitCommit :: [CommandParam] -> IO Bool
-gitCommit ps = do
-	k <- doesFileExist keyring
-	boolSystem "git" $ catMaybes $
-		[ Just (Param "commit")
-		, if k then Just (Param "--gpg-sign") else Nothing
-		] ++ map Just ps
-
-keyring :: FilePath
-keyring = privDataDir </> "keyring.gpg"
-
-gpgopts :: [String]
-gpgopts = ["--options", "/dev/null", "--no-default-keyring", "--keyring", keyring]
-
-getUrl :: IO String
-getUrl = maybe nourl return =<< getM get urls
-  where
-	urls = ["remote.deploy.url", "remote.origin.url"]
-	nourl = errorMessage $ "Cannot find deploy url in " ++ show urls
-	get u = do
-		v <- catchMaybeIO $ 
-			takeWhile (/= '\n') 
-				<$> readProcess "git" ["config", u]
-		return $ case v of
-			Just url | not (null url) -> Just url
-			_ -> Nothing
-
-checkDebugMode :: IO ()
-checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
-  where
-	go (Just s)
-		| s == "1" = do
-		f <- setFormatter
-			<$> streamHandler stderr DEBUG
-			<*> pure (simpleLogFormatter "[$time] $msg")
-		updateGlobalLogger rootLoggerName $ 
-			setLevel DEBUG .  setHandlers [f]
-	go _ = noop
-
--- Parameters can be passed to both ssh and scp, to enable a ssh connection
--- caching socket.
---
--- If the socket already exists, check if its mtime is older than 10
--- minutes, and if so stop that ssh process, in order to not try to
--- use an old stale connection. (atime would be nicer, but there's
--- a good chance a laptop uses noatime)
-sshCachingParams :: HostName -> IO [CommandParam]
-sshCachingParams hn = do
-	home <- myHomeDir
-	let cachedir = home </> ".ssh" </> "propellor"
-	createDirectoryIfMissing False cachedir
-	let socketfile = cachedir </> hn ++ ".sock"
-	let ps = 
-		[ Param "-o", Param ("ControlPath=" ++ socketfile)
-		, Params "-o ControlMaster=auto -o ControlPersist=yes"
-		]
-
-	maybe noop (expireold ps socketfile)
-		=<< catchMaybeIO (getFileStatus socketfile)
-	
-	return ps
-		
-  where
-	expireold ps f s = do
-		now <- truncate <$> getPOSIXTime :: IO Integer
-		if modificationTime s > fromIntegral now - tenminutes
-			then touchFile f
-			else do
-				void $ boolSystem "ssh" $
-					[ Params "-O stop" ] ++ ps ++
-					[ Param "localhost" ]
-				nukeFile f
-	tenminutes = 600