9 files changed, 51 insertions, 183 deletions

diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..e2b7af1
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,9 @@
+build:
+        stack build
+
+execs = kiki cokiki hosts
+dests = $(addprefix ~/.local/bin/, $(execs))
+
+install: build
+        stack install
+        sudo ln -sf $(dests) /usr/local/bin/
diff --git a/kiki.hs b/kiki.hs
index 0b884ae..5bd6951 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -43,7 +43,6 @@ import qualified Data.Map as Map
 import Control.Arrow   (first,second)
 import Data.Monoid ( (<>) )
 import Data.Binary.Put
-import System.Posix.User
 
 import CommandLine
 import Data.OpenPGP.Util (verify, fingerprint, GenerateKeyParams(..))
@@ -1312,8 +1311,6 @@ kiki "merge" [] = do
         , "                   don't write)."
         , ""
         , "  --create=(rsa:SIZE|cmd:CMD)"
-        , "                   Note: With --flow=spill, a dummy file name must still be"
-        , "                   provided so that the command line can be parsed."
         , ""
         , "  --autosign[=no]"
         , ""
@@ -1536,16 +1533,7 @@ kiki "init" args | "--help" `elem` args = do
         , ""
         ] ++ documentHomeDir ++ [""] ++ documentPassphraseFDFlag True True True
 
-kiki "init" args = do
-    rootOK <- case runArgs ([],args) dashdashChroot of
-        Left e     -> hPutStrLn stderr (usageErrorMessage e) >> return False
-        Right root -> if root "x" /= root "x"
-                        then return True
-                        else fmap (==0) $ getEffectiveUserID
-    if rootOK
-        then run args $ importAndRefresh <$> dashdashChroot <*> dashdashHomedir <*> dashdashCipher
-        else do hPutStrLn stderr "Missing --chroot option.  Permision denied."
-                exitFailure
+kiki "init" args = run args $ importAndRefresh <$> dashdashChroot <*> dashdashHomedir <*> dashdashCipher
 kiki "spawn" args | "--help" `elem` args =
     putStr . unlines $
         [ "kiki spawn [ --passphrase-fd=FD"
@@ -1612,18 +1600,6 @@ kiki "tar" args | "--help" `elem` args = do
         ,"            (sub-string of a user id without 'u:' prefix)"
         ]
 
