From 64202f804429053058ac3efce527f77c2e12948b Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 23 Apr 2016 00:35:03 -0400 Subject: WIP: tar command. --- KeyRing.hs | 21 ++++--- kiki.hs | 208 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 209 insertions(+), 20 deletions(-) diff --git a/KeyRing.hs b/KeyRing.hs index 7369acf..d4bb099 100644 --- a/KeyRing.hs +++ b/KeyRing.hs @@ -938,7 +938,7 @@ parseSpec grip spec = (topspec,subspec) "fp" | top=="" -> Nothing "" | top=="" && is40digitHex sub -> Nothing "" -> listToMaybe sub >> Just sub - -- "fp" -> ??? TODO: non-ehaustive patterns in case: fp:7/fp: + _ -> Nothing is40digitHex xs = ys == xs && length ys==40 where @@ -992,11 +992,14 @@ selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db -selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(Packet,[Packet])] +selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Packet])] selectPublicKeyAndSigs (spec,mtag) db = case mtag of - Nothing -> concat $ Map.elems $ fmap (findbyspec spec) db - Just tag -> Map.elems (Map.filter (matchSpec spec) db) >>= findsubs tag + Nothing -> do + (kk,r) <- Map.toList $ fmap (findbyspec spec) db + (sub,sigs) <- r + return (kk,sub,sigs) + Just tag -> Map.toList (Map.filter (matchSpec spec) db) >>= findsubs tag where topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd) @@ -1009,22 +1012,22 @@ selectPublicKeyAndSigs (spec,mtag) db = ismatch (p,sigs) = matchpr g p ==g findbyspec spec kd = if matchSpec spec kd then [topresult kd] else [] - findsubs tag (KeyData topk _ _ subs) = Map.elems subs >>= gettag + findsubs tag (kk, KeyData topk _ _ subs) = Map.elems subs >>= gettag where gettag (SubKey sub sigs) = do let (_,mb,_) = findTag [mkUsage tag] (packet topk) (packet sub) sigs (hastag,_) <- maybeToList mb guard hastag - return $ (packet sub, map (packet . fst) sigs) + return $ (kk, packet sub, map (packet . fst) sigs) selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectKey0 wantPublic (spec,mtag) db = do let Message ps = flattenKeys wantPublic db ys = snd $ seek_key spec ps flip (maybe (listToMaybe ys)) mtag $ \tag -> do - let (subspec,ys1) = (KeyTag y tag,ys1) where y:ys1 = ys - zs = snd $ seek_key subspec ys1 - listToMaybe zs + case ys of + y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1 + [] -> Nothing {- selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)] diff --git a/kiki.hs b/kiki.hs index 9a2000a..d58ef2a 100644 --- a/kiki.hs +++ b/kiki.hs @@ -17,18 +17,24 @@ import Data.Binary import Data.Bits import Data.Char import Data.IORef +import Data.Int import Data.List import Data.Maybe import Data.OpenPGP import Data.Ord import Data.Text.Encoding import System.Posix.User +import System.Posix.Files +import System.Posix.Types import System.FilePath.Posix +import Foreign.C.Types (CTime(..)) import System.Directory import System.Environment import System.Exit import System.IO (hPutStrLn,stderr) import qualified Codec.Binary.Base64 as Base64 +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar #if !defined(VERSION_cryptonite) import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 import qualified Crypto.Hash.SHA256 as SHA256 @@ -42,7 +48,6 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as Char8 import qualified Data.Map as Map import Control.Arrow (first,second) -import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) import Data.Monoid ( (<>) ) import Data.Binary.Put @@ -58,6 +63,8 @@ import ProcessUtils import qualified SSHKey as SSH import Text.Printf import qualified DNSKey as DNS +import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) +import Debug.Trace -- {-# ANN module ("HLint: ignore Eta reduce"::String) #-} -- {-# ANN module ("HLint: ignore Use camelCase"::String) #-} @@ -329,11 +336,13 @@ show_ssh' keyspec wkgrip db = do let s = parseSpec wkgrip keyspec flip (maybe . Left $ keyspec ++ ": not found") (selectPublicKey s db) - $ \k -> do - let Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k - bs = SSH.keyblob (n,e) - blob = Char8.unpack bs - return blob + $ return . sshblobFromPacket + +sshblobFromPacket k = blob + where + Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k + bs = SSH.keyblob (n,e) + blob = Char8.unpack bs show_id keyspec wkgrip db = do let s = parseSpec "" keyspec @@ -376,7 +385,7 @@ show_cert keyspec wkgrip db = do let s = parseSpec wkgrip keyspec case selectPublicKeyAndSigs s db of [] -> void $ warn (keyspec ++ ": not found") - [(k,sigs)] -> do + [(_,k,sigs)] -> do {- let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k der = encodeASN1 DER (toASN1 rsa []) @@ -944,9 +953,27 @@ documentHostsOption bExport bImport bSecret = ," but they are currently NOT signed and may be altered in" ," transit." ,""] - - + + +-- | +-- Arguments: +-- +-- * option-count pairs - List of option names paired with number of expected values to follow them. +-- +-- * polyvariadic options - List of option names that can take any number of arguments. +-- +-- * default polyvariadic - Implicit polyvariadic option if no other option is specified. +-- +-- * arguments - list of arguments to be parsed. +-- +-- Returns: +-- +-- * (non-variadic only) options and corresponding arguemnts in list of lists form. +-- +-- * (variadic only) map of option name to argument lists. +-- +processArgs :: [(String,Int)] -> [String] -> String -> [String] -> ([[String]],Map.Map String [String]) processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs) where (args,trail1) = break (=="--") args_raw @@ -962,7 +989,7 @@ processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs) gargs) where (sargs,vargs) = partitionStaticArguments sargspec' args argspec = map fst sargspec' ++ polyVariadicArgs - args' = if map (take 1) (take 1 vargs) == ["-"] + args' = if null defaultPoly || map (take 1) (take 1 vargs) == ["-"] then vargs else defaultPoly:vargs -- grouped args @@ -1175,7 +1202,7 @@ kiki "show" args = do , ("--torhash",1) ] polyVariadicArgs = ["--show"] - let cap = parseCommonArgs margs + let cap = parseCommonArgs margs homespec = cap_homespec cap passfd = cap_passfd cap pems = [] @@ -1592,6 +1619,164 @@ kiki "delete" args = do forM_ report $ \(fname,act) -> do putStrLn $ fname ++ ": " ++ reportString act +kiki "tar" args | "--help" `elem` args = do + putStr . unlines $ + [ "kiki tar (-c|-A|-t) [--secrets SPEC] [--passphrase-fd FD] [--homedir HOMEDIR]" + , "" + , "Import or export a tar archive containing key files in the proper" + , "format for software configuration." + , "" + ," -c Generate tar archive on stdout." + ,"" + ," -A Read tar archive on stdin." + ,"" + ," -t List filepaths that would be included in the (-c) output archive." + ,"" + ," --secrets SPEC" + ," Include secret keys for the specified identity." + ," Otherwise, only public keys are included." + ,"" + ," SPEC is matched against the following forms in order:" + ,"" + ," -" + ," (current working identity)" + ,"" + ," fp:4A39F" + ," (tail end of a fingerprint prefixed by 'fp:')" + ,"" + ," u:joe" + ," (sub-string of a user id prefixed by 'u:')" + ,"" + ," 5E24CD442AA6965D2012E62A905C24185D5379C2" + ," (fingerprint as 40 characters of hexidecimal)" + ,"" + ," joe" + ," (sub-string of a user id without 'u:' prefix)" + ] + +kiki "tar" args = do + let parsed_args = processArgs sargspec [] "" args + sargspec = [("-t",0),("-c",0),("-A",0),("-C",1),("--secrets",1)] + ismode ("-t":_) = True + ismode ("-c":_) = True + ismode ("-A":_) = True + ismode _ = False + case filter ismode (fst parsed_args) of + ["-t":_] -> tarT parsed_args + ["-c":_] -> tarC parsed_args + ["-A":_] -> putStrLn "unimplemented." + _ -> kiki "tar" ["--help"] + +tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root" + where + ipsecs = do + (kk,ipsec,sigs) <- selectPublicKeyAndSigs (KeyUidMatch "",Just "strongswan") (rtKeyDB rt) + let kd = (rtKeyDB rt Map.! kk) + k = packet $ keyMappedPacket kd + (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 . (Map.!) (rtKeyDB rt) . keykey + Just topspec + -> map snd $ filterMatches topspec $ Map.toList $ rtKeyDB rt + w -> [] + + lookupSecret tag kd = maybeToList $ selectSecretKey (KeyGrip "",Just tag) m + where + m = Map.singleton (keykey $ keyPacket kd) kd + + sshkeyname SecretKeyPacket { key_algorithm = RSA } = "id_rsa" + + 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 + return $ spem (dir $ homedir ++ "/.ssh/" ++ sshkeyname k) k + sshsvr = spem (dir "etc/ssh/ssh_host_rsa_key") <$> lookupSecret "ssh-host" kd + ipseckey = do + k <- lookupSecret "strongswan" kd + oname <- fst . snd $ getHostnames kd + return $ spem (dir $ "etc/ipsec.d/private/"++Char8.unpack oname++".pem") k + torkey ++ sshcli ++ sshsvr ++ ipseckey + +tarT :: ([[String]],Map.Map String [String]) -> IO () +tarT (sargs,margs) = do + KikiResult rt report <- runKeyRing $ minimalOp $ 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 $ parseCommonArgs margs + case rt of + KikiSuccess rt -> do + CTime pubtime <- modificationTime <$> getFileStatus (rtPubring rt) + let keyspec = concat . take 1 <$> Map.lookup "--secrets" margs + fs = tarContent rt keyspec build_ipsec (build_ssh rt pubtime) (error "todo") + es = do + (n,(epoch_time_int64,bs)) <- fs + entry <- either (const []) (return . flip Tar.fileEntry bs) $ Tar.toTarPath False n + return $ entry { Tar.entryTime = epoch_time_int64 } + tarbs = Tar.write es + L.putStr tarbs + err -> putStrLn $ errorString err + where + build_ipsec ns addr ipsec sigs + = ( fromIntegral $ timestamp ipsec + , Char8.pack $ fromJust $ pemFromPacket ipsec) + build_ssh rt timestamp sshs = (timestamp, Char8.unlines $ map knownhost sshs) + where + knownhost (kk,hostkey,sigs) = Char8.intercalate "," ns <> " " <> Char8.pack (sshblobFromPacket hostkey) + where + ns = onames ++ others + (_,(onames,others)) = getHostnames $ rtKeyDB rt Map.! kk + +minimalOp :: CommonArgsParsed -> KeyRingOperation +minimalOp cap = op + where + streaminfo = StreamInfo { fill = KF_None + , typ = KeyRingFile + , spill = KF_All + , initializer = Nothing + , 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 + } + +-- | +-- +-- no leading hyphen, returns Right (input string). +-- +-- single leading hyphen, quits program with "Unrecognized option" error +-- +-- Otherwise, Left (key-value pair) is returend by parsing +-- a string of the form --key=value. splitArg :: String -> Either (String,Maybe String) String splitArg arg = case hyphens of @@ -1620,6 +1805,7 @@ commands = , ( "merge", "low level import/export operation" ) , ( "init-key", "initialize the samizdat key ring") , ( "delete", "Delete a subkey and its associated signatures" ) + , ( "tar", "import or export system key files in tar format" ) ] interp vars raw = es >>= interp1 -- cgit v1.2.3