summaryrefslogtreecommitdiff
path: root/cokiki.hs
blob: c93e30e5cada6c871a3e44a41cd994c4bf2379d4 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
import Control.Applicative
import Control.DeepSeq
import Data.Bool
import Data.Char
import Data.Maybe
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Kiki
import System.Directory
import System.Environment
import System.IO
import System.Posix.User
import CommandLine

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/ssh_known_hosts."
    , ""
    , "  ssh-server   Modify system ssh configuration to use the"
    , "               kiki-managed host key at"
    , "               /var/cache/kiki/ssh_host_rsa_key."
    , ""
    , "  strongswan   Modify /etc/ipsec.conf to include settings from"
    , "               /var/cache/kiki/ipsec.conf."
    ]

main = do
    (cmd,args) <- splitAt 1 <$> getArgs
    uid <- getEffectiveUserID
    let whenRoot action
            | uid==0    = action
            | otherwise = hPutStrLn stderr "operation requires root."
    let sel = case cmd of
                ["ssh-client"] -> pure (sshClient uid) <*> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
                ["ssh-server"] -> pure (whenRoot sshServer)
                ["strongswan"] -> pure (whenRoot strongswan)
                _   -> pure $ hPutStr stderr usage
        spec = uncurry fancy Kiki.kikiOptions ""
    case runArgs (parseInvocation spec args) sel of
        Left e   -> hPutStrLn stderr $ usageErrorMessage e
        Right io -> io

maybeReadFile :: FilePath -> IO (Maybe L.ByteString)
maybeReadFile path = do
    doesFileExist path >>= bool (return Nothing) (Just <$> L.readFile path)

sshClient uid root cmn = do
    -- /etc/ssh/ssh_config    <--  'GlobalKnownHostsFile /var/cache/kiki/ssh_known_hosts'
    sshconfig <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ssh/ssh_config")
    let (ps,qs) = sshSplitAtDirective "GlobalKnownHostsFile" sshconfig
        myWriteFile f bs = do
            hPutStrLn stderr $ "Writing "++f
            -- L8.putStr bs
            L8.writeFile f bs
    sshconfig' <-
        case qs of
            d:ds | elem "/var/cache/kiki/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/ssh_known_hosts" : drop 1 d
                           stmt = take 1 d ++ hs
                       return $ Just (ps ++ stmt : ds)
            []   -> do -- Unconfigured add fresh directive.
                       let stmt = L8.unwords ["GlobalKnownHostsFile"
                                             ,  "/var/cache/kiki/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'

    -- /root/.gnupg/...       <--  contains known hosts from /etc/ssh/ssh_known_hosts
    -- /var/cache/kiki/ssh_known_hosts        <--  contains known hosts from /root/.gnupg/...
    -- Kiki.replaceSshServerKeys root cmn
    Kiki.importAndRefresh root cmn

sshServer = do
    -- /etc/ssh/sshd_config <-- 'HostKey /var/cache/kiki/ssh_host_ecdsa_key' etc.
    return ()

strongswan = do
    -- etc/ipsec.conf    <--  'include /var/cache/kiki/ipsec.conf'
    -- /root/.gnupg/...   <--  contains newly-generated ipsec subkey
    Kiki.refresh id (Kiki.CommonArgsParsed Nothing Nothing)
    -- /var/cache/kiki/ipsec.conf      <--  contains configurations for each remote ipsec host
    -- /var/cache/kiki/ipsec.conf      <--  contains '%default' configuration for this local host
    -- /var/cache/kiki/ipsec.d/certs   <--  contains relevant certs
    -- /var/cache/kiki/ipsec.d/private <--  contains private key


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