summaryrefslogtreecommitdiff
path: root/lib/Kiki.hs
blob: 575cf266bfeab584711ea1ee58f5f4aab505a6f8 (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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
{-# LANGUAGE CPP #-}
module Kiki where

import Control.Monad
import Control.Applicative
import Data.List
import Data.Maybe
import Data.Ord
import System.Directory
import System.FilePath.Posix
import System.IO
import Data.OpenPGP
import Data.OpenPGP.Util
import qualified Data.Map.Strict as Map
import qualified Codec.Binary.Base64 as Base64
import Data.ASN1.BinaryEncoding
import Data.ASN1.Encoding
import Data.ASN1.Types
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as Char8

import CommandLine
import qualified SSHKey as SSH
import KeyRing

-- |
-- Regenerate /var/cache/kiki
refresh :: (FilePath -> FilePath) -> CommonArgsParsed -> IO ()
refresh root homepass = do
    let homepass' = homepass { cap_homespec = fmap root (cap_homespec homepass) }
    KikiResult r report <- runKeyRing $ minimalOp homepass'
    let mroot = case root "" of
                    "/" -> Nothing
                    ""  -> Nothing
                    pth -> Just pth
    case r of
        KikiSuccess rt -> refreshCache rt mroot
        _ -> return () -- XXX: silent fail?

data CommonArgsParsed = CommonArgsParsed { cap_homespec :: Maybe String, cap_passfd :: Maybe InputFile }


minimalOp :: CommonArgsParsed -> KeyRingOperation
minimalOp cap = op
 where
    streaminfo = StreamInfo { fill = KF_None
                            , typ = KeyRingFile
                            , spill = KF_All
                            , initializer = NoCreate
                            , access = AutoAccess
                            , transforms = []
                            }
    op = KeyRingOperation
        { opFiles = Map.fromList $
            [ ( HomeSec, streaminfo { access = Sec })
            , ( HomePub, streaminfo { access = Pub })
            ]
        , opPassphrases = do pfile <- maybeToList (cap_passfd cap)
                             return $ PassphraseSpec Nothing Nothing pfile
        , opTransforms = []
        , opHome = cap_homespec cap
        }


refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO ()
refreshCache rt rootdir = do

    let mkpath pth = fromMaybe "" rootdir ++ "/var/cache/kiki/"++pth

        write f bs = do
            createDirectoryIfMissing True $ takeDirectory f
            writeFile f bs

    let oname' = do wk <- rtWorkingKey rt
                    -- XXX unnecessary signature check
                    onionNameForContact (keykey wk) (rtKeyDB rt)
        bUnprivileged = False -- TODO
    if (oname' == Nothing) && (not bUnprivileged) then error "Missing tor key" else do
    let oname = fromMaybe "" oname'
    -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </> "id_rsa.pub"
    -- sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub"
    -- contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem"

    -- Finally, export public keys if they do not exist.
    flip (maybe $ warn "missing working key?") (rtGrip rt) $ \grip -> do
    either warn (write $ mkpath "root/.ssh/id_rsa.pub")
            $ show_ssh' "ssh-client" grip (rtKeyDB rt)
    either warn (write $ mkpath "ssh_host_rsa_key.pub")
        $ show_ssh' "ssh-server" grip (rtKeyDB rt)
    either warn (write $ mkpath "ipsec.d/certs/" ++ oname++".pem")
        $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket

    let cs = filter notme (Map.elems $ rtKeyDB rt)
        kk = keykey (fromJust $ rtWorkingKey rt)
        notme kd = keykey (keyPacket kd) /= kk

        installConctact kd = do
            -- The getHostnames command requires a valid cross-signed tor key
            -- for each onion name returned in (_,(ns,_)).
            let (_,(ns,_)) = getHostnames kd
                contactname = fmap Char8.unpack $ listToMaybe ns -- only first onion name.
            flip (maybe $ return ()) contactname $ \contactname -> do

            let cpath = interp (Map.singleton "onion" contactname) "ipsec.d/certs/%(onion).pem"
                their_master = packet $ keyMappedPacket kd
                -- We find all cross-certified ipsec keys for the given cross-certified onion name.
                ipsecs = sortOn (Down . timestamp)
                         $ getCrossSignedSubkeys their_master (keySubKeys kd) "ipsec"
            forM_ (take 1 ipsecs) $ \k -> do
            either warn (write $ mkpath cpath) $ pemFromPacket k

    mapM_ installConctact cs


#if !MIN_VERSION_base(4,8,0)
sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn f =
    map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))
#endif

pemFromPacket k = do
    let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k
        der = encodeASN1 DER (toASN1 rsa [])
        qq  = Base64.encode (L.unpack der)
    return $
        writePEM "PUBLIC KEY" qq -- ("TODO "++show keyspec)

show_pem keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db pemFromPacket

show_pem' keyspec wkgrip db keyfmt = do
    let s = parseSpec wkgrip keyspec
    flip (maybe . Left $ keyspec ++ ": not found")
         (selectPublicKey s db)
         keyfmt

warn str = hPutStrLn stderr str

show_ssh keyspec wkgrip db = either warn putStrLn $ show_ssh' keyspec wkgrip db

show_ssh' keyspec wkgrip db = do
    let s = parseSpec wkgrip keyspec
    flip (maybe . Left $ keyspec ++ ": not found")
         (selectPublicKey s db)
         $ return . sshblobFromPacket

-- |
-- interpolate %var patterns in a string.
interp vars raw = es >>= interp1
 where
    gs = groupBy (\_ c -> c/='%') raw
    es = dropWhile null $ gobbleEscapes ("":gs)
            where gobbleEscapes :: [String] -> [String]
                  gobbleEscapes (a:"%":b:bs) = (a++b) : gobbleEscapes bs
                  gobbleEscapes (g:gs)       = g : gobbleEscapes gs
                  gobbleEscapes []           = []
    interp1 ('%':'(':str) = fromMaybe "" (Map.lookup key vars) ++ drop 1 rest
                            where (key,rest) = break (==')') str
    interp1 plain = plain

sshblobFromPacket k = blob
 where
    Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k
    bs = SSH.keyblob (n,e)
    blob = Char8.unpack bs

ㄧhomedir = Kiki.CommonArgsParsed
                <$> optional (arg "--homedir")
                <*> optional (FileDesc <$> read <$> arg "--passphrase-fd")