module Propellor.CmdLine (
	defaultMain,
	processCmdLine,
) where

import System.Environment (getArgs)
import Data.List
import System.Exit
import System.Posix.User
import Network.Socket

import Propellor.Base
import Propellor.Gpg
import Propellor.Git
import Propellor.Git.VerifiedBranch
import Propellor.Bootstrap
import Propellor.Spin
import Propellor.Types.CmdLine
import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Shim as Shim
import Utility.FileSystemEncoding

usage :: Handle -> IO ()
usage :: Handle -> IO ()
usage Handle
h = Handle -> String -> IO ()
hPutStrLn Handle
h forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
	[ String
"Usage:"
	, String
"  with no arguments, provision the current host"
	, String
""
	, String
"  --init"
	, String
"      initialize ~/.propellor"
	, String
"  hostname"
	, String
"      provision the current host as if it had the specified hostname"
	, String
"  --spin targethost [--via relayhost]"
	, String
"      provision the specified host"
	, String
"  --build"
	, String
"      recompile using your current config"
	, String
"  --add-key keyid"
	, String
"      add an additional signing key to the private data"
	, String
"  --rm-key keyid"
	, String
"      remove a signing key from the private data"
	, String
"  --list-fields"
	, String
"      list private data fields"
	, String
"  --set field context"
	, String
"      set a private data field"
	, String
"  --unset field context"
	, String
"      clear a private data field"
	, String
"  --unset-unused"
	, String
"      clear unused fields from the private data"
	, String
"  --dump field context"
	, String
"      show the content of a private data field"
	, String
"  --edit field context"
	, String
"      edit the content of a private data field"
	, String
"  --merge"
	, String
"      combine multiple spins into a single git commit"
	, String
"  --check"
	, String
"      double-check that propellor can actually run here"]

usageError :: [String] -> IO a
usageError :: forall a. [String] -> IO a
usageError [String]
ps = do
	Handle -> IO ()
usage Handle
stderr
	forall a. HasCallStack => String -> a
error (String
"(Unexpected: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [String]
ps)

processCmdLine :: IO CmdLine
processCmdLine :: IO CmdLine
processCmdLine = [String] -> IO CmdLine
go forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String]
getArgs
  where
	go :: [String] -> IO CmdLine
go (String
"--check":[String]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return CmdLine
Check
	go (String
"--spin":[String]
ps) = case forall a. [a] -> [a]
reverse [String]
ps of
		(String
r:String
"--via":[String]
hs) -> [String] -> Maybe String -> CmdLine
Spin
			forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO String
hostname (forall a. [a] -> [a]
reverse [String]
hs)
			forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just String
r)
		[String]
_ -> [String] -> Maybe String -> CmdLine
Spin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO String
hostname [String]
ps forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
	go (String
"--build":[]) = forall (m :: * -> *) a. Monad m => a -> m a
return CmdLine
Build
	go (String
"--add-key":String
k:[]) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> CmdLine
AddKey String
k
	go (String
"--rm-key":String
k:[]) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> CmdLine
RmKey String
k
	go (String
"--set":String
f:String
c:[]) = forall {t} {m :: * -> *} {a}.
(Read t, MonadIO m) =>
String -> String -> (t -> Context -> a) -> m a
withprivfield String
f String
c PrivDataField -> Context -> CmdLine
Set
	go (String
"--unset":String
f:String
c:[]) = forall {t} {m :: * -> *} {a}.
(Read t, MonadIO m) =>
String -> String -> (t -> Context -> a) -> m a
withprivfield String
f String
c PrivDataField -> Context -> CmdLine
Unset
	go (String
"--unset-unused":[]) = forall (m :: * -> *) a. Monad m => a -> m a
return CmdLine
UnsetUnused
	go (String
"--dump":String
f:String
c:[]) = forall {t} {m :: * -> *} {a}.
(Read t, MonadIO m) =>
String -> String -> (t -> Context -> a) -> m a
withprivfield String
f String
c PrivDataField -> Context -> CmdLine
Dump
	go (String
"--edit":String
f:String
c:[]) = forall {t} {m :: * -> *} {a}.
(Read t, MonadIO m) =>
String -> String -> (t -> Context -> a) -> m a
withprivfield String
f String
c PrivDataField -> Context -> CmdLine
Edit
	go (String
"--list-fields":[]) = forall (m :: * -> *) a. Monad m => a -> m a
return CmdLine
ListFields
	go (String
"--merge":[]) = forall (m :: * -> *) a. Monad m => a -> m a
return CmdLine
Merge
	go (String
"--help":[String]
_) = do
		Handle -> IO ()
usage Handle
stdout
		forall a. IO a
