summaryrefslogtreecommitdiff
path: root/cokiki.hs
diff options
context:
space:
mode:
Diffstat (limited to 'cokiki.hs')
-rw-r--r--cokiki.hs60
1 files changed, 45 insertions, 15 deletions
diff --git a/cokiki.hs b/cokiki.hs
index 2cb6491..daf2be5 100644
--- a/cokiki.hs
+++ b/cokiki.hs
@@ -1,5 +1,7 @@
1{-# LANGUAGE OverloadedStrings #-} 1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE CPP #-}
2import Control.Applicative 3import Control.Applicative
4import Control.DeepSeq
3import Data.Bool 5import Data.Bool
4import Data.Char 6import Data.Char
5import Data.Maybe 7import Data.Maybe
@@ -10,6 +12,7 @@ import System.Directory
10import System.Environment 12import System.Environment
11import System.IO 13import System.IO
12import System.Posix.User 14import System.Posix.User
15import CommandLine
13 16
14usage = unlines 17usage = unlines
15 [ "cokiki <command>" 18 [ "cokiki <command>"
@@ -20,37 +23,62 @@ usage = unlines
20 , " strongswan" 23 , " strongswan"
21 ] 24 ]
22 25
26ㄧchroot = pure (\r a -> slash r a) <*> arg "--chroot" <|> pure id
27 where
28 slash :: String -> String -> String
29 slash "/" ('/':xs) = '/':xs
30 slash "" ('/':xs) = '/':xs
31 slash "" xs = '/':xs
32 slash (y:ys) xs = y:slash ys xs
33
23main = do 34main = do
24 args <- getArgs 35 (cmd,args) <- splitAt 1 <$> getArgs
25 uid <- getEffectiveUserID 36 uid <- getEffectiveUserID
26 let whenRoot action 37 let whenRoot action
27 | uid==0 = action 38 | uid==0 = action
28 | otherwise = hPutStrLn stderr "operaiton requires root." 39 | otherwise = hPutStrLn stderr "operation requires root."
29 case args of 40 let sel = case cmd of
30 ["ssh-client"] -> sshClient uid id 41 ["ssh-client"] -> pure (sshClient uid) <*> ㄧchroot
31 ["ssh-server"] -> whenRoot sshServer 42 ["ssh-server"] -> pure (whenRoot sshServer)
32 ["strongswan"] -> whenRoot strongswan 43 ["strongswan"] -> pure (whenRoot strongswan)
33 _ -> hPutStr stderr usage 44 _ -> pure $ hPutStr stderr usage
45 spec = fancy [("--chroot",1)] [] ""
46 case runArgs (parseInvocation spec args) sel of
47 Left e -> hPutStrLn stderr $ usageErrorMessage e
48 Right io -> io
34 49
35maybeReadFile :: FilePath -> IO (Maybe L.ByteString) 50maybeReadFile :: FilePath -> IO (Maybe L.ByteString)
36maybeReadFile path = do 51maybeReadFile path = do
37 doesFileExist path >>= bool (return Nothing) (Just <$> L.readFile path) 52 doesFileExist path >>= bool (return Nothing) (Just <$> L.readFile path)
38 53
39sshClient 0 root = do 54sshClient uid root = do
40 -- /etc/ssh/ssh_config <-- 'GlobalKnownHostsFile /var/cache/kiki/ssh_known_hosts' 55 -- /etc/ssh/ssh_config <-- 'GlobalKnownHostsFile /var/cache/kiki/ssh_known_hosts'
41 sshconfig <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ssh/ssh_config") 56 sshconfig <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ssh/ssh_config")
42 let (ps,qs) = sshSplitAtDirective "GlobalKnownHostsFile" sshconfig 57 let (ps,qs) = sshSplitAtDirective "GlobalKnownHostsFile" sshconfig
58 myWriteFile f bs = do
59 hPutStrLn stderr $ "Writing "++f
60 -- L8.putStr bs
61 L8.writeFile f bs
43 sshconfig' <- 62 sshconfig' <-
44 case qs of 63 case qs of
45 d:ds -> error "modify GlobalKnownHostsFile" 64 d:ds | elem "/var/cache/kiki/ssh_known_hosts" d
46 [] -> error "append GlobalKnownHostsFile" 65 -> do hPutStrLn stderr "ssh-client already configured."
47 L.writeFile (root "/var/cache/kiki/ssh_known_hosts") $ unparseSshConfig sshconfig' 66 return Nothing
67 d:ds -> do hPutStrLn stderr "modifying GlobalKnownHostsFile not implemented"
68 return Nothing
69 [] -> do
70 let stmt = L8.unwords ["GlobalKnownHostsFile"
71 , "/var/cache/kiki/ssh_known_hosts"
72 , "/etc/ssh/ssh_known_hosts"
73 , "/etc/ssh/ssh_known_hosts2"
74 ]
75 return $ Just (sshconfig ++ parseSshConfig stmt)
76 -- sshconfig' `deepseq` return () -- force lazy input
77 maybe (return ()) (myWriteFile (root "/etc/ssh/ssh_config") . unparseSshConfig) sshconfig'
48 -- /root/.gnupg/... <-- contains known hosts from /etc/ssh/ssh_known_hosts 78 -- /root/.gnupg/... <-- contains known hosts from /etc/ssh/ssh_known_hosts
49 Kiki.refresh
50 -- /var/cache/kiki/ssh_known_hosts <-- contains known hosts from /root/.gnupg/...
51
52 79
53sshClient uid root = return () 80 -- Kiki.refresh
81 -- /var/cache/kiki/ssh_known_hosts <-- contains known hosts from /root/.gnupg/...
54 82
55sshServer = do 83sshServer = do
56 -- /etc/ssh/sshd_config <-- 'HostKey /var/cache/kiki/ssh_host_ecdsa_key' etc. 84 -- /etc/ssh/sshd_config <-- 'HostKey /var/cache/kiki/ssh_host_ecdsa_key' etc.
@@ -84,6 +112,8 @@ sshIsDirective d ls =
84 isSpaceTok "" = True 112 isSpaceTok "" = True
85 isSpaceTok b = isSpace $ L8.head b 113 isSpaceTok b = isSpace $ L8.head b
86 114
115#if !MIN_VERSION_base(4,8,0)
87bool :: a -> a -> Bool -> a 116bool :: a -> a -> Bool -> a
88bool f _ False = f 117bool f _ False = f
89bool _ t True = t 118bool _ t True = t
119#endif