-kiki "tar" args = do
-    let parsed_args = processArgs sargspec [] "" args
-        sargspec = [("-t",0),("-c",0),("--secrets",1)]
-        ismode ("-t":_) = True
-        ismode ("-c":_) = True
-        ismode _        = False
-    case filter ismode (fst parsed_args) of
-        ["-t":_] -> tarT parsed_args
-        ["-c":_] -> tarC parsed_args
-        ["-A":_] -> putStrLn "unimplemented." -- import tar file?
-        _ -> kiki "tar" ["--help"]
-
 kiki "verify" args | "--help" `elem` args = do
     putStr . unlines $
         [ "kiki verify [--homedir HOMEDIR | --homeless] [[--keyring FILE] ...] FILE"
@@ -1644,126 +1620,6 @@ sshkeyname :: Packet -> [FilePath]
 sshkeyname SecretKeyPacket { key_algorithm = RSA } = ["id_rsa"]
 sshkeyname _ = []
 
-
-tarContent :: KeyRingRuntime
-           -> Maybe String
-           -> ([Char8.ByteString] -> SockAddr -> Packet -> [Packet] -> t )
-           -> ([(KeyRing.KeyKey, Packet, [Packet])] -> t)
-           -> (Packet -> t)
-           -> [(String, t)]
-tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root"
- where
-    ipsecs = do
-        (kk,ipsec,sigs) <- selectPublicKeyAndSigs (KeyUidMatch "",Just "ipsec") (rtKeyDB rt)
-        let kd = fromJust $ lookupKeyData kk (rtKeyDB rt)
-            Hostnames addr onames ns _ = getHostnames kd
-        oname <- onames
-        return ("etc/ipsec.d/certs/" ++ Char8.unpack oname ++ ".pem", pubpem ns addr ipsec sigs)
-
-    sshs = case selectPublicKeyAndSigs (KeyUidMatch "",Just "ssh-host") (rtKeyDB rt) of
-            []      -> []
-            ssh_sel -> [("etc/ssh/ssh_known_hosts", knownhosts ssh_sel)]
-
-    secrets_kd = case fst . parseSpec "" <$> (++"/") <$> spec of
-                    _ | spec == Just "-" || spec == Just ""
-                        -> maybeToList (rtWorkingKey rt)
-                            >>= return . fromJust . (`lookupKeyData` rtKeyDB rt) . keykey
-                    Just topspec
-                        -> map snd $ filterMatches topspec $ kkData $ rtKeyDB rt
-                    w -> []
-
-    lookupSecret tag kd = take 1 $ snd $ (\(y:ys) -> seek_key (KeyTag y tag) ys)
-                                 $ snd $ seek_key (KeyGrip "")
-                                 $ map packet $ flattenTop "" False kd
-
-    dir :: FilePath -> FilePath
-    dir d = d -- TODO: prepend prefix path?
-
-    spem d k = (d, secpem k)
-
-    secrets homedir = do
-        kd <- secrets_kd
-        let torkey = spem (dir "var/lib/tor/samizdat/private_key") <$> lookupSecret "tor" kd
-            sshcli = do k <- lookupSecret "ssh-client" kd
-                        keyname <- sshkeyname k
-                        return $ spem (dir $ homedir ++ "/.ssh/" ++ keyname) k
-            sshsvr = spem (dir "etc/ssh/ssh_host_rsa_key") <$> lookupSecret "ssh-host" kd
-            ipseckey = do
-                k <- lookupSecret "ipsec" kd
-                keyName <- ipsecKeyNames (getHostnames kd)
-                return $ spem (dir $ keyName) k
-        torkey ++ sshcli ++ sshsvr ++ ipseckey
-
-ipsecKeyNames :: Hostnames -> [String]
-ipsecKeyNames (Hostnames _ onames _ _) = do
-  oname <- Char8.unpack <$> onames
-  return $ "etc/ipsec.d/private/"++oname++".pem"
-
-tarT :: ([[String]],Map.Map String [String]) -> IO ()
-tarT (sargs,margs) = do
-    KikiResult rt report <- runKeyRing $ minimalOp False $ parseCommonArgs margs
-    case rt of
-      KikiSuccess rt -> do
-        let keyspec = concat . take 1 <$> Map.lookup "--secrets" margs
-            nil = error "internal error!"
-            fs = map fst $ tarContent rt keyspec nil nil nil
-        mapM_ putStrLn fs
-      err -> putStrLn $ errorString err
-
-tarC :: ([[String]],Map.Map String [String]) -> IO ()
-tarC (sargs,margs) = do
-    KikiResult rt report <- runKeyRing $ minimalOp False $ parseCommonArgs margs
-    case rt of
-      KikiSuccess rt -> do
-        CTime pubtime <- modificationTime <$> getFileStatus (rtPubring rt)
-        let keyspec = concat . take 1 <$> Map.lookup "--secrets" margs
-            pubtime64 :: Int64
-            pubtime64 = fromIntegral pubtime -- EpochTime=CTime is Int32 on some platforms
-            fs :: [(String, (Int64,Either (IO (Maybe Char8.ByteString)) Char8.ByteString))]
-            fs = tarContent rt keyspec build_ipsec (build_ssh rt pubtime64) (build_secret rt)
-            es = do
-                (n,(epoch_time_int64,ebs)) <- fs
-                let mktar' = mktar n epoch_time_int64
-                return $ case ebs of
-                    Right bs -> return $ either (const Nothing) Just $  mktar' bs
-                    Left iombs -> do
-                        mbs <- iombs
-                        case mbs of
-                            Nothing -> return Nothing
-                            Just bs -> return $ either (const Nothing) Just $ mktar' bs
-        tarbs <- Tar.write . mapMaybe id <$> sequence es
-        L.putStr tarbs
-      err -> putStrLn $ errorString err
- where
-    build_ipsec :: Num n => b -> c -> Packet -> d -> (n, Either a Char8.ByteString)
-    build_ipsec ns addr ipsec sigs
-       = ( fromIntegral $ timestamp ipsec
-         , Right $ Char8.pack $ fromJust $ pemFromPacket ipsec)
-    build_ssh rt timestamp sshs = (timestamp, Right $ Char8.unlines $ map knownhost sshs)
-     where
-        knownhost (kk,hostkey,sigs) = Char8.intercalate "," ns <> " " <> Char8.pack (sshblobFromPacket hostkey)
-         where
-            ns = onames ++ others
-            Hostnames _ onames others _ = getHostnames $ fromJust $ lookupKeyData kk (rtKeyDB rt)
-
-    build_secret :: Num t => KeyRingRuntime  -> Packet -> (t, Either (IO (Maybe Char8.ByteString)) b)
-    build_secret rt k = ( fromIntegral $ timestamp k
-                        , Left $ fmap Char8.pack . (>>= secretPemFromPacket) <$> decrypt rt k )
-
-    mktar :: FilePath -> Tar.EpochTime -> L.ByteString -> Either String Tar.Entry
-    mktar n epoch_time_int64 bs = do
-        torpath <- Tar.toTarPath False n
-        Right $ (Tar.fileEntry torpath bs) { Tar.entryTime = epoch_time_int64 }
-
-    decrypt :: KeyRingRuntime -> Packet -> IO (Maybe Packet)
-    decrypt rt k@SecretKeyPacket { symmetric_algorithm = Unencrypted } = return $ Just k
-    decrypt rt k = do
-        r <- rtPassphrases rt (Unencrypted,S2K 100 "") (MappedPacket k Map.empty)
-        case r of
-            KikiSuccess p -> return $ Just p
-            _ -> do
-                hPutStrLn stderr $ "Failed to decrypt "++show (fingerprint k) ++ "."
-                return Nothing
 -- |
 --
 -- no leading hyphen, returns Right (input string).
diff --git a/lib/KeyDB.hs b/lib/KeyDB.hs
index c92f614..fd0a9ce 100644
--- a/lib/KeyDB.hs
+++ b/lib/KeyDB.hs
@@ -71,7 +71,11 @@ newtype KeyGrip = KeyInt Int
 
 fingerprintGrip :: Fingerprint -> KeyGrip
 fingerprintGrip (Fingerprint bs) =
-    case decode $ L.fromStrict $ S.drop (S.length bs - sizeOf (0::Int)) bs of
+    -- case decode $ L.fromStrict $ S.drop (S.length bs - sizeOf (0::Int)) bs of
+    -- -- The above was removed because Int is encoded as 8 bytes even when we are
+    -- -- using 32-bit GHC.
+    -- Presumably, the extra 4 bytes will be truncated.
+    case decode $ L.fromStrict $ S.drop (S.length bs - 8) bs of
         i -> KeyInt i
 
 smallprGrip :: String -> Maybe KeyGrip
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 3da3565..5f43b4f 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -68,7 +68,7 @@ import Base58
 import FunctorToMaybe
 import DotLock
 import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )
-import           KeyRing.BuildKeyDB          (Hostnames(..),
+import           KeyRing.BuildKeyDB          (allNames', Hostnames,
                                               IPsToWriteToHostsFile(..),
                                               buildKeyDB,
                                               combineTransforms,
@@ -532,11 +532,7 @@ writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,IPsToWriteToHostsFile outg
 
     -- 3. add hostnames from gpg for addresses not in U
     let u = foldl' f u1 ans
-        ans = reverse $ do
-            Hostnames addr _ ns _ <- gpgnames
-            guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0
-            n <- ns
-            return (addr,n)
+        ans = reverse . filter ((`elem` outgoing_names) . fst) . concat $ allNames' <$> gpgnames
         f h (addr,n) = Hosts.assignNewName addr n h
 
     -- 4. for each host db H, union H with U and write it out as H'
@@ -796,8 +792,8 @@ subkeysForExport subspec (KeyData key _ _ subkeys) = do
 data PemType = PemPublicKey | PemPrivateKey | PemCertificate
 
 pemTypeString :: PemType -> String
-pemTypeString PemPublicKey  = "PUBLIC KEY"
-pemTypeString PemPrivateKey = "PRIVATE KEY"
+pemTypeString PemPublicKey   = "PUBLIC KEY"
+pemTypeString PemPrivateKey  = "RSA PRIVATE KEY"
 pemTypeString PemCertificate = "CERTIFICATE"
 
 writePEM :: PemType -> String -> String
@@ -1202,10 +1198,3 @@ getHomeDir protohome = do
                         where topair (x:xs) = (x,xs)
         return $ lookup "default-key" config >>= listToMaybe
 
-{-
-onionName :: KeyData -> (SockAddr,L.ByteString)
-onionName kd = (addr,name)
- where
-    (addr,(name:_,_)) = getHostnames kd
--}
-
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
index 587d812..3fe1d17 100644
--- a/lib/KeyRing/BuildKeyDB.hs
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DoAndIfThenElse          #-}
 {-# LANGUAGE ForeignFunctionInterface #-}
 {-# LANGUAGE LambdaCase               #-}
+{-# LANGUAGE NamedFieldPuns           #-}
 {-# LANGUAGE OverloadedStrings        #-}
 {-# LANGUAGE PatternGuards            #-}
 {-# LANGUAGE TupleSections            #-}
@@ -550,10 +551,7 @@ mergeHostFiles krd db ctx = do
     hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns
 
     let gpgnames = map getHostnames $ keyData db
-        os = do
-            Hostnames addr ns _ _ <- gpgnames
-            n <- ns
-            return (addr,n)
+        os = concat $ allNames' <$> gpgnames
         setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os
         -- we ensure .onion names are set properly
         hostdbs = map setOnions hostdbs0
@@ -864,6 +862,12 @@ generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
         return $ KikiSuccess (kd,report0)
 generateSubkey _ kd _ = return kd
 
+allNames :: Hostnames -> [Char8.ByteString]
+allNames (Hostnames _ ns os cs) = ns ++ os ++ (maybe [] return cs)
+
+allNames' :: Hostnames -> [(SockAddr, Char8.ByteString)]
+allNames' h@Hostnames{gpgipv6addr} = (gpgipv6addr,) <$> allNames h
+
 data Hostnames = Hostnames {
   gpgipv6addr :: SockAddr,
   verifiedOnionNames :: [L.ByteString],
@@ -915,7 +919,7 @@ setHostnames (IPsToWriteToHostsFile outgoing_names) hosts kd@(KeyData topmp tops
     --       when we should be removing origins from the locations
     --       field of the sig's MappedPacket records.
     -- Call getHostnames and compare to see if no-op.
-    if pred || pred2
+    if (addr `elem` outgoing_names) || (gotNonOnions == namesWithoutGotOnions)
         then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
                              , "                   file: "++show (map Char8.unpack names)
                              , "                   pred: "++show (pred addr)]) -}
@@ -931,11 +935,9 @@ setHostnames (IPsToWriteToHostsFile outgoing_names) hosts kd@(KeyData topmp tops
     -}
     return $ KeyData topmp topsigs uids1 subs
  where
-    pred = addr `elem` outgoing_names
     addr = fingerdress $ packet topmp
     names :: [Char8.ByteString]
     names = Hosts.namesForAddress addr hosts
-    pred2 = gotNonOnions == namesWithoutGotOnions
 
     Hostnames _ gotOnions gotNonOnions cryptonomic = getHostnames kd
 
diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs
index 5318b31..af213ce 100644
--- a/lib/KeyRing/Types.hs
+++ b/lib/KeyRing/Types.hs
@@ -161,7 +161,7 @@ data Transform =
         Autosign
         -- ^ This operation will make signatures for any tor-style UID
         -- that matches a tor subkey and thus can be authenticated without
-        -- requring the judgement of a human user.
+        -- requiring the judgment of a human user.
         --
         -- A tor-style UID is one of the following form:
         --
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index 64dc2bd..258892f 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -49,6 +49,7 @@ import           DotLock
 import           GnuPGAgent                 (Query (..))
 import           KeyRing hiding (pemFromPacket)
 import           KeyDB
+import           KeyRing.BuildKeyDB (gpgipv6addr, Hostnames, allNames)
 
 withAgent :: [PassphraseSpec] -> [PassphraseSpec]
 withAgent [] = [PassphraseAgent]
@@ -448,9 +449,6 @@ generateHostsFile fw rt      = do
     KikiResult _ report <- runKeyRing op
     outputReport report
 
-allNames :: Hostnames -> [Char8.ByteString]
-allNames (Hostnames _ ns os cs) = ns ++ os ++ (maybe [] return cs)
-
 getSshKnownHosts :: Peer -> Char8.ByteString
 getSshKnownHosts peer@Peer{kd} = Char8.unlines taggedblobs
   where
@@ -496,7 +494,7 @@ installIpsecConf fw MyIdentity{myGpgAddress} cs = do
 getMyIdentity :: KeyRingRuntime -> Maybe MyIdentity
 getMyIdentity rt = do
     wk <- rtWorkingKey rt
-    Hostnames wkaddr _ _ _ <- getHostnames <$> lookupKeyData (keykey wk) (rtKeyDB rt)
+    wkaddr <- gpgipv6addr . getHostnames <$> lookupKeyData (keykey wk) (rtKeyDB rt)
     return $ MyIdentity wkaddr (show $ fingerprint wk)
 
 refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO ()
@@ -734,16 +732,24 @@ verifyFile isHomeless cap keyrings filename = do
                     Right sigs -> do
                         let over = DataSignature lit sigs
                             lit = LiteralDataPacket
-                                    { format    = error "format" :: Char
+                                    { format    = error "format" :: Char -- TODO
                                     , filename  = filename
-                                    , timestamp = error "timestamp" :: Word32
-                                    , content   = bs
+                                    , timestamp = error "timestamp" :: Word32 -- TODO
+                                    , content   = txt
                                     }
                             -- TODO: Remove this take 1 after optimizing 'candidateSignerKeys'
                             tentativeTake1 xs = take 1 xs
                             keys = concatMap (candidateSignerKeys (rtKeyDB rt)) $ tentativeTake1 sigs
                             good = verify (Message keys) over
-                        putStrLn $ "verifyFile: " ++ show (length $ signatures_over good)
+                        putStrLn $ unwords
+                            [ "verifyFile:"
+                            , show (length $ signatures_over good)
+                            , "good of"
+                            , show (length $ signatures_over over)
+                            , "signatures."
+                            ]
+                        -- when (null (signatures_over good)) $ do
+                        --    L.putStrLn txt
                     rs -> do
                         hPutStrLn stderr $ show rs
             _ -> do
diff --git a/lib/Transforms.hs b/lib/Transforms.hs
index f3cd5e3..8a1da73 100644
--- a/lib/Transforms.hs
+++ b/lib/Transforms.hs
@@ -79,8 +79,7 @@ instance ASN1Object RSAPublicKey where
     fromASN1 (Start Sequence:IntVal n:IntVal e:End Sequence:xs) =
         Right (RSAKey (MPI n) (MPI e), xs)
 
-    fromASN1 _ = 
-        Left "fromASN1: RSAPublicKey: unexpected format"
+    fromASN1 _ = Left "fromASN1: RSAPublicKey: unexpected format"
 
 
 -- | This type is used to describe events triggered by 'runKeyRing'.  In
@@ -778,7 +777,7 @@ selfAuthenticated k kd (UidString str) =
   and [ uid_topdomain parsed == "onion"
       , uid_realname parsed `elem` ["","Anonymous"]
       , uid_user parsed == "root"
-      , fmap (match . fst) (lookup (packet k) torbindings) == Just True
+      , fmap match torSubdom == Just True
       ]
   where
     parsed      = parseUID str
@@ -786,6 +785,7 @@ selfAuthenticated k kd (UidString str) =
     len         = T.length (uid_subdomain parsed)
     subdom0     = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
     subdom      = Char8.unpack subdom0
+    torSubdom   = fst <$> lookup (packet k) torbindings
     torbindings = getTorKeys (map packet $ flattenTop "" True kd)
 
 getTorKeys :: [Packet] -> [(Packet, (String, Packet))]
diff --git a/stack.yaml b/stack.yaml
index 26641d9..f820baf 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,6 +1,8 @@
 resolver: lts-14.2
 packages:
-- .
+- '.'
 extra-deps:
-  - git: d@cryptonomic.net:public_git/openpgp-util.git
-    commit: bb3a9e181638fa881e2bcd8425f10cfb365533f5
+- git: d@cryptonomic.net:public_git/openpgp-util.git
+  commit: bb3a9e181638fa881e2bcd8425f10cfb365533f5
+- git: d@cryptonomic.net:public_git/openpgp-asciiarmor.git
+  commit: 9694b1b6ae3763c44d3b1361b5faa0a7b27e77a9