{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} import Control.Applicative import Control.DeepSeq import Data.Bool import Data.Char import Data.List import Data.Maybe import Data.Monoid import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Char8 as S8 import qualified Kiki import System.Directory import System.FilePath.Posix (takeDirectory) import System.Environment import System.Exit import System.IO import System.Posix.User import CommandLine import Data.OpenPGP (SymmetricAlgorithm(Unencrypted)) import qualified Hosts usage = unlines [ "cokiki [--chroot=ROOTDIR]" , " [--homedir=HOMEDIR]" , " [--passphrase-fd=FD]" , "" , "cokiki modifies system configuration to recognize generated files" , "in /var/cache/kiki. In addition to each command's documented effects" , "(see COMMANDS), the following operation will be performed on your" , "GnuPG keyring:" , "" , " master-key (generated if not present)" , " tor (generated if not prsenet)" , " ipsec (generated if not prsenet)" , " ssh-server (imported or generated if not present)" , " ssh-client (imported or gnnerated if not present)" , "" , "The /var/cache/kiki/* tree will also be refreshed." , "" , "COMMANDS" , "" , " ssh-client Modify system ssh configuration to respect" , " /var/cache/kiki/config/ssh_known_hosts." , "" , " ssh-server Modify system ssh configuration to use the" , " kiki-managed host key at" , " /var/cache/kiki/config/ssh_host_rsa_key." , "" , " strongswan Modify /etc/ipsec.conf to include settings from" , " /var/cache/kiki/config/ipsec.conf." , "" , " tor Modify /etc/tor/torrc to configure a tor hidden" , " service for email (smtp), ssh, and http ports." , "" , " hosts Merge hostnames from /var/cache/kiki/config/hosts" , " into system file /etc/hosts." ] main = do (cmd,args) <- splitAt 1 <$> getArgs uid <- getEffectiveUserID let msel = case cmd of ["ssh-client"] -> Just $ sshClient uid <$> Kiki.dashdashChroot <*> Kiki.dashdashHomedir ["ssh-server"] -> Just $ sshServer uid <$> Kiki.dashdashChroot <*> Kiki.dashdashHomedir ["strongswan"] -> Just $ strongswan uid <$> Kiki.dashdashChroot <*> Kiki.dashdashHomedir ["tor"] -> Just $ configureTor uid <$> Kiki.dashdashChroot <*> Kiki.dashdashHomedir ["hosts"] -> Just $ configureHosts uid <$> Kiki.dashdashChroot <*> Kiki.dashdashHomedir _ -> Nothing spec = uncurry fancy Kiki.kikiOptions "" errorQuit msg = do hPutStr stderr msg System.Exit.exitFailure fromMaybe (errorQuit usage) $ do sel <- msel Just $ do case runArgs (parseInvocation spec args) sel of Left e -> errorQuit $ usageErrorMessage e Right io -> io maybeReadFile :: FilePath -> IO (Maybe L.ByteString) maybeReadFile path = do doesFileExist path >>= bool (return Nothing) (Just <$> L.readFile path) myWriteFile f bs = do createDirectoryIfMissing True (takeDirectory f) hPutStrLn stderr $ "Writing "++f -- L8.putStr bs L8.writeFile f bs whenRoot uid root cmn action | uid==0 = action | root "" == "/" = no | root "" == "" = no | otherwise = action where no = hPutStrLn stderr "operation requires root." sshClient uid root cmn = whenRoot uid root cmn $ do -- /etc/ssh/config/ssh_config <-- 'GlobalKnownHostsFile /var/cache/kiki/ssh_known_hosts' sshconfig <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ssh/ssh_config") let (ps,qs) = sshSplitAtDirective "GlobalKnownHostsFile" sshconfig sshconfig' <- case qs of d:ds | elem "/var/cache/kiki/config/ssh_known_hosts" d -> do hPutStrLn stderr "ssh-client already configured." return Nothing d:ds -> do hPutStrLn stderr "modifying GlobalKnownHostsFile directive" let hs = " " : "/var/cache/kiki/config/ssh_known_hosts" : drop 1 d stmt = take 1 d ++ hs return $ Just (ps ++ stmt : ds) [] -> do -- Unconfigured add fresh directive. hPutStrLn stderr "adding GlobalKnownHostsFile directive" let stmt = L8.unwords ["GlobalKnownHostsFile" , "/var/cache/kiki/config/ssh_known_hosts" , "/etc/ssh/ssh_known_hosts" , "/etc/ssh/ssh_known_hosts2" ] return $ Just (sshconfig ++ parseSshConfig stmt) sshconfig' `deepseq` return () -- force lazy input maybe (return ()) (myWriteFile (root "/etc/ssh/ssh_config") . unparseSshConfig) sshconfig' -- /var/cache/kiki/config/ssh_known_hosts <-- contains known hosts from /root/.gnupg/... Kiki.importAndRefresh root cmn Unencrypted sshServer uid root cmn = whenRoot uid root cmn $ do sshconfig <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ssh/sshd_config") let p:gs = groupBy (\_ d -> not $ sshIsDirective "HostKey" d) $ ["#"]:sshconfig got = filter (\(d:ds) -> elem "/var/cache/kiki/config/ssh_host_rsa_key" d) gs case got of _:_ -> do hPutStrLn stderr "ssh-server already configured." [] -> do let sshconfig' = drop 1 $ sshconfig ++ [stmt] stmt = ["HostKey", " ", "/var/cache/kiki/config/ssh_host_rsa_key"] hPutStrLn stderr "adding HostKey directive" myWriteFile (root "/etc/ssh/sshd_config") $ unparseSshConfig sshconfig' -- /etc/ssh/sshd_config <-- 'HostKey /var/cache/kiki/config/ssh_host_ecdsa_key' etc. Kiki.importAndRefresh root cmn Unencrypted strongswan uid root cmn = whenRoot uid root cmn $ do -- (1) /etc/ipsec.conf <-- 'include /var/cache/kiki/config/ipsec.conf' -- Parsing as if ssh config, that's not right, but good enough for now. ipsecconf <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ipsec.conf") let p:gs = groupBy (\_ d -> not $ sshIsDirective "include" d) $ ["#"]:ipsecconf got = filter (\(d:ds) -> elem "/var/cache/kiki/config/ipsec.conf" d) gs case got of _:_ -> do hPutStrLn stderr "ipsec.conf already configured." [] -> do let ipsecconf' = drop 1 $ ipsecconf ++ [stmt] stmt = ["include", " ", "/var/cache/kiki/config/ipsec.conf"] hPutStrLn stderr "adding include directive" myWriteFile (root "/etc/ipsec.conf") $ unparseSshConfig ipsecconf' -- (2) /etc/ipsec.secrets/ <- include /var/cache/kiki/config/ipsec.secrets -- Parsing as if ssh config, that's not right, but good enough for now. ipsecconf <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ipsec.secrets") let p:gs = groupBy (\_ d -> not $ sshIsDirective "include" d) $ ["#"]:ipsecconf got = filter (\(d:ds) -> elem "/var/cache/kiki/config/ipsec.secrets" d) gs case got of _:_ -> do hPutStrLn stderr "ipsec.secrets already configured." [] -> do let ipsecconf' = drop 1 $ ipsecconf ++ [stmt] stmt = ["include", " ", "/var/cache/kiki/config/ipsec.secrets"] hPutStrLn stderr "adding include directive" myWriteFile (root "/etc/ipsec.secrets") $ unparseSshConfig ipsecconf' Kiki.importAndRefresh root cmn Unencrypted configureTor uid root cmn = whenRoot uid root cmn $ do -- Parsing as if ssh config, that's not right, but good enough for now. torrc <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/tor/torrc") let p:gs = groupBy (\_ d -> not $ sshIsDirective "HiddenServiceDir" d) $ ["#"]:torrc (fs, hs) = break (\(d:ds) -> elem "/var/cache/kiki/config/tor/" d) gs case hs of (d:ds):ks | (pre:ports) <- groupBy (\_ d -> not $ sshIsDirective "HiddenServicePort" d) $ ["#"]:ds , (got,need) <- partition (hasPort ports) ["80","22","25"] -> case need of [] -> hPutStrLn stderr "tor is already configured." ns | (addr:_) <- mapMaybe (fmap fst . splitAddr . word 2) ds -> do hPutStrLn stderr "binding tor ports for configured address" bindports addr ns | otherwise -> do hPutStrLn stderr "binding tor ports for 127.0.0.1" bindports "127.0.0.1" ns where bindports :: L.ByteString -> [L.ByteString] -> IO () bindports addr ns = do let binds = map mkport ns mkport n = ["HiddenServicePort"," ",n," ",addr <> ":" <> n] torrc' = concat $ drop 1 p : fs ++ (d:binds ++ ds):ks torrc' `deepseq` return () -- force lazy input myWriteFile (root "/etc/tor/torrc") $ unparseSshConfig torrc' hasPort :: [[[L.ByteString]]] -> L.ByteString -> Bool hasPort ports p = not $ null $ flip filter ports $ (==p) . word 1 . concat . take 1 word :: Int -> [L.ByteString] -> L.ByteString word n toks = L.concat $ take 1 $ drop n words where words = filter (not . L8.any isSpace . L8.take 1) toks splitAddr lb | S8.null saddr = Nothing | otherwise = Just ( L.fromChunks [S8.init saddr] , L.fromChunks [sport]) where (saddr,sport) = S8.breakEnd (==':') sb sb = S8.concat $ L.toChunks $ L.take 60 lb [] -> do hPutStrLn stderr $ "configuring new hidden service" let torrc' = torrc ++ [ [] , ["HiddenServiceDir"," ","/var/cache/kiki/config/tor/"] , ["HiddenServicePort"," ","80"," ","127.0.0.1:80"] , ["HiddenServicePort"," ","22"," ","127.0.0.1:22"] , ["HiddenServicePort"," ","25"," ","127.0.0.1:25"] ] myWriteFile (root "/etc/tor/torrc") $ unparseSshConfig torrc' Kiki.importAndRefresh root cmn Unencrypted return () configureHosts uid root cmn = whenRoot uid root cmn $ do Kiki.importAndRefresh root cmn Unencrypted hosts <- Hosts.decode . fromMaybe "" <$> maybeReadFile (root "/etc/hosts") kikihosts <- Hosts.decode . fromMaybe "" <$> maybeReadFile (root "/var/cache/kiki/config/hosts") let hosts' = hosts `Hosts.plus` kikihosts case Hosts.diff hosts hosts' of [] -> hPutStrLn stderr "kiki hosts are already merged." _ -> myWriteFile (root "/etc/hosts") $ Hosts.encode hosts' parseSshConfig :: L.ByteString -> [[L.ByteString]] parseSshConfig bs = map tokenize $ L8.lines bs where tokenize l = L8.groupBy tokrel l' ++ [comment] where (l', comment) = L8.break (=='#') l tokrel x y = isSpace x == isSpace y unparseSshConfig ls = L8.unlines $ map L.concat $ ls sshSplitAtDirective d sshconfig = break (sshIsDirective d) sshconfig sshIsDirective d ls = case dropWhile isSpaceTok ls of g:_ | g == d -> True _ -> False where isSpaceTok "" = True isSpaceTok b = isSpace $ L8.head b #if !MIN_VERSION_base(4,7,0) bool :: a -> a -> Bool -> a bool f _ False = f bool _ t True = t #endif