exitFailure
	go (String
"--boot":String
_:[]) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe String -> CmdLine
Update forall a. Maybe a
Nothing -- for back-compat
	go (String
"--serialized":String
s:[]) = forall {t} {m :: * -> *} {a}.
(Read t, MonadIO m) =>
(t -> a) -> String -> m a
serialized CmdLine -> CmdLine
Serialized String
s
	go (String
"--continue":String
s:[]) = forall {t} {m :: * -> *} {a}.
(Read t, MonadIO m) =>
(t -> a) -> String -> m a
serialized CmdLine -> CmdLine
Continue String
s
	go (String
"--gitpush":String
fin:String
fout:[String]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Fd -> Fd -> CmdLine
GitPush (forall a. Read a => String -> a
Prelude.read String
fin) (forall a. Read a => String -> a
Prelude.read String
fout)
	go (String
"--run":String
h:[]) = [String] -> IO CmdLine
go [String
h]
	go (String
h:[])
		| String
"--" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
h = forall a. [String] -> IO a
usageError [String
h]
		| Bool
otherwise = String -> CmdLine
Run forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
hostname String
h
	go [] = do
		String
s <- forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\n') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
readProcess String
"hostname" [String
"-f"]
		if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s
			then forall (m :: * -> *) a. MonadIO m => String -> m a
errorMessage String
"Cannot determine hostname! Pass it on the command line."
			else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> CmdLine
Run String
s
	go [String]
v = forall a. [String] -> IO a
usageError [String]
v

	withprivfield :: String -> String -> (t -> Context -> a) -> m a
withprivfield String
s String
c t -> Context -> a
f = case forall a. Read a => String -> Maybe a
readish String
s of
		Just t
pf -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ t -> Context -> a
f t
pf (String -> Context
Context String
c)
		Maybe t
Nothing -> forall (m :: * -> *) a. MonadIO m => String -> m a
errorMessage forall a b. (a -> b) -> a -> b
$ String
"Unknown privdata field " forall a. [a] -> [a] -> [a]
++ String
s

	serialized :: (t -> a) -> String -> m a
serialized t -> a
mk String
s = case forall a. Read a => String -> Maybe a
readish String
s of
		Just t
cmdline -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ t -> a
mk t
cmdline
		Maybe t
Nothing -> forall (m :: * -> *) a. MonadIO m => String -> m a
errorMessage forall a b. (a -> b) -> a -> b
$ String
"serialization failure (" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
")"

data CanRebuild = CanRebuild | NoRebuild

-- | Runs propellor on hosts, as controlled by command-line options.
defaultMain :: [Host] -> IO ()
defaultMain :: [Host] -> IO ()
defaultMain [Host]
hostlist = forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
withConcurrentOutput forall a b. (a -> b) -> a -> b
$ do
	IO ()
useFileSystemEncoding
	IO ()
setupGpgEnv
	IO ()
Shim.cleanEnv
	IO ()
checkDebugMode
	CmdLine
cmdline <- IO CmdLine
processCmdLine
	[String] -> IO ()
debug [String
"command line: ", forall a. Show a => a -> String
show CmdLine
cmdline]
	CanRebuild -> CmdLine -> IO ()
go CanRebuild
CanRebuild CmdLine
cmdline
  where
	go :: CanRebuild -> CmdLine -> IO ()
go CanRebuild
cr (Serialized CmdLine
cmdline) = CanRebuild -> CmdLine -> IO ()
go CanRebuild
cr CmdLine
cmdline
	go CanRebuild
_ CmdLine
Check = forall (m :: * -> *) a. Monad m => a -> m a
return ()
	go CanRebuild
cr CmdLine
Build = Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
buildFirst forall a. Maybe a
Nothing CanRebuild
cr CmdLine
Build forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
	go CanRebuild
_ (Set PrivDataField
field Context
context) = PrivDataField -> Context -> IO ()
setPrivData PrivDataField
field Context
context
	go CanRebuild
_ (Unset PrivDataField
field Context
context) = PrivDataField -> Context -> IO ()
unsetPrivData PrivDataField
field Context
context
	go CanRebuild
_ (CmdLine
UnsetUnused) = [Host] -> IO ()
unsetPrivDataUnused [Host]
hostlist
	go CanRebuild
_ (Dump PrivDataField
field Context
context) = PrivDataField -> Context -> IO ()
dumpPrivData PrivDataField
field Context
context
	go CanRebuild
_ (Edit PrivDataField
field Context
context) = PrivDataField -> Context -> IO ()
editPrivData PrivDataField
field Context
context
	go CanRebuild
_ CmdLine
ListFields = [Host] -> IO ()
listPrivDataFields [Host]
hostlist
	go CanRebuild
_ (AddKey String
keyid) = String -> IO ()
addKey String
keyid
	go CanRebuild
_ (RmKey String
keyid) = String -> IO ()
rmKey String
keyid
	go CanRebuild
_ c :: CmdLine
c@(ChrootChain String
_ String
_ Bool
_ Bool
_ [ContainerCapability]
_) = [Host] -> CmdLine -> IO ()
Chroot.chain [Host]
hostlist CmdLine
c
	go CanRebuild
_ (DockerChain String
hn String
cid) = [Host] -> String -> String -> IO ()
Docker.chain [Host]
hostlist String
hn String
cid
	go CanRebuild
_ (DockerInit String
hn) = String -> IO ()
Docker.init String
hn
	go CanRebuild
_ (GitPush Fd
fin Fd
fout) = Fd -> Fd -> IO ()
gitPushHelper Fd
fin Fd
fout
	go CanRebuild
cr (Relay String
h) = IO ()
forceConsole forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
		Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
updateFirst forall a. Maybe a
Nothing CanRebuild
cr (Maybe String -> CmdLine
Update (forall a. a -> Maybe a
Just String
h)) (Maybe String -> IO ()
update (forall a. a -> Maybe a
Just String
h))
	go CanRebuild
_ (Update Maybe String
Nothing) = IO ()
forceConsole forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
		IO () -> IO ()
fetchFirst (forall {a}. IO a -> IO a
onlyprocess (Maybe String -> IO ()
update forall a. Maybe a
Nothing))
	go CanRebuild
_ (Update (Just String
h)) = Maybe String -> IO ()
update (forall a. a -> Maybe a
Just String
h)
	go CanRebuild
_ CmdLine
Merge = IO ()
mergeSpin
	go CanRebuild
cr cmdline :: CmdLine
cmdline@(Spin [String]
hs Maybe String
mrelay) = Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
buildFirst forall a. Maybe a
Nothing CanRebuild
cr CmdLine
cmdline forall a b. (a -> b) -> a -> b
$ do
		forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Maybe a -> Bool
isJust Maybe String
mrelay) IO ()
commitSpin
		forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
