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 @@
+{-# 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 :: IO ()
-refresh = do
-    -- TODO
-    return ()
+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")
+
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 @@
+module LengthPrefixedBE
+    ( LengthPrefixedBE(..)
+    , encode_bigendian
+    , decode_bigendian
+    ) where
+
+import qualified Data.ByteString.Lazy as L
+import Data.Bits
+import Data.Binary
+import Data.Binary.Get
+import Data.Binary.Put (putWord32be, putLazyByteString)
+import Data.Int
+
+{-
+   From RFC4251...
+ 
+   string
+
+      Arbitrary length binary string.  Strings are allowed to contain
+      arbitrary binary data, including null characters and 8-bit
+      characters.  They are stored as a uint32 containing its length
+      (number of bytes that follow) and zero (= empty string) or more
+      bytes that are the value of the string.  Terminating null
+      characters are not used.
+
+   mpint ( LengthPrefixedBE )
+
+      Represents multiple precision integers in two's complement format,
+      stored as a string, 8 bits per byte, MSB first.  Negative numbers
+      have the value 1 as the most significant bit of the first byte of
+      the data partition.  If the most significant bit would be set for
+      a positive number, the number MUST be preceded by a zero byte.
+      Unnecessary leading bytes with the value 0 or 255 MUST NOT be
+      included.  The value zero MUST be stored as a string with zero
+      bytes of data.
+-}
+
+newtype LengthPrefixedBE = LengthPrefixedBE Integer
+
+instance Binary LengthPrefixedBE where
+
+    put (LengthPrefixedBE n) = do
+        putWord32be len
+        putLazyByteString bytes
+     where
+        bytes = encode_bigendian n
+        len = fromIntegral (L.length bytes) :: Word32
+
+    get = do
+        len <- get
+        bs <- getLazyByteString (word32_to_int64 len)
+        return . LengthPrefixedBE $ decode_bigendian bs
+     where
+        word32_to_int64 :: Word32 -> Int64
+        word32_to_int64 = fromIntegral
+        
+
+
+encode_bigendian :: (Integral a, Bits a) => a -> L.ByteString
+encode_bigendian n =
+        if (bit /= sbyte) 
+         then sbyte `L.cons` bytes
+         else bytes
+     where
+        bytes = L.reverse $ unroll n
+        sbyte :: Word8
+        sbyte = if n<0 then 0xFF else 0
+        bit = if L.null bytes 
+                then 0x00
+                else fromIntegral ((fromIntegral (L.head bytes) :: Int8) `shiftR` 7)
+
+        unroll :: (Integral a, Bits a) => a -> L.ByteString
+        unroll = L.unfoldr step 
+            -- TODO: Is reversing L.unfoldr more or less efficient
+            --  than using Data.List.unfoldr ?
+            --  Probably Data.ByteString.Lazy should export an unfoldrEnd
+            --  function that efficiently unfolds reversed bytestrings.
+          where
+            step 0 = Nothing
+            step (-1) = Nothing
+            step i = Just (fromIntegral i, i `shiftR` 8)
+
+decode_bigendian :: (Num a, Bits a) => L.ByteString -> a
+decode_bigendian bs = if isneg then n - 256^(L.length bs)
+                               else n
+ where
+    n = L.foldl (\a b -> a `shiftL` 8 .|. fromIntegral b) 0 bs
+    isneg = not (L.null bs) &&  L.head bs .&. 0x80 /= 0
+
+
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 @@
+{-# LANGUAGE OverloadedStrings #-}
+module SSHKey where
+
+import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Data.ByteString.Lazy as L
+import qualified Codec.Binary.Base64 as Base64
+import Data.Binary.Get ( runGet )
+import Data.Binary.Put ( putWord32be, runPut, putByteString )
+import Data.Binary     ( get, put )
+import Data.Monoid     ( (<>) )
+import Data.Maybe      ( listToMaybe )
+import Data.Char       ( isSpace )
+import Control.Monad   ( guard )
+import LengthPrefixedBE
+
+type Key = (Integer,Integer)
+
+keyblob :: Key -> L.ByteString
+keyblob (n,e) = "ssh-rsa " <> blob
+ where
+    bs = sshrsa e n
+    blob = L8.pack $ Base64.encode (L.unpack bs)
+
+    sshrsa :: Integer -> Integer -> L.ByteString
+    sshrsa e n = runPut $ do
+        putWord32be 7
+        putByteString "ssh-rsa"
+        put (LengthPrefixedBE e)
+        put (LengthPrefixedBE n)
+
+blobkey :: L8.ByteString -> Maybe Key
+blobkey bs = do
+    let (pre,bs1) = L8.splitAt 7 bs
+    guard $ pre == "ssh-rsa"
+    let (sp,bs2) = L8.span isSpace bs1
+    guard $ not (L8.null sp)
+    bs3 <- listToMaybe $ L8.words bs2
+    qq <- L.pack `fmap` Base64.decode (L8.unpack bs3)
+    decode_sshrsa qq
+ where
+    decode_sshrsa :: L8.ByteString -> Maybe Key
+    decode_sshrsa bs = do
+        let (pre,bs1) = L8.splitAt 11 bs
+        guard $ pre == runPut (putWord32be 7 >> putByteString "ssh-rsa")
+        let rsakey = flip runGet bs1 $ do
+                LengthPrefixedBE e <- get
+                LengthPrefixedBE n <- get
+                return (n,e)
+        return rsakey