diff options
author | joe <joe@jerkface.net> | 2016-04-23 00:35:03 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2016-04-23 00:35:03 -0400 |
commit | 64202f804429053058ac3efce527f77c2e12948b (patch) | |
tree | cf301c570fa9b2266abd8def3106805c970040bc /kiki.hs | |
parent | f11640aecb9ba8e1693bcc8fa80a53dc5feb2bac (diff) |
WIP: tar command.
Diffstat (limited to 'kiki.hs')
-rw-r--r-- | kiki.hs | 208 |
1 files changed, 197 insertions, 11 deletions
@@ -17,18 +17,24 @@ import Data.Binary | |||
17 | import Data.Bits | 17 | import Data.Bits |
18 | import Data.Char | 18 | import Data.Char |
19 | import Data.IORef | 19 | import Data.IORef |
20 | import Data.Int | ||
20 | import Data.List | 21 | import Data.List |
21 | import Data.Maybe | 22 | import Data.Maybe |
22 | import Data.OpenPGP | 23 | import Data.OpenPGP |
23 | import Data.Ord | 24 | import Data.Ord |
24 | import Data.Text.Encoding | 25 | import Data.Text.Encoding |
25 | import System.Posix.User | 26 | import System.Posix.User |
27 | import System.Posix.Files | ||
28 | import System.Posix.Types | ||
26 | import System.FilePath.Posix | 29 | import System.FilePath.Posix |
30 | import Foreign.C.Types (CTime(..)) | ||
27 | import System.Directory | 31 | import System.Directory |
28 | import System.Environment | 32 | import System.Environment |
29 | import System.Exit | 33 | import System.Exit |
30 | import System.IO (hPutStrLn,stderr) | 34 | import System.IO (hPutStrLn,stderr) |
31 | import qualified Codec.Binary.Base64 as Base64 | 35 | import qualified Codec.Binary.Base64 as Base64 |
36 | import qualified Codec.Archive.Tar as Tar | ||
37 | import qualified Codec.Archive.Tar.Entry as Tar | ||
32 | #if !defined(VERSION_cryptonite) | 38 | #if !defined(VERSION_cryptonite) |
33 | import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 | 39 | import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 |
34 | import qualified Crypto.Hash.SHA256 as SHA256 | 40 | import qualified Crypto.Hash.SHA256 as SHA256 |
@@ -42,7 +48,6 @@ import qualified Data.ByteString.Lazy as L | |||
42 | import qualified Data.ByteString.Lazy.Char8 as Char8 | 48 | import qualified Data.ByteString.Lazy.Char8 as Char8 |
43 | import qualified Data.Map as Map | 49 | import qualified Data.Map as Map |
44 | import Control.Arrow (first,second) | 50 | import Control.Arrow (first,second) |
45 | import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) | ||
46 | import Data.Monoid ( (<>) ) | 51 | import Data.Monoid ( (<>) ) |
47 | import Data.Binary.Put | 52 | import Data.Binary.Put |
48 | 53 | ||
@@ -58,6 +63,8 @@ import ProcessUtils | |||
58 | import qualified SSHKey as SSH | 63 | import qualified SSHKey as SSH |
59 | import Text.Printf | 64 | import Text.Printf |
60 | import qualified DNSKey as DNS | 65 | import qualified DNSKey as DNS |
66 | import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) | ||
67 | import Debug.Trace | ||
61 | 68 | ||
62 | -- {-# ANN module ("HLint: ignore Eta reduce"::String) #-} | 69 | -- {-# ANN module ("HLint: ignore Eta reduce"::String) #-} |
63 | -- {-# ANN module ("HLint: ignore Use camelCase"::String) #-} | 70 | -- {-# ANN module ("HLint: ignore Use camelCase"::String) #-} |
@@ -329,11 +336,13 @@ show_ssh' keyspec wkgrip db = do | |||
329 | let s = parseSpec wkgrip keyspec | 336 | let s = parseSpec wkgrip keyspec |
330 | flip (maybe . Left $ keyspec ++ ": not found") | 337 | flip (maybe . Left $ keyspec ++ ": not found") |
331 | (selectPublicKey s db) | 338 | (selectPublicKey s db) |
332 | $ \k -> do | 339 | $ return . sshblobFromPacket |
333 | let Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k | 340 | |
334 | bs = SSH.keyblob (n,e) | 341 | sshblobFromPacket k = blob |
335 | blob = Char8.unpack bs | 342 | where |
336 | return blob | 343 | Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k |
344 | bs = SSH.keyblob (n,e) | ||
345 | blob = Char8.unpack bs | ||
337 | 346 | ||
338 | show_id keyspec wkgrip db = do | 347 | show_id keyspec wkgrip db = do |
339 | let s = parseSpec "" keyspec | 348 | let s = parseSpec "" keyspec |
@@ -376,7 +385,7 @@ show_cert keyspec wkgrip db = do | |||
376 | let s = parseSpec wkgrip keyspec | 385 | let s = parseSpec wkgrip keyspec |
377 | case selectPublicKeyAndSigs s db of | 386 | case selectPublicKeyAndSigs s db of |
378 | [] -> void $ warn (keyspec ++ ": not found") | 387 | [] -> void $ warn (keyspec ++ ": not found") |
379 | [(k,sigs)] -> do | 388 | [(_,k,sigs)] -> do |
380 | {- | 389 | {- |
381 | let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k | 390 | let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k |
382 | der = encodeASN1 DER (toASN1 rsa []) | 391 | der = encodeASN1 DER (toASN1 rsa []) |
@@ -944,9 +953,27 @@ documentHostsOption bExport bImport bSecret = | |||
944 | ," but they are currently NOT signed and may be altered in" | 953 | ," but they are currently NOT signed and may be altered in" |
945 | ," transit." | 954 | ," transit." |
946 | ,""] | 955 | ,""] |
947 | |||
948 | |||
949 | 956 | ||
957 | |||
958 | |||
959 | -- | | ||
960 | -- Arguments: | ||
961 | -- | ||
962 | -- * option-count pairs - List of option names paired with number of expected values to follow them. | ||
963 | -- | ||
964 | -- * polyvariadic options - List of option names that can take any number of arguments. | ||
965 | -- | ||
966 | -- * default polyvariadic - Implicit polyvariadic option if no other option is specified. | ||
967 | -- | ||
968 | -- * arguments - list of arguments to be parsed. | ||
969 | -- | ||
970 | -- Returns: | ||
971 | -- | ||
972 | -- * (non-variadic only) options and corresponding arguemnts in list of lists form. | ||
973 | -- | ||
974 | -- * (variadic only) map of option name to argument lists. | ||
975 | -- | ||
976 | processArgs :: [(String,Int)] -> [String] -> String -> [String] -> ([[String]],Map.Map String [String]) | ||
950 | processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs) | 977 | processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs) |
951 | where | 978 | where |
952 | (args,trail1) = break (=="--") args_raw | 979 | (args,trail1) = break (=="--") args_raw |
@@ -962,7 +989,7 @@ processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs) | |||
962 | gargs) | 989 | gargs) |
963 | where (sargs,vargs) = partitionStaticArguments sargspec' args | 990 | where (sargs,vargs) = partitionStaticArguments sargspec' args |
964 | argspec = map fst sargspec' ++ polyVariadicArgs | 991 | argspec = map fst sargspec' ++ polyVariadicArgs |
965 | args' = if map (take 1) (take 1 vargs) == ["-"] | 992 | args' = if null defaultPoly || map (take 1) (take 1 vargs) == ["-"] |
966 | then vargs | 993 | then vargs |
967 | else defaultPoly:vargs | 994 | else defaultPoly:vargs |
968 | -- grouped args | 995 | -- grouped args |
@@ -1175,7 +1202,7 @@ kiki "show" args = do | |||
1175 | , ("--torhash",1) | 1202 | , ("--torhash",1) |
1176 | ] | 1203 | ] |
1177 | polyVariadicArgs = ["--show"] | 1204 | polyVariadicArgs = ["--show"] |
1178 | let cap = parseCommonArgs margs | 1205 | let cap = parseCommonArgs margs |
1179 | homespec = cap_homespec cap | 1206 | homespec = cap_homespec cap |
1180 | passfd = cap_passfd cap | 1207 | passfd = cap_passfd cap |
1181 | pems = [] | 1208 | pems = [] |
@@ -1592,6 +1619,164 @@ kiki "delete" args = do | |||
1592 | forM_ report $ \(fname,act) -> do | 1619 | forM_ report $ \(fname,act) -> do |
1593 | putStrLn $ fname ++ ": " ++ reportString act | 1620 | putStrLn $ fname ++ ": " ++ reportString act |
1594 | 1621 | ||
1622 | kiki "tar" args | "--help" `elem` args = do | ||
1623 | putStr . unlines $ | ||
1624 | [ "kiki tar (-c|-A|-t) [--secrets SPEC] [--passphrase-fd FD] [--homedir HOMEDIR]" | ||
1625 | , "" | ||
1626 | , "Import or export a tar archive containing key files in the proper" | ||
1627 | , "format for software configuration." | ||
1628 | , "" | ||
1629 | ," -c Generate tar archive on stdout." | ||
1630 | ,"" | ||
1631 | ," -A Read tar archive on stdin." | ||
1632 | ,"" | ||
1633 | ," -t List filepaths that would be included in the (-c) output archive." | ||
1634 | ,"" | ||
1635 | ," --secrets SPEC" | ||
1636 | ," Include secret keys for the specified identity." | ||
1637 | ," Otherwise, only public keys are included." | ||
1638 | ,"" | ||
1639 | ," SPEC is matched against the following forms in order:" | ||
1640 | ,"" | ||
1641 | ," -" | ||
1642 | ," (current working identity)" | ||
1643 | ,"" | ||
1644 | ," fp:4A39F" | ||
1645 | ," (tail end of a fingerprint prefixed by 'fp:')" | ||
1646 | ,"" | ||
1647 | ," u:joe" | ||
1648 | ," (sub-string of a user id prefixed by 'u:')" | ||
1649 | ,"" | ||
1650 | ," 5E24CD442AA6965D2012E62A905C24185D5379C2" | ||
1651 | ," (fingerprint as 40 characters of hexidecimal)" | ||
1652 | ,"" | ||
1653 | ," joe" | ||
1654 | ," (sub-string of a user id without 'u:' prefix)" | ||
1655 | ] | ||
1656 | |||
1657 | kiki "tar" args = do | ||
1658 | let parsed_args = processArgs sargspec [] "" args | ||
1659 | sargspec = [("-t",0),("-c",0),("-A",0),("-C",1),("--secrets",1)] | ||
1660 | ismode ("-t":_) = True | ||
1661 | ismode ("-c":_) = True | ||
1662 | ismode ("-A":_) = True | ||
1663 | ismode _ = False | ||
1664 | case filter ismode (fst parsed_args) of | ||
1665 | ["-t":_] -> tarT parsed_args | ||
1666 | ["-c":_] -> tarC parsed_args | ||
1667 | ["-A":_] -> putStrLn "unimplemented." | ||
1668 | _ -> kiki "tar" ["--help"] | ||
1669 | |||
1670 | tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root" | ||
1671 | where | ||
1672 | ipsecs = do | ||
1673 | (kk,ipsec,sigs) <- selectPublicKeyAndSigs (KeyUidMatch "",Just "strongswan") (rtKeyDB rt) | ||
1674 | let kd = (rtKeyDB rt Map.! kk) | ||
1675 | k = packet $ keyMappedPacket kd | ||
1676 | (addr,(onames,ns)) = getHostnames kd | ||
1677 | oname <- onames | ||
1678 | return ("etc/ipsec.d/certs/" ++ Char8.unpack oname ++ ".pem", pubpem ns addr ipsec sigs) | ||
1679 | |||
1680 | sshs = case selectPublicKeyAndSigs (KeyUidMatch "",Just "ssh-host") (rtKeyDB rt) of | ||
1681 | [] -> [] | ||
1682 | ssh_sel -> [("etc/ssh/ssh_known_hosts", knownhosts ssh_sel)] | ||
1683 | |||
1684 | secrets_kd = case fst . parseSpec "" <$> (++"/") <$> spec of | ||
1685 | _ | spec == Just "-" || spec == Just "" | ||
1686 | -> maybeToList (rtWorkingKey rt) >>= return . (Map.!) (rtKeyDB rt) . keykey | ||
1687 | Just topspec | ||
1688 | -> map snd $ filterMatches topspec $ Map.toList $ rtKeyDB rt | ||
1689 | w -> [] | ||
1690 | |||
1691 | lookupSecret tag kd = maybeToList $ selectSecretKey (KeyGrip "",Just tag) m | ||
1692 | where | ||
1693 | m = Map.singleton (keykey $ keyPacket kd) kd | ||
1694 | |||
1695 | sshkeyname SecretKeyPacket { key_algorithm = RSA } = "id_rsa" | ||
1696 | |||
1697 | dir :: FilePath -> FilePath | ||
1698 | dir d = d -- TODO: prepend prefix path? | ||
1699 | |||
1700 | spem d k = (d, secpem k) | ||
1701 | |||
1702 | secrets homedir = do | ||
1703 | kd <- secrets_kd | ||
1704 | let torkey = spem (dir "var/lib/tor/samizdat/private_key") <$> lookupSecret "tor" kd | ||
1705 | sshcli = do k <- lookupSecret "ssh-client" kd | ||
1706 | return $ spem (dir $ homedir ++ "/.ssh/" ++ sshkeyname k) k | ||
1707 | sshsvr = spem (dir "etc/ssh/ssh_host_rsa_key") <$> lookupSecret "ssh-host" kd | ||
1708 | ipseckey = do | ||
1709 | k <- lookupSecret "strongswan" kd | ||
1710 | oname <- fst . snd $ getHostnames kd | ||
1711 | return $ spem (dir $ "etc/ipsec.d/private/"++Char8.unpack oname++".pem") k | ||
1712 | torkey ++ sshcli ++ sshsvr ++ ipseckey | ||
1713 | |||
1714 | tarT :: ([[String]],Map.Map String [String]) -> IO () | ||
1715 | tarT (sargs,margs) = do | ||
1716 | KikiResult rt report <- runKeyRing $ minimalOp $ parseCommonArgs margs | ||
1717 | case rt of | ||
1718 | KikiSuccess rt -> do | ||
1719 | let keyspec = concat . take 1 <$> Map.lookup "--secrets" margs | ||
1720 | nil = error "internal error!" | ||
1721 | fs = map fst $ tarContent rt keyspec nil nil nil | ||
1722 | mapM_ putStrLn fs | ||
1723 | err -> putStrLn $ errorString err | ||
1724 | |||
1725 | tarC :: ([[String]],Map.Map String [String]) -> IO () | ||
1726 | tarC (sargs,margs) = do | ||
1727 | KikiResult rt report <- runKeyRing $ minimalOp $ parseCommonArgs margs | ||
1728 | case rt of | ||
1729 | KikiSuccess rt -> do | ||
1730 | CTime pubtime <- modificationTime <$> getFileStatus (rtPubring rt) | ||
1731 | let keyspec = concat . take 1 <$> Map.lookup "--secrets" margs | ||
1732 | fs = tarContent rt keyspec build_ipsec (build_ssh rt pubtime) (error "todo") | ||
1733 | es = do | ||
1734 | (n,(epoch_time_int64,bs)) <- fs | ||
1735 | entry <- either (const []) (return . flip Tar.fileEntry bs) $ Tar.toTarPath False n | ||
1736 | return $ entry { Tar.entryTime = epoch_time_int64 } | ||
1737 | tarbs = Tar.write es | ||
1738 | L.putStr tarbs | ||
1739 | err -> putStrLn $ errorString err | ||
1740 | where | ||
1741 | build_ipsec ns addr ipsec sigs | ||
1742 | = ( fromIntegral $ timestamp ipsec | ||
1743 | , Char8.pack $ fromJust $ pemFromPacket ipsec) | ||
1744 | build_ssh rt timestamp sshs = (timestamp, Char8.unlines $ map knownhost sshs) | ||
1745 | where | ||
1746 | knownhost (kk,hostkey,sigs) = Char8.intercalate "," ns <> " " <> Char8.pack (sshblobFromPacket hostkey) | ||
1747 | where | ||
1748 | ns = onames ++ others | ||
1749 | (_,(onames,others)) = getHostnames $ rtKeyDB rt Map.! kk | ||
1750 | |||
1751 | minimalOp :: CommonArgsParsed -> KeyRingOperation | ||
1752 | minimalOp cap = op | ||
1753 | where | ||
1754 | streaminfo = StreamInfo { fill = KF_None | ||
1755 | , typ = KeyRingFile | ||
1756 | , spill = KF_All | ||
1757 | , initializer = Nothing | ||
1758 | , access = AutoAccess | ||
1759 | , transforms = [] | ||
1760 | } | ||
1761 | op = KeyRingOperation | ||
1762 | { opFiles = Map.fromList $ | ||
1763 | [ ( HomeSec, streaminfo { access = Sec }) | ||
1764 | , ( HomePub, streaminfo { access = Pub }) | ||
1765 | ] | ||
1766 | , opPassphrases = do pfile <- maybeToList (cap_passfd cap) | ||
1767 | return $ PassphraseSpec Nothing Nothing pfile | ||
1768 | , opTransforms = [] | ||
1769 | , opHome = cap_homespec cap | ||
1770 | } | ||
1771 | |||
1772 | -- | | ||
1773 | -- | ||
1774 | -- no leading hyphen, returns Right (input string). | ||
1775 | -- | ||
1776 | -- single leading hyphen, quits program with "Unrecognized option" error | ||
1777 | -- | ||
1778 | -- Otherwise, Left (key-value pair) is returend by parsing | ||
1779 | -- a string of the form --key=value. | ||
1595 | splitArg :: String -> Either (String,Maybe String) String | 1780 | splitArg :: String -> Either (String,Maybe String) String |
1596 | splitArg arg = | 1781 | splitArg arg = |
1597 | case hyphens of | 1782 | case hyphens of |
@@ -1620,6 +1805,7 @@ commands = | |||
1620 | , ( "merge", "low level import/export operation" ) | 1805 | , ( "merge", "low level import/export operation" ) |
1621 | , ( "init-key", "initialize the samizdat key ring") | 1806 | , ( "init-key", "initialize the samizdat key ring") |
1622 | , ( "delete", "Delete a subkey and its associated signatures" ) | 1807 | , ( "delete", "Delete a subkey and its associated signatures" ) |
1808 | , ( "tar", "import or export system key files in tar format" ) | ||
1623 | ] | 1809 | ] |
1624 | 1810 | ||
1625 | interp vars raw = es >>= interp1 | 1811 | interp vars raw = es >>= interp1 |