hs forall a b. (a -> b) -> a -> b
$ \String
hn -> String -> (Host -> IO ()) -> IO ()
withhost String
hn forall a b. (a -> b) -> a -> b
$ Maybe String -> String -> Host -> IO ()
spin Maybe String
mrelay String
hn
	go CanRebuild
cr cmdline :: CmdLine
cmdline@(Run String
hn) = forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (forall a. Eq a => a -> a -> Bool
(==) UserID
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UserID
getRealUserID)
		( Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
updateFirst ([Host] -> String -> Maybe Host
findHost [Host]
hostlist String
hn) CanRebuild
cr CmdLine
cmdline forall a b. (a -> b) -> a -> b
$ String -> IO ()
runhost String
hn
		, IO () -> IO ()
fetchFirst forall a b. (a -> b) -> a -> b
$ CanRebuild -> CmdLine -> IO ()
go CanRebuild
cr ([String] -> Maybe String -> CmdLine
Spin [String
hn] forall a. Maybe a
Nothing)
		)
	go CanRebuild
cr cmdline :: CmdLine
cmdline@(SimpleRun String
hn) = IO ()
forceConsole forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
		IO () -> IO ()
fetchFirst (Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
buildFirst ([Host] -> String -> Maybe Host
findHost [Host]
hostlist String
hn) CanRebuild
cr CmdLine
cmdline (String -> IO ()
runhost String
hn))
	-- When continuing after a rebuild, don't want to rebuild again.
	go CanRebuild
_ (Continue CmdLine
cmdline) = CanRebuild -> CmdLine -> IO ()
go CanRebuild
NoRebuild CmdLine
cmdline

	withhost :: HostName -> (Host -> IO ()) -> IO ()
	withhost :: String -> (Host -> IO ()) -> IO ()
withhost String
hn Host -> IO ()
a = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. String -> [Host] -> IO a
unknownhost String
hn [Host]
hostlist) Host -> IO ()
a ([Host] -> String -> Maybe Host
findHost [Host]
hostlist String
hn)

	runhost :: String -> IO ()
runhost String
hn = forall {a}. IO a -> IO a
onlyprocess forall a b. (a -> b) -> a -> b
$ String -> (Host -> IO ()) -> IO ()
withhost String
hn Host -> IO ()
mainProperties

	onlyprocess :: IO a -> IO a
onlyprocess = forall a. String -> IO a -> IO a
onlyProcess (String
localdir String -> String -> String
</> String
".lock")

