diff options
author | joe <joe@jerkface.net> | 2016-04-25 20:20:45 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2016-04-25 20:20:45 -0400 |
commit | 6860098ed8f8b56eb5058e0c9c427abaa57021bf (patch) | |
tree | defc0ae2c6bcd08f489628be0633f99e6254a218 /kiki.hs | |
parent | 3c8536fd92043283d20b9e19ae488e7fe64af236 (diff) |
more work on cokiki (ssh-client)
Diffstat (limited to 'kiki.hs')
-rw-r--r-- | kiki.hs | 124 |
1 files changed, 1 insertions, 123 deletions
@@ -66,14 +66,9 @@ import qualified SSHKey as SSH | |||
66 | import Text.Printf | 66 | import Text.Printf |
67 | import qualified DNSKey as DNS | 67 | import qualified DNSKey as DNS |
68 | import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) | 68 | import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) |
69 | import Kiki | ||
69 | import Debug.Trace | 70 | import Debug.Trace |
70 | 71 | ||
71 | #if !MIN_VERSION_base(4,8,0) | ||
72 | sortOn :: Ord b => (a -> b) -> [a] -> [a] | ||
73 | sortOn f = | ||
74 | map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) | ||
75 | #endif | ||
76 | |||
77 | -- {-# ANN module ("HLint: ignore Eta reduce"::String) #-} | 72 | -- {-# ANN module ("HLint: ignore Eta reduce"::String) #-} |
78 | -- {-# ANN module ("HLint: ignore Use camelCase"::String) #-} | 73 | -- {-# ANN module ("HLint: ignore Use camelCase"::String) #-} |
79 | 74 | ||
@@ -134,8 +129,6 @@ sortOn f = | |||
134 | - | 129 | - |
135 | -} | 130 | -} |
136 | 131 | ||
137 | warn str = hPutStrLn stderr str | ||
138 | |||
139 | 132 | ||
140 | isCertificationSig (CertificationSignature {}) = True | 133 | isCertificationSig (CertificationSignature {}) = True |
141 | isCertificationSig _ = True | 134 | isCertificationSig _ = True |
@@ -307,21 +300,6 @@ show_whose_key input_key db = | |||
307 | 300 | ||
308 | show_dns keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db dnsPresentationFromPacket | 301 | show_dns keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db dnsPresentationFromPacket |
309 | 302 | ||
310 | show_pem keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db pemFromPacket | ||
311 | |||
312 | show_pem' keyspec wkgrip db keyfmt = do | ||
313 | let s = parseSpec wkgrip keyspec | ||
314 | flip (maybe . Left $ keyspec ++ ": not found") | ||
315 | (selectPublicKey s db) | ||
316 | keyfmt | ||
317 | |||
318 | pemFromPacket k = do | ||
319 | let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k | ||
320 | der = encodeASN1 DER (toASN1 rsa []) | ||
321 | qq = Base64.encode (L.unpack der) | ||
322 | return $ | ||
323 | writePEM "PUBLIC KEY" qq -- ("TODO "++show keyspec) | ||
324 | |||
325 | dnsPresentationFromPacket k = do | 303 | dnsPresentationFromPacket k = do |
326 | let RSAKey (MPI n) (MPI e) = fromJust $ rsaKeyFromPacket k | 304 | let RSAKey (MPI n) (MPI e) = fromJust $ rsaKeyFromPacket k |
327 | dnskey = DNS.RSA n e | 305 | dnskey = DNS.RSA n e |
@@ -341,20 +319,6 @@ dnsPresentationFromPacket k = do | |||
341 | 319 | ||
342 | ] | 320 | ] |
343 | 321 | ||
344 | show_ssh keyspec wkgrip db = either warn putStrLn $ show_ssh' keyspec wkgrip db | ||
345 | |||
346 | show_ssh' keyspec wkgrip db = do | ||
347 | let s = parseSpec wkgrip keyspec | ||
348 | flip (maybe . Left $ keyspec ++ ": not found") | ||
349 | (selectPublicKey s db) | ||
350 | $ return . sshblobFromPacket | ||
351 | |||
352 | sshblobFromPacket k = blob | ||
353 | where | ||
354 | Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k | ||
355 | bs = SSH.keyblob (n,e) | ||
356 | blob = Char8.unpack bs | ||
357 | |||
358 | show_id keyspec wkgrip db = do | 322 | show_id keyspec wkgrip db = do |
359 | let s = parseSpec "" keyspec | 323 | let s = parseSpec "" keyspec |
360 | let ps = do | 324 | let ps = do |
@@ -1029,8 +993,6 @@ processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs) | |||
1029 | else error . unlines $ [ "unrecognized option "++k | 993 | else error . unlines $ [ "unrecognized option "++k |
1030 | , "Use --help for usage." ] | 994 | , "Use --help for usage." ] |
1031 | 995 | ||
1032 | data CommonArgsParsed = CommonArgsParsed { cap_homespec :: Maybe String, cap_passfd :: Maybe InputFile } | ||
1033 | |||
1034 | parseCommonArgs margs = CommonArgsParsed { cap_homespec = homespec, cap_passfd = passfd } | 996 | parseCommonArgs margs = CommonArgsParsed { cap_homespec = homespec, cap_passfd = passfd } |
1035 | where | 997 | where |
1036 | passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs | 998 | passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs |
@@ -1658,55 +1620,6 @@ kiki "tar" args = do | |||
1658 | ["-A":_] -> putStrLn "unimplemented." -- import tar file? | 1620 | ["-A":_] -> putStrLn "unimplemented." -- import tar file? |
1659 | _ -> kiki "tar" ["--help"] | 1621 | _ -> kiki "tar" ["--help"] |
1660 | 1622 | ||
1661 | refreshCache rt rootdir = do | ||
1662 | |||
1663 | let mkpath pth = fromMaybe "" rootdir ++ "/var/cache/kiki/"++pth | ||
1664 | |||
1665 | write f bs = do | ||
1666 | createDirectoryIfMissing True $ takeDirectory f | ||
1667 | writeFile f bs | ||
1668 | |||
1669 | let oname' = do wk <- rtWorkingKey rt | ||
1670 | -- XXX unnecessary signature check | ||
1671 | onionNameForContact (keykey wk) (rtKeyDB rt) | ||
1672 | bUnprivileged = False -- TODO | ||
1673 | if (oname' == Nothing) && (not bUnprivileged) then error "Missing tor key" else do | ||
1674 | let oname = fromMaybe "" oname' | ||
1675 | -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </> "id_rsa.pub" | ||
1676 | -- sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub" | ||
1677 | -- contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem" | ||
1678 | |||
1679 | -- Finally, export public keys if they do not exist. | ||
1680 | flip (maybe $ warn "missing working key?") (rtGrip rt) $ \grip -> do | ||
1681 | either warn (write $ mkpath "root/.ssh/id_rsa.pub") | ||
1682 | $ show_ssh' "ssh-client" grip (rtKeyDB rt) | ||
1683 | either warn (write $ mkpath "ssh_host_rsa_key.pub") | ||
1684 | $ show_ssh' "ssh-server" grip (rtKeyDB rt) | ||
1685 | either warn (write $ mkpath "ipsec.d/certs/" ++ oname++".pem") | ||
1686 | $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket | ||
1687 | |||
1688 | let cs = filter notme (Map.elems $ rtKeyDB rt) | ||
1689 | kk = keykey (fromJust $ rtWorkingKey rt) | ||
1690 | notme kd = keykey (keyPacket kd) /= kk | ||
1691 | |||
1692 | installConctact kd = do | ||
1693 | -- The getHostnames command requires a valid cross-signed tor key | ||
1694 | -- for each onion name returned in (_,(ns,_)). | ||
1695 | let (_,(ns,_)) = getHostnames kd | ||
1696 | contactname = fmap Char8.unpack $ listToMaybe ns -- only first onion name. | ||
1697 | flip (maybe $ return ()) contactname $ \contactname -> do | ||
1698 | |||
1699 | let cpath = interp (Map.singleton "onion" contactname) "ipsec.d/certs/%(onion).pem" | ||
1700 | their_master = packet $ keyMappedPacket kd | ||
1701 | -- We find all cross-certified ipsec keys for the given cross-certified onion name. | ||
1702 | ipsecs = sortOn (Down . timestamp) | ||
1703 | $ getCrossSignedSubkeys their_master (keySubKeys kd) "ipsec" | ||
1704 | forM_ (take 1 ipsecs) $ \k -> do | ||
1705 | either warn (write $ mkpath cpath) $ pemFromPacket k | ||
1706 | |||
1707 | mapM_ installConctact cs | ||
1708 | |||
1709 | |||
1710 | tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root" | 1623 | tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root" |
1711 | where | 1624 | where |
1712 | ipsecs = do | 1625 | ipsecs = do |
@@ -1811,27 +1724,6 @@ tarC (sargs,margs) = do | |||
1811 | hPutStrLn stderr $ "Failed to decrypt "++fingerprint k++"." | 1724 | hPutStrLn stderr $ "Failed to decrypt "++fingerprint k++"." |
1812 | return Nothing | 1725 | return Nothing |
1813 | 1726 | ||
1814 | minimalOp :: CommonArgsParsed -> KeyRingOperation | ||
1815 | minimalOp cap = op | ||
1816 | where | ||
1817 | streaminfo = StreamInfo { fill = KF_None | ||
1818 | , typ = KeyRingFile | ||
1819 | , spill = KF_All | ||
1820 | , initializer = NoCreate | ||
1821 | , access = AutoAccess | ||
1822 | , transforms = [] | ||
1823 | } | ||
1824 | op = KeyRingOperation | ||
1825 | { opFiles = Map.fromList $ | ||
1826 | [ ( HomeSec, streaminfo { access = Sec }) | ||
1827 | , ( HomePub, streaminfo { access = Pub }) | ||
1828 | ] | ||
1829 | , opPassphrases = do pfile <- maybeToList (cap_passfd cap) | ||
1830 | return $ PassphraseSpec Nothing Nothing pfile | ||
1831 | , opTransforms = [] | ||
1832 | , opHome = cap_homespec cap | ||
1833 | } | ||
1834 | |||
1835 | -- | | 1727 | -- | |
1836 | -- | 1728 | -- |
1837 | -- no leading hyphen, returns Right (input string). | 1729 | -- no leading hyphen, returns Right (input string). |
@@ -1872,20 +1764,6 @@ commands = | |||
1872 | , ( "tar", "import or export system key files in tar format" ) | 1764 | , ( "tar", "import or export system key files in tar format" ) |
1873 | ] | 1765 | ] |
1874 | 1766 | ||
1875 | -- | | ||
1876 | -- interpolate %var patterns in a string. | ||
1877 | interp vars raw = es >>= interp1 | ||
1878 | where | ||
1879 | gs = groupBy (\_ c -> c/='%') raw | ||
1880 | es = dropWhile null $ gobbleEscapes ("":gs) | ||
1881 | where gobbleEscapes :: [String] -> [String] | ||
1882 | gobbleEscapes (a:"%":b:bs) = (a++b) : gobbleEscapes bs | ||
1883 | gobbleEscapes (g:gs) = g : gobbleEscapes gs | ||
1884 | gobbleEscapes [] = [] | ||
1885 | interp1 ('%':'(':str) = fromMaybe "" (Map.lookup key vars) ++ drop 1 rest | ||
1886 | where (key,rest) = break (==')') str | ||
1887 | interp1 plain = plain | ||
1888 | |||
1889 | main = do | 1767 | main = do |
1890 | dotlock_init | 1768 | dotlock_init |
1891 | args_raw <- getArgs | 1769 | args_raw <- getArgs |