path: root/cokiki.hs

{-# 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 <command> [--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.ㄧchroot <*> Kiki.ㄧhomedir
                ["ssh-server"] -> Just $ sshServer  uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
                ["strongswan"] -> Just $ strongswan uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
                ["tor"]        -> Just $ configureTor uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
                ["hosts"]      -> Just $ configureHosts uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
                _ -> 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