unknownhost :: HostName -> [Host] -> IO a
unknownhost :: forall a. String -> [Host] -> IO a
unknownhost String
h [Host]
hosts = forall (m :: * -> *) a. MonadIO m => String -> m a
errorMessage forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
	[ String
"Propellor does not know about host: " forall a. [a] -> [a] -> [a]
++ String
h
	, String
"(Perhaps you should specify the real hostname on the command line?)"
	, String
"(Or, edit propellor's config.hs to configure this host)"
	, String
"Known hosts: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (forall a b. (a -> b) -> [a] -> [b]
map Host -> String
hostName [Host]
hosts)
	]

-- Builds propellor (when allowed) and if it looks like a new binary,
-- re-execs it to continue.
-- Otherwise, runs the IO action to continue.
--
-- The Host should only be provided when dependencies should be installed
-- as needed to build propellor.
buildFirst :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
buildFirst :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
buildFirst Maybe Host
h CanRebuild
CanRebuild CmdLine
cmdline IO ()
next = do
	Maybe UTCTime
oldtime <- IO (Maybe UTCTime)
getmtime
	Maybe Host -> IO ()
buildPropellor Maybe Host
h
	Maybe UTCTime
newtime <- IO (Maybe UTCTime)
getmtime
	if Maybe UTCTime
newtime forall a. Eq a => a -> a -> Bool
== Maybe UTCTime
oldtime
		then IO ()
next
		else forall a. CmdLine -> IO a
continueAfterBuild CmdLine
cmdline
  where
	getmtime :: IO (Maybe UTCTime)
getmtime = forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO forall a b. (a -> b) -> a -> b
$ String -> IO UTCTime
getModificationTime String
"propellor"
buildFirst Maybe Host
_ CanRebuild
NoRebuild CmdLine
_ IO ()
next = IO ()
next

continueAfterBuild :: CmdLine -> IO a
continueAfterBuild :: forall a. CmdLine -> IO a
continueAfterBuild CmdLine
cmdline = forall {a}. Bool -> IO a
go forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> [CommandParam] -> IO Bool
boolSystem String
"./propellor"
	[ String -> CommandParam
Param String
"--continue"
	, String -> CommandParam
Param (forall a. Show a => a -> String
show CmdLine
cmdline)
	]
  where
	go :: Bool -> IO a
go Bool
True = forall a. IO a
exitSuccess
	go Bool
False = forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)

fetchFirst :: IO () -> IO ()
fetchFirst :: IO () -> IO ()
fetchFirst IO ()
next = do
	forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
hasOrigin forall a b. (a -> b) -> a -> b
$
		forall (f :: * -> *) a. Functor f => f a -> f ()
void IO Bool
fetchOrigin
	IO ()
next

updateFirst :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
updateFirst :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
updateFirst Maybe Host
h CanRebuild
canrebuild CmdLine
cmdline IO ()
next = forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM IO Bool
hasOrigin
	( Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
updateFirst' Maybe Host
h CanRebuild
canrebuild CmdLine
cmdline IO ()
next
	, IO ()
next
	)

-- If changes can be fetched from origin, builds propellor (when allowed)
-- and re-execs the updated propellor binary to continue.
-- Otherwise, runs the IO action to continue.
updateFirst' :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
updateFirst' :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
updateFirst' Maybe Host
h CanRebuild
CanRebuild CmdLine
cmdline IO ()
next = forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM IO Bool
fetchOrigin
	( do
		Maybe Host -> IO ()
buildPropellor Maybe Host
h
		forall a. CmdLine -> IO a
continueAfterBuild CmdLine
cmdline
	, IO ()
next
	)
updateFirst' Maybe Host
_ CanRebuild
NoRebuild CmdLine
_ IO ()
next = IO ()
next

-- Gets the fully qualified domain name, given a string that might be
-- a short name to look up in the DNS.
hostname :: String -> IO HostName
hostname :: String -> IO String
hostname String
s = forall {f :: * -> *}. Applicative f => [AddrInfo] -> f String
go forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO [] IO [AddrInfo]
dnslookup
  where
	dnslookup :: IO [AddrInfo]
dnslookup = Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (forall a. a -> Maybe a
Just AddrInfo
canonname) (forall a. a -> Maybe a
Just String
s) forall a. Maybe a
Nothing
	canonname :: AddrInfo
canonname = AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_CANONNAME] }
	go :: [AddrInfo] -> f String
go (AddrInfo { addrCanonName :: AddrInfo -> Maybe String
addrCanonName = Just String
v } : [AddrInfo]
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure String
v
	go [AddrInfo]
_
		| String
"." forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
s = forall (f :: * -> *) a. Applicative f => a -> f a
pure String
s -- assume it's a fqdn
		| Bool
otherwise =
			forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"cannot find host " forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
" in the DNS"