summaryrefslogtreecommitdiff
path: root/kiki.hs
diff options
context:
space:
mode:
authorJoe Crayne <joe@jerkface.net>2019-07-06 17:26:54 -0400
committerJoe Crayne <joe@jerkface.net>2019-07-06 17:26:54 -0400
commitb1ae1ecdc9d1f16134ea40b07a6cedcc26a94db8 (patch)
treeb46ce0c50abb65fdff3a80f5f072b9010c05294e /kiki.hs
parentea924c53e6ecb2148747353ce34ae7b0ea416d8c (diff)
Quiet down some of the warnings.
Diffstat (limited to 'kiki.hs')
-rw-r--r--kiki.hs24
1 files changed, 17 insertions, 7 deletions
diff --git a/kiki.hs b/kiki.hs
index 6a62312..47462a7 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -122,6 +122,7 @@ listKeysFiltered grips pkts = do
122 subs0 <- map Left gs ++ map Right singles 122 subs0 <- map Left gs ++ map Right singles
123 let (top,subs) = case subs0 of Left subs1@((_,(top0,_),_,_,_):_) -> (top0,subs1) 123 let (top,subs) = case subs0 of Left subs1@((_,(top0,_),_,_,_):_) -> (top0,subs1)
124 Right top0 -> (top0,[]) 124 Right top0 -> (top0,[])
125 Left [] -> error "groupBy returned an empty group?"
125 let subkeys = do 126 let subkeys = do
126 (code,(top,sub), kind, hashed,claimants) <- subs 127 (code,(top,sub), kind, hashed,claimants) <- subs
127 let ar = case code of 128 let ar = case code of
@@ -129,6 +130,7 @@ listKeysFiltered grips pkts = do
129 1 -> " --> " 130 1 -> " --> "
130 2 -> " <-- " 131 2 -> " <-- "
131 3 -> " <-> " 132 3 -> " <-> "
133 _ -> error "Unknown signature scenario."
132 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' ' 134 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' '
133 -- torhash = fromMaybe "" $ derToBase32 <$> derRSA sub 135 -- torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
134 (netid,kind') = maybe (0x0,"bitcoin") 136 (netid,kind') = maybe (0x0,"bitcoin")
@@ -656,6 +658,7 @@ kiki_usage ((== Export) -> bExport) ((== Import) -> bImport) ((== Secret) -> bSe
656 ,"" 658 ,""
657 ] ++ syncflags ++ specifyingFiles 659 ] ++ syncflags ++ specifyingFiles
658 "spec" -> unlines keyspec 660 "spec" -> unlines keyspec
661 x -> "Undocumented command "++show x++"."
659 where 662 where
660 commonOptions :: [String] 663 commonOptions :: [String]
661 commonOptions = 664 commonOptions =
@@ -1149,13 +1152,14 @@ moreMoreSync kikiOp sargs = do
1149 1152
1150doTransform :: [String] -> ([String]->[Transform]) -> IO () 1153doTransform :: [String] -> ([String]->[Transform]) -> IO ()
1151doTransform args mktrans = do 1154doTransform args mktrans = do
1152 let (sargs,margs) = processArgs sargspec polyVariadicArgs "---" args 1155 let (_,margs) = processArgs sargspec polyVariadicArgs "---" args
1153 where sargspec = [] 1156 where sargspec = []
1154 polyVariadicArgs = ["---"] 1157 polyVariadicArgs = ["---"]
1155 passfd = fmap (FileDesc . read) passphrase_fd 1158 passfd = fmap (FileDesc . read) passphrase_fd
1156 where passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs 1159 where passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
1157 targs = fromMaybe [] $ Map.lookup "---" margs 1160 targs = fromMaybe [] $ Map.lookup "---" margs
1158 homespec = join . take 1 <$> Map.lookup "--homedir" margs 1161 homespec = join . take 1 <$> Map.lookup "--homedir" margs
1162 ts = mktrans targs
1159 kikiOp = KeyRingOperation 1163 kikiOp = KeyRingOperation
1160 { opFiles = Map.fromList $ 1164 { opFiles = Map.fromList $
1161 [ ( HomeSec, buildStreamInfo KF_All KeyRingFile ) 1165 [ ( HomeSec, buildStreamInfo KF_All KeyRingFile )
@@ -1163,10 +1167,11 @@ doTransform args mktrans = do
1163 ] 1167 ]
1164 , opPassphrases = withAgent $ do pfile <- maybeToList passfd 1168 , opPassphrases = withAgent $ do pfile <- maybeToList passfd
1165 return $ PassphraseSpec Nothing Nothing pfile 1169 return $ PassphraseSpec Nothing Nothing pfile
1166 , opTransforms = mktrans targs 1170 , opTransforms = ts
1167 , opHome = homespec 1171 , opHome = homespec
1168 } 1172 }
1169 KikiResult rt report <- runKeyRing kikiOp 1173 KikiResult rt report <- if null ts then return $ KikiResult OperationCanceled []
1174 else runKeyRing kikiOp
1170 forM_ report $ \(fname,act) -> do 1175 forM_ report $ \(fname,act) -> do
1171 putStrLn $ fname ++ ": " ++ reportString act 1176 putStrLn $ fname ++ ": " ++ reportString act
1172 case rt of 1177 case rt of
@@ -1595,6 +1600,7 @@ kiki "rename" args | "--help" `elem` args = do
1595 1600
1596kiki "rename" args = doTransform args rename 1601kiki "rename" args = doTransform args rename
1597 where rename (oldtag:newtag:_) = [ RenameSubkeys oldtag newtag ] 1602 where rename (oldtag:newtag:_) = [ RenameSubkeys oldtag newtag ]
1603 rename _ = []
1598 1604
1599kiki "tar" args | "--help" `elem` args = do 1605kiki "tar" args | "--help" `elem` args = do
1600 putStr . unlines $ 1606 putStr . unlines $
@@ -1641,6 +1647,12 @@ kiki "tar" args = do
1641 ["-A":_] -> putStrLn "unimplemented." -- import tar file? 1647 ["-A":_] -> putStrLn "unimplemented." -- import tar file?
1642 _ -> kiki "tar" ["--help"] 1648 _ -> kiki "tar" ["--help"]
1643 1649
1650kiki cmd args = hPutStrLn stderr $ "I don't know how to "++cmd++"."
1651
1652sshkeyname :: Packet -> [FilePath]
1653sshkeyname SecretKeyPacket { key_algorithm = RSA } = ["id_rsa"]
1654sshkeyname _ = []
1655
1644 1656
1645tarContent :: KeyRingRuntime 1657tarContent :: KeyRingRuntime
1646 -> Maybe String 1658 -> Maybe String
@@ -1653,7 +1665,6 @@ tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root"
1653 ipsecs = do 1665 ipsecs = do
1654 (kk,ipsec,sigs) <- selectPublicKeyAndSigs (KeyUidMatch "",Just "ipsec") (rtKeyDB rt) 1666 (kk,ipsec,sigs) <- selectPublicKeyAndSigs (KeyUidMatch "",Just "ipsec") (rtKeyDB rt)
1655 let kd = (rtKeyDB rt Map.! kk) 1667 let kd = (rtKeyDB rt Map.! kk)
1656 k = packet $ keyMappedPacket kd
1657 (addr,(onames,ns)) = getHostnames kd 1668 (addr,(onames,ns)) = getHostnames kd
1658 oname <- onames 1669 oname <- onames
1659 return ("etc/ipsec.d/certs/" ++ Char8.unpack oname ++ ".pem", pubpem ns addr ipsec sigs) 1670 return ("etc/ipsec.d/certs/" ++ Char8.unpack oname ++ ".pem", pubpem ns addr ipsec sigs)
@@ -1673,8 +1684,6 @@ tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root"
1673 where 1684 where
1674 m = Map.singleton (keykey $ keyPacket kd) kd 1685 m = Map.singleton (keykey $ keyPacket kd) kd
1675 1686
1676 sshkeyname SecretKeyPacket { key_algorithm = RSA } = "id_rsa"
1677
1678 dir :: FilePath -> FilePath 1687 dir :: FilePath -> FilePath
1679 dir d = d -- TODO: prepend prefix path? 1688 dir d = d -- TODO: prepend prefix path?
1680 1689
@@ -1684,7 +1693,8 @@ tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root"
1684 kd <- secrets_kd 1693 kd <- secrets_kd
1685 let torkey = spem (dir "var/lib/tor/samizdat/private_key") <$> lookupSecret "tor" kd 1694 let torkey = spem (dir "var/lib/tor/samizdat/private_key") <$> lookupSecret "tor" kd
1686 sshcli = do k <- lookupSecret "ssh-client" kd 1695 sshcli = do k <- lookupSecret "ssh-client" kd
1687 return $ spem (dir $ homedir ++ "/.ssh/" ++ sshkeyname k) k 1696 keyname <- sshkeyname k
1697 return $ spem (dir $ homedir ++ "/.ssh/" ++ keyname) k
1688 sshsvr = spem (dir "etc/ssh/ssh_host_rsa_key") <$> lookupSecret "ssh-host" kd 1698 sshsvr = spem (dir "etc/ssh/ssh_host_rsa_key") <$> lookupSecret "ssh-host" kd
1689 ipseckey = do 1699 ipseckey = do
1690 k <- lookupSecret "ipsec" kd 1700 k <- lookupSecret "ipsec" kd