summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Kiki.hs169
-rw-r--r--lib/LengthPrefixedBE.hs90
-rw-r--r--lib/SSHKey.hs49
3 files changed, 304 insertions, 4 deletions
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index 783b6ed..575cf26 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -1,8 +1,169 @@
1{-# LANGUAGE CPP #-}
1module Kiki where 2module Kiki where
2 3
4import Control.Monad
5import Control.Applicative
6import Data.List
7import Data.Maybe
8import Data.Ord
9import System.Directory
10import System.FilePath.Posix
11import System.IO
12import Data.OpenPGP
13import Data.OpenPGP.Util
14import qualified Data.Map.Strict as Map
15import qualified Codec.Binary.Base64 as Base64
16import Data.ASN1.BinaryEncoding
17import Data.ASN1.Encoding
18import Data.ASN1.Types
19import qualified Data.ByteString.Lazy as L
20import qualified Data.ByteString.Lazy.Char8 as Char8
21
22import CommandLine
23import qualified SSHKey as SSH
24import KeyRing
25
3-- | 26-- |
4-- Regenerate /var/cache/kiki 27-- Regenerate /var/cache/kiki
5refresh :: IO () 28refresh :: (FilePath -> FilePath) -> CommonArgsParsed -> IO ()
6refresh = do 29refresh root homepass = do
7 -- TODO 30 let homepass' = homepass { cap_homespec = fmap root (cap_homespec homepass) }
8 return () 31 KikiResult r report <- runKeyRing $ minimalOp homepass'
32 let mroot = case root "" of
33 "/" -> Nothing
34 "" -> Nothing
35 pth -> Just pth
36 case r of
37 KikiSuccess rt -> refreshCache rt mroot
38 _ -> return () -- XXX: silent fail?
39
40data CommonArgsParsed = CommonArgsParsed { cap_homespec :: Maybe String, cap_passfd :: Maybe InputFile }
41
42
43minimalOp :: CommonArgsParsed -> KeyRingOperation
44minimalOp cap = op
45 where
46 streaminfo = StreamInfo { fill = KF_None
47 , typ = KeyRingFile
48 , spill = KF_All
49 , initializer = NoCreate
50 , access = AutoAccess
51 , transforms = []
52 }
53 op = KeyRingOperation
54 { opFiles = Map.fromList $
55 [ ( HomeSec, streaminfo { access = Sec })
56 , ( HomePub, streaminfo { access = Pub })
57 ]
58 , opPassphrases = do pfile <- maybeToList (cap_passfd cap)
59 return $ PassphraseSpec Nothing Nothing pfile
60 , opTransforms = []
61 , opHome = cap_homespec cap
62 }
63
64
65refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO ()
66refreshCache rt rootdir = do
67
68 let mkpath pth = fromMaybe "" rootdir ++ "/var/cache/kiki/"++pth
69
70 write f bs = do
71 createDirectoryIfMissing True $ takeDirectory f
72 writeFile f bs
73
74 let oname' = do wk <- rtWorkingKey rt
75 -- XXX unnecessary signature check
76 onionNameForContact (keykey wk) (rtKeyDB rt)
77 bUnprivileged = False -- TODO
78 if (oname' == Nothing) && (not bUnprivileged) then error "Missing tor key" else do
79 let oname = fromMaybe "" oname'
80 -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </> "id_rsa.pub"
81 -- sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub"
82 -- contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem"
83
84 -- Finally, export public keys if they do not exist.
85 flip (maybe $ warn "missing working key?") (rtGrip rt) $ \grip -> do
86 either warn (write $ mkpath "root/.ssh/id_rsa.pub")
87 $ show_ssh' "ssh-client" grip (rtKeyDB rt)
88 either warn (write $ mkpath "ssh_host_rsa_key.pub")
89 $ show_ssh' "ssh-server" grip (rtKeyDB rt)
90 either warn (write $ mkpath "ipsec.d/certs/" ++ oname++".pem")
91 $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket
92
93 let cs = filter notme (Map.elems $ rtKeyDB rt)
94 kk = keykey (fromJust $ rtWorkingKey rt)
95 notme kd = keykey (keyPacket kd) /= kk
96
97 installConctact kd = do
98 -- The getHostnames command requires a valid cross-signed tor key
99 -- for each onion name returned in (_,(ns,_)).
100 let (_,(ns,_)) = getHostnames kd
101 contactname = fmap Char8.unpack $ listToMaybe ns -- only first onion name.
102 flip (maybe $ return ()) contactname $ \contactname -> do
103
104 let cpath = interp (Map.singleton "onion" contactname) "ipsec.d/certs/%(onion).pem"
105 their_master = packet $ keyMappedPacket kd
106 -- We find all cross-certified ipsec keys for the given cross-certified onion name.
107 ipsecs = sortOn (Down . timestamp)
108 $ getCrossSignedSubkeys their_master (keySubKeys kd) "ipsec"
109 forM_ (take 1 ipsecs) $ \k -> do
110 either warn (write $ mkpath cpath) $ pemFromPacket k
111
112 mapM_ installConctact cs
113
114
115#if !MIN_VERSION_base(4,8,0)
116sortOn :: Ord b => (a -> b) -> [a] -> [a]
117sortOn f =
118 map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))
119#endif
120
121pemFromPacket k = do
122 let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k
123 der = encodeASN1 DER (toASN1 rsa [])
124 qq = Base64.encode (L.unpack der)
125 return $
126 writePEM "PUBLIC KEY" qq -- ("TODO "++show keyspec)
127
128show_pem keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db pemFromPacket
129
130show_pem' keyspec wkgrip db keyfmt = do
131 let s = parseSpec wkgrip keyspec
132 flip (maybe . Left $ keyspec ++ ": not found")
133 (selectPublicKey s db)
134 keyfmt
135
136warn str = hPutStrLn stderr str
137
138show_ssh keyspec wkgrip db = either warn putStrLn $ show_ssh' keyspec wkgrip db
139
140show_ssh' keyspec wkgrip db = do
141 let s = parseSpec wkgrip keyspec
142 flip (maybe . Left $ keyspec ++ ": not found")
143 (selectPublicKey s db)
144 $ return . sshblobFromPacket
145
146-- |
147-- interpolate %var patterns in a string.
148interp vars raw = es >>= interp1
149 where
150 gs = groupBy (\_ c -> c/='%') raw
151 es = dropWhile null $ gobbleEscapes ("":gs)
152 where gobbleEscapes :: [String] -> [String]
153 gobbleEscapes (a:"%":b:bs) = (a++b) : gobbleEscapes bs
154 gobbleEscapes (g:gs) = g : gobbleEscapes gs
155 gobbleEscapes [] = []
156 interp1 ('%':'(':str) = fromMaybe "" (Map.lookup key vars) ++ drop 1 rest
157 where (key,rest) = break (==')') str
158 interp1 plain = plain
159
160sshblobFromPacket k = blob
161 where
162 Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k
163 bs = SSH.keyblob (n,e)
164 blob = Char8.unpack bs
165
166ㄧhomedir = Kiki.CommonArgsParsed
167 <$> optional (arg "--homedir")
168 <*> optional (FileDesc <$> read <$> arg "--passphrase-fd")
169
diff --git a/lib/LengthPrefixedBE.hs b/lib/LengthPrefixedBE.hs
new file mode 100644
index 0000000..0ccd0e2
--- /dev/null
+++ b/lib/LengthPrefixedBE.hs
@@ -0,0 +1,90 @@
1module LengthPrefixedBE
2 ( LengthPrefixedBE(..)
3 , encode_bigendian
4 , decode_bigendian
5 ) where
6
7import qualified Data.ByteString.Lazy as L
8import Data.Bits
9import Data.Binary
10import Data.Binary.Get
11import Data.Binary.Put (putWord32be, putLazyByteString)
12import Data.Int
13
14{-
15 From RFC4251...
16
17 string
18
19 Arbitrary length binary string. Strings are allowed to contain
20 arbitrary binary data, including null characters and 8-bit
21 characters. They are stored as a uint32 containing its length
22 (number of bytes that follow) and zero (= empty string) or more
23 bytes that are the value of the string. Terminating null
24 characters are not used.
25
26 mpint ( LengthPrefixedBE )
27
28 Represents multiple precision integers in two's complement format,
29 stored as a string, 8 bits per byte, MSB first. Negative numbers
30 have the value 1 as the most significant bit of the first byte of
31 the data partition. If the most significant bit would be set for
32 a positive number, the number MUST be preceded by a zero byte.
33 Unnecessary leading bytes with the value 0 or 255 MUST NOT be
34 included. The value zero MUST be stored as a string with zero
35 bytes of data.
36-}
37
38newtype LengthPrefixedBE = LengthPrefixedBE Integer
39
40instance Binary LengthPrefixedBE where
41
42 put (LengthPrefixedBE n) = do
43 putWord32be len
44 putLazyByteString bytes
45 where
46 bytes = encode_bigendian n
47 len = fromIntegral (L.length bytes) :: Word32
48
49 get = do
50 len <- get
51 bs <- getLazyByteString (word32_to_int64 len)
52 return . LengthPrefixedBE $ decode_bigendian bs
53 where
54 word32_to_int64 :: Word32 -> Int64
55 word32_to_int64 = fromIntegral
56
57
58
59encode_bigendian :: (Integral a, Bits a) => a -> L.ByteString
60encode_bigendian n =
61 if (bit /= sbyte)
62 then sbyte `L.cons` bytes
63 else bytes
64 where
65 bytes = L.reverse $ unroll n
66 sbyte :: Word8
67 sbyte = if n<0 then 0xFF else 0
68 bit = if L.null bytes
69 then 0x00
70 else fromIntegral ((fromIntegral (L.head bytes) :: Int8) `shiftR` 7)
71
72 unroll :: (Integral a, Bits a) => a -> L.ByteString
73 unroll = L.unfoldr step
74 -- TODO: Is reversing L.unfoldr more or less efficient
75 -- than using Data.List.unfoldr ?
76 -- Probably Data.ByteString.Lazy should export an unfoldrEnd
77 -- function that efficiently unfolds reversed bytestrings.
78 where
79 step 0 = Nothing
80 step (-1) = Nothing
81 step i = Just (fromIntegral i, i `shiftR` 8)
82
83decode_bigendian :: (Num a, Bits a) => L.ByteString -> a
84decode_bigendian bs = if isneg then n - 256^(L.length bs)
85 else n
86 where
87 n = L.foldl (\a b -> a `shiftL` 8 .|. fromIntegral b) 0 bs
88 isneg = not (L.null bs) && L.head bs .&. 0x80 /= 0
89
90
diff --git a/lib/SSHKey.hs b/lib/SSHKey.hs
new file mode 100644
index 0000000..488f55f
--- /dev/null
+++ b/lib/SSHKey.hs
@@ -0,0 +1,49 @@
1{-# LANGUAGE OverloadedStrings #-}
2module SSHKey where
3
4import qualified Data.ByteString.Lazy.Char8 as L8
5import qualified Data.ByteString.Lazy as L
6import qualified Codec.Binary.Base64 as Base64
7import Data.Binary.Get ( runGet )
8import Data.Binary.Put ( putWord32be, runPut, putByteString )
9import Data.Binary ( get, put )
10import Data.Monoid ( (<>) )
11import Data.Maybe ( listToMaybe )
12import Data.Char ( isSpace )
13import Control.Monad ( guard )
14import LengthPrefixedBE
15
16type Key = (Integer,Integer)
17
18keyblob :: Key -> L.ByteString
19keyblob (n,e) = "ssh-rsa " <> blob
20 where
21 bs = sshrsa e n
22 blob = L8.pack $ Base64.encode (L.unpack bs)
23
24 sshrsa :: Integer -> Integer -> L.ByteString
25 sshrsa e n = runPut $ do
26 putWord32be 7
27 putByteString "ssh-rsa"
28 put (LengthPrefixedBE e)
29 put (LengthPrefixedBE n)
30
31blobkey :: L8.ByteString -> Maybe Key
32blobkey bs = do
33 let (pre,bs1) = L8.splitAt 7 bs
34 guard $ pre == "ssh-rsa"
35 let (sp,bs2) = L8.span isSpace bs1
36 guard $ not (L8.null sp)
37 bs3 <- listToMaybe $ L8.words bs2
38 qq <- L.pack `fmap` Base64.decode (L8.unpack bs3)
39 decode_sshrsa qq
40 where
41 decode_sshrsa :: L8.ByteString -> Maybe Key
42 decode_sshrsa bs = do
43 let (pre,bs1) = L8.splitAt 11 bs
44 guard $ pre == runPut (putWord32be 7 >> putByteString "ssh-rsa")
45 let rsakey = flip runGet bs1 $ do
46 LengthPrefixedBE e <- get
47 LengthPrefixedBE n <- get
48 return (n,e)
49 return rsakey