From 6860098ed8f8b56eb5058e0c9c427abaa57021bf Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 25 Apr 2016 20:20:45 -0400 Subject: more work on cokiki (ssh-client) --- LengthPrefixedBE.hs | 90 -------------------------- SSHKey.hs | 49 -------------- cokiki.hs | 22 ++++--- kiki.cabal | 2 + kiki.hs | 124 +---------------------------------- lib/Kiki.hs | 169 ++++++++++++++++++++++++++++++++++++++++++++++-- lib/LengthPrefixedBE.hs | 90 ++++++++++++++++++++++++++ lib/SSHKey.hs | 49 ++++++++++++++ 8 files changed, 319 insertions(+), 276 deletions(-) delete mode 100644 LengthPrefixedBE.hs delete mode 100644 SSHKey.hs create mode 100644 lib/LengthPrefixedBE.hs create mode 100644 lib/SSHKey.hs diff --git a/LengthPrefixedBE.hs b/LengthPrefixedBE.hs deleted file mode 100644 index 0ccd0e2..0000000 --- a/LengthPrefixedBE.hs +++ /dev/null @@ -1,90 +0,0 @@ -module LengthPrefixedBE - ( LengthPrefixedBE(..) - , encode_bigendian - , decode_bigendian - ) where - -import qualified Data.ByteString.Lazy as L -import Data.Bits -import Data.Binary -import Data.Binary.Get -import Data.Binary.Put (putWord32be, putLazyByteString) -import Data.Int - -{- - From RFC4251... - - string - - Arbitrary length binary string. Strings are allowed to contain - arbitrary binary data, including null characters and 8-bit - characters. They are stored as a uint32 containing its length - (number of bytes that follow) and zero (= empty string) or more - bytes that are the value of the string. Terminating null - characters are not used. - - mpint ( LengthPrefixedBE ) - - Represents multiple precision integers in two's complement format, - stored as a string, 8 bits per byte, MSB first. Negative numbers - have the value 1 as the most significant bit of the first byte of - the data partition. If the most significant bit would be set for - a positive number, the number MUST be preceded by a zero byte. - Unnecessary leading bytes with the value 0 or 255 MUST NOT be - included. The value zero MUST be stored as a string with zero - bytes of data. --} - -newtype LengthPrefixedBE = LengthPrefixedBE Integer - -instance Binary LengthPrefixedBE where - - put (LengthPrefixedBE n) = do - putWord32be len - putLazyByteString bytes - where - bytes = encode_bigendian n - len = fromIntegral (L.length bytes) :: Word32 - - get = do - len <- get - bs <- getLazyByteString (word32_to_int64 len) - return . LengthPrefixedBE $ decode_bigendian bs - where - word32_to_int64 :: Word32 -> Int64 - word32_to_int64 = fromIntegral - - - -encode_bigendian :: (Integral a, Bits a) => a -> L.ByteString -encode_bigendian n = - if (bit /= sbyte) - then sbyte `L.cons` bytes - else bytes - where - bytes = L.reverse $ unroll n - sbyte :: Word8 - sbyte = if n<0 then 0xFF else 0 - bit = if L.null bytes - then 0x00 - else fromIntegral ((fromIntegral (L.head bytes) :: Int8) `shiftR` 7) - - unroll :: (Integral a, Bits a) => a -> L.ByteString - unroll = L.unfoldr step - -- TODO: Is reversing L.unfoldr more or less efficient - -- than using Data.List.unfoldr ? - -- Probably Data.ByteString.Lazy should export an unfoldrEnd - -- function that efficiently unfolds reversed bytestrings. - where - step 0 = Nothing - step (-1) = Nothing - step i = Just (fromIntegral i, i `shiftR` 8) - -decode_bigendian :: (Num a, Bits a) => L.ByteString -> a -decode_bigendian bs = if isneg then n - 256^(L.length bs) - else n - where - n = L.foldl (\a b -> a `shiftL` 8 .|. fromIntegral b) 0 bs - isneg = not (L.null bs) && L.head bs .&. 0x80 /= 0 - - diff --git a/SSHKey.hs b/SSHKey.hs deleted file mode 100644 index 488f55f..0000000 --- a/SSHKey.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module SSHKey where - -import qualified Data.ByteString.Lazy.Char8 as L8 -import qualified Data.ByteString.Lazy as L -import qualified Codec.Binary.Base64 as Base64 -import Data.Binary.Get ( runGet ) -import Data.Binary.Put ( putWord32be, runPut, putByteString ) -import Data.Binary ( get, put ) -import Data.Monoid ( (<>) ) -import Data.Maybe ( listToMaybe ) -import Data.Char ( isSpace ) -import Control.Monad ( guard ) -import LengthPrefixedBE - -type Key = (Integer,Integer) - -keyblob :: Key -> L.ByteString -keyblob (n,e) = "ssh-rsa " <> blob - where - bs = sshrsa e n - blob = L8.pack $ Base64.encode (L.unpack bs) - - sshrsa :: Integer -> Integer -> L.ByteString - sshrsa e n = runPut $ do - putWord32be 7 - putByteString "ssh-rsa" - put (LengthPrefixedBE e) - put (LengthPrefixedBE n) - -blobkey :: L8.ByteString -> Maybe Key -blobkey bs = do - let (pre,bs1) = L8.splitAt 7 bs - guard $ pre == "ssh-rsa" - let (sp,bs2) = L8.span isSpace bs1 - guard $ not (L8.null sp) - bs3 <- listToMaybe $ L8.words bs2 - qq <- L.pack `fmap` Base64.decode (L8.unpack bs3) - decode_sshrsa qq - where - decode_sshrsa :: L8.ByteString -> Maybe Key - decode_sshrsa bs = do - let (pre,bs1) = L8.splitAt 11 bs - guard $ pre == runPut (putWord32be 7 >> putByteString "ssh-rsa") - let rsakey = flip runGet bs1 $ do - LengthPrefixedBE e <- get - LengthPrefixedBE n <- get - return (n,e) - return rsakey diff --git a/cokiki.hs b/cokiki.hs index daf2be5..899608b 100644 --- a/cokiki.hs +++ b/cokiki.hs @@ -23,6 +23,7 @@ usage = unlines , " strongswan" ] +ㄧchroot :: Args (FilePath -> FilePath) ㄧchroot = pure (\r a -> slash r a) <*> arg "--chroot" <|> pure id where slash :: String -> String -> String @@ -38,11 +39,11 @@ main = do | uid==0 = action | otherwise = hPutStrLn stderr "operation requires root." let sel = case cmd of - ["ssh-client"] -> pure (sshClient uid) <*> ㄧchroot + ["ssh-client"] -> pure (sshClient uid) <*> ㄧchroot <*> Kiki.ㄧhomedir ["ssh-server"] -> pure (whenRoot sshServer) ["strongswan"] -> pure (whenRoot strongswan) _ -> pure $ hPutStr stderr usage - spec = fancy [("--chroot",1)] [] "" + spec = fancy [("--chroot",1),("--passphrase-fd",1),("--homedir",1)] [] "" case runArgs (parseInvocation spec args) sel of Left e -> hPutStrLn stderr $ usageErrorMessage e Right io -> io @@ -51,7 +52,7 @@ maybeReadFile :: FilePath -> IO (Maybe L.ByteString) maybeReadFile path = do doesFileExist path >>= bool (return Nothing) (Just <$> L.readFile path) -sshClient uid root = do +sshClient uid root cmn = do -- /etc/ssh/ssh_config <-- 'GlobalKnownHostsFile /var/cache/kiki/ssh_known_hosts' sshconfig <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ssh/ssh_config") let (ps,qs) = sshSplitAtDirective "GlobalKnownHostsFile" sshconfig @@ -64,20 +65,21 @@ sshClient uid root = do d:ds | elem "/var/cache/kiki/ssh_known_hosts" d -> do hPutStrLn stderr "ssh-client already configured." return Nothing - d:ds -> do hPutStrLn stderr "modifying GlobalKnownHostsFile not implemented" - return Nothing - [] -> do + d:ds -> do hPutStrLn stderr "modifying GlobalKnownHostsFile directive" + let hs = " " : "/var/cache/kiki/ssh_known_hosts" : drop 1 d + stmt = take 1 d ++ hs + return $ Just (ps ++ stmt : ds) + [] -> do -- Unconfigured add fresh directive. let stmt = L8.unwords ["GlobalKnownHostsFile" , "/var/cache/kiki/ssh_known_hosts" , "/etc/ssh/ssh_known_hosts" , "/etc/ssh/ssh_known_hosts2" ] return $ Just (sshconfig ++ parseSshConfig stmt) - -- sshconfig' `deepseq` return () -- force lazy input + sshconfig' `deepseq` return () -- force lazy input maybe (return ()) (myWriteFile (root "/etc/ssh/ssh_config") . unparseSshConfig) sshconfig' -- /root/.gnupg/... <-- contains known hosts from /etc/ssh/ssh_known_hosts - - -- Kiki.refresh + Kiki.refresh root cmn -- /var/cache/kiki/ssh_known_hosts <-- contains known hosts from /root/.gnupg/... sshServer = do @@ -87,7 +89,7 @@ sshServer = do strongswan = do -- etc/ipsec.conf <-- 'include /var/cache/kiki/ipsec.conf' -- /root/.gnupg/... <-- contains newly-generated ipsec subkey - Kiki.refresh + Kiki.refresh id (Kiki.CommonArgsParsed Nothing Nothing) -- /var/cache/kiki/ipsec.conf <-- contains configurations for each remote ipsec host -- /var/cache/kiki/ipsec.conf <-- contains '%default' configuration for this local host -- /var/cache/kiki/ipsec.d/certs <-- contains relevant certs diff --git a/kiki.cabal b/kiki.cabal index 5ed7a4c..b64b87e 100644 --- a/kiki.cabal +++ b/kiki.cabal @@ -78,6 +78,8 @@ library CryptoCoins, ProcessUtils, Hosts, + SSHKey, + LengthPrefixedBE, CommandLine, Numeric.Interval, Numeric.Interval.Bounded, diff --git a/kiki.hs b/kiki.hs index 0284ff9..842e697 100644 --- a/kiki.hs +++ b/kiki.hs @@ -66,14 +66,9 @@ import qualified SSHKey as SSH import Text.Printf import qualified DNSKey as DNS import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) +import Kiki import Debug.Trace -#if !MIN_VERSION_base(4,8,0) -sortOn :: Ord b => (a -> b) -> [a] -> [a] -sortOn f = - map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) -#endif - -- {-# ANN module ("HLint: ignore Eta reduce"::String) #-} -- {-# ANN module ("HLint: ignore Use camelCase"::String) #-} @@ -134,8 +129,6 @@ sortOn f = - -} -warn str = hPutStrLn stderr str - isCertificationSig (CertificationSignature {}) = True isCertificationSig _ = True @@ -307,21 +300,6 @@ show_whose_key input_key db = show_dns keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db dnsPresentationFromPacket -show_pem keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db pemFromPacket - -show_pem' keyspec wkgrip db keyfmt = do - let s = parseSpec wkgrip keyspec - flip (maybe . Left $ keyspec ++ ": not found") - (selectPublicKey s db) - keyfmt - -pemFromPacket k = do - let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k - der = encodeASN1 DER (toASN1 rsa []) - qq = Base64.encode (L.unpack der) - return $ - writePEM "PUBLIC KEY" qq -- ("TODO "++show keyspec) - dnsPresentationFromPacket k = do let RSAKey (MPI n) (MPI e) = fromJust $ rsaKeyFromPacket k dnskey = DNS.RSA n e @@ -341,20 +319,6 @@ dnsPresentationFromPacket k = do ,qq ] -show_ssh keyspec wkgrip db = either warn putStrLn $ show_ssh' keyspec wkgrip db - -show_ssh' keyspec wkgrip db = do - let s = parseSpec wkgrip keyspec - flip (maybe . Left $ keyspec ++ ": not found") - (selectPublicKey s db) - $ 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 let ps = do @@ -1029,8 +993,6 @@ processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs) else error . unlines $ [ "unrecognized option "++k , "Use --help for usage." ] -data CommonArgsParsed = CommonArgsParsed { cap_homespec :: Maybe String, cap_passfd :: Maybe InputFile } - parseCommonArgs margs = CommonArgsParsed { cap_homespec = homespec, cap_passfd = passfd } where passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs @@ -1658,55 +1620,6 @@ kiki "tar" args = do ["-A":_] -> putStrLn "unimplemented." -- import tar file? _ -> kiki "tar" ["--help"] -refreshCache rt rootdir = do - - let mkpath pth = fromMaybe "" rootdir ++ "/var/cache/kiki/"++pth - - write f bs = do - createDirectoryIfMissing True $ takeDirectory f - writeFile f bs - - let oname' = do wk <- rtWorkingKey rt - -- XXX unnecessary signature check - onionNameForContact (keykey wk) (rtKeyDB rt) - bUnprivileged = False -- TODO - if (oname' == Nothing) && (not bUnprivileged) then error "Missing tor key" else do - let oname = fromMaybe "" oname' - -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir ".ssh" "id_rsa.pub" - -- sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub" - -- contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem" - - -- Finally, export public keys if they do not exist. - flip (maybe $ warn "missing working key?") (rtGrip rt) $ \grip -> do - either warn (write $ mkpath "root/.ssh/id_rsa.pub") - $ show_ssh' "ssh-client" grip (rtKeyDB rt) - either warn (write $ mkpath "ssh_host_rsa_key.pub") - $ show_ssh' "ssh-server" grip (rtKeyDB rt) - either warn (write $ mkpath "ipsec.d/certs/" ++ oname++".pem") - $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket - - let cs = filter notme (Map.elems $ rtKeyDB rt) - kk = keykey (fromJust $ rtWorkingKey rt) - notme kd = keykey (keyPacket kd) /= kk - - installConctact kd = do - -- The getHostnames command requires a valid cross-signed tor key - -- for each onion name returned in (_,(ns,_)). - let (_,(ns,_)) = getHostnames kd - contactname = fmap Char8.unpack $ listToMaybe ns -- only first onion name. - flip (maybe $ return ()) contactname $ \contactname -> do - - let cpath = interp (Map.singleton "onion" contactname) "ipsec.d/certs/%(onion).pem" - their_master = packet $ keyMappedPacket kd - -- We find all cross-certified ipsec keys for the given cross-certified onion name. - ipsecs = sortOn (Down . timestamp) - $ getCrossSignedSubkeys their_master (keySubKeys kd) "ipsec" - forM_ (take 1 ipsecs) $ \k -> do - either warn (write $ mkpath cpath) $ pemFromPacket k - - mapM_ installConctact cs - - tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root" where ipsecs = do @@ -1811,27 +1724,6 @@ tarC (sargs,margs) = do hPutStrLn stderr $ "Failed to decrypt "++fingerprint k++"." return Nothing -minimalOp :: CommonArgsParsed -> KeyRingOperation -minimalOp cap = op - where - streaminfo = StreamInfo { fill = KF_None - , typ = KeyRingFile - , spill = KF_All - , initializer = NoCreate - , 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). @@ -1872,20 +1764,6 @@ commands = , ( "tar", "import or export system key files in tar format" ) ] --- | --- interpolate %var patterns in a string. -interp vars raw = es >>= interp1 - where - gs = groupBy (\_ c -> c/='%') raw - es = dropWhile null $ gobbleEscapes ("":gs) - where gobbleEscapes :: [String] -> [String] - gobbleEscapes (a:"%":b:bs) = (a++b) : gobbleEscapes bs - gobbleEscapes (g:gs) = g : gobbleEscapes gs - gobbleEscapes [] = [] - interp1 ('%':'(':str) = fromMaybe "" (Map.lookup key vars) ++ drop 1 rest - where (key,rest) = break (==')') str - interp1 plain = plain - main = do dotlock_init args_raw <- getArgs diff --git a/lib/Kiki.hs b/lib/Kiki.hs index 783b6ed..575cf26 100644 --- a/lib/Kiki.hs +++ b/lib/Kiki.hs @@ -1,8 +1,169 @@ +{-# LANGUAGE CPP #-} module Kiki where +import Control.Monad +import Control.Applicative +import Data.List +import Data.Maybe +import Data.Ord +import System.Directory +import System.FilePath.Posix +import System.IO +import Data.OpenPGP +import Data.OpenPGP.Util +import qualified Data.Map.Strict as Map +import qualified Codec.Binary.Base64 as Base64 +import Data.ASN1.BinaryEncoding +import Data.ASN1.Encoding +import Data.ASN1.Types +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as Char8 + +import CommandLine +import qualified SSHKey as SSH +import KeyRing + -- | -- Regenerate /var/cache/kiki -refresh :: IO () -refresh = do - -- TODO - return () +refresh :: (FilePath -> FilePath) -> CommonArgsParsed -> IO () +refresh root homepass = do + let homepass' = homepass { cap_homespec = fmap root (cap_homespec homepass) } + KikiResult r report <- runKeyRing $ minimalOp homepass' + let mroot = case root "" of + "/" -> Nothing + "" -> Nothing + pth -> Just pth + case r of + KikiSuccess rt -> refreshCache rt mroot + _ -> return () -- XXX: silent fail? + +data CommonArgsParsed = CommonArgsParsed { cap_homespec :: Maybe String, cap_passfd :: Maybe InputFile } + + +minimalOp :: CommonArgsParsed -> KeyRingOperation +minimalOp cap = op + where + streaminfo = StreamInfo { fill = KF_None + , typ = KeyRingFile + , spill = KF_All + , initializer = NoCreate + , 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 + } + + +refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO () +refreshCache rt rootdir = do + + let mkpath pth = fromMaybe "" rootdir ++ "/var/cache/kiki/"++pth + + write f bs = do + createDirectoryIfMissing True $ takeDirectory f + writeFile f bs + + let oname' = do wk <- rtWorkingKey rt + -- XXX unnecessary signature check + onionNameForContact (keykey wk) (rtKeyDB rt) + bUnprivileged = False -- TODO + if (oname' == Nothing) && (not bUnprivileged) then error "Missing tor key" else do + let oname = fromMaybe "" oname' + -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir ".ssh" "id_rsa.pub" + -- sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub" + -- contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem" + + -- Finally, export public keys if they do not exist. + flip (maybe $ warn "missing working key?") (rtGrip rt) $ \grip -> do + either warn (write $ mkpath "root/.ssh/id_rsa.pub") + $ show_ssh' "ssh-client" grip (rtKeyDB rt) + either warn (write $ mkpath "ssh_host_rsa_key.pub") + $ show_ssh' "ssh-server" grip (rtKeyDB rt) + either warn (write $ mkpath "ipsec.d/certs/" ++ oname++".pem") + $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket + + let cs = filter notme (Map.elems $ rtKeyDB rt) + kk = keykey (fromJust $ rtWorkingKey rt) + notme kd = keykey (keyPacket kd) /= kk + + installConctact kd = do + -- The getHostnames command requires a valid cross-signed tor key + -- for each onion name returned in (_,(ns,_)). + let (_,(ns,_)) = getHostnames kd + contactname = fmap Char8.unpack $ listToMaybe ns -- only first onion name. + flip (maybe $ return ()) contactname $ \contactname -> do + + let cpath = interp (Map.singleton "onion" contactname) "ipsec.d/certs/%(onion).pem" + their_master = packet $ keyMappedPacket kd + -- We find all cross-certified ipsec keys for the given cross-certified onion name. + ipsecs = sortOn (Down . timestamp) + $ getCrossSignedSubkeys their_master (keySubKeys kd) "ipsec" + forM_ (take 1 ipsecs) $ \k -> do + either warn (write $ mkpath cpath) $ pemFromPacket k + + mapM_ installConctact cs + + +#if !MIN_VERSION_base(4,8,0) +sortOn :: Ord b => (a -> b) -> [a] -> [a] +sortOn f = + map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) +#endif + +pemFromPacket k = do + let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k + der = encodeASN1 DER (toASN1 rsa []) + qq = Base64.encode (L.unpack der) + return $ + writePEM "PUBLIC KEY" qq -- ("TODO "++show keyspec) + +show_pem keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db pemFromPacket + +show_pem' keyspec wkgrip db keyfmt = do + let s = parseSpec wkgrip keyspec + flip (maybe . Left $ keyspec ++ ": not found") + (selectPublicKey s db) + keyfmt + +warn str = hPutStrLn stderr str + +show_ssh keyspec wkgrip db = either warn putStrLn $ show_ssh' keyspec wkgrip db + +show_ssh' keyspec wkgrip db = do + let s = parseSpec wkgrip keyspec + flip (maybe . Left $ keyspec ++ ": not found") + (selectPublicKey s db) + $ return . sshblobFromPacket + +-- | +-- interpolate %var patterns in a string. +interp vars raw = es >>= interp1 + where + gs = groupBy (\_ c -> c/='%') raw + es = dropWhile null $ gobbleEscapes ("":gs) + where gobbleEscapes :: [String] -> [String] + gobbleEscapes (a:"%":b:bs) = (a++b) : gobbleEscapes bs + gobbleEscapes (g:gs) = g : gobbleEscapes gs + gobbleEscapes [] = [] + interp1 ('%':'(':str) = fromMaybe "" (Map.lookup key vars) ++ drop 1 rest + where (key,rest) = break (==')') str + interp1 plain = plain + +sshblobFromPacket k = blob + where + Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k + bs = SSH.keyblob (n,e) + blob = Char8.unpack bs + +ㄧhomedir = Kiki.CommonArgsParsed + <$> optional (arg "--homedir") + <*> optional (FileDesc <$> read <$> arg "--passphrase-fd") + diff --git a/lib/LengthPrefixedBE.hs b/lib/LengthPrefixedBE.hs new file mode 100644 index 0000000..0ccd0e2 --- /dev/null +++ b/lib/LengthPrefixedBE.hs @@ -0,0 +1,90 @@ +module LengthPrefixedBE + ( LengthPrefixedBE(..) + , encode_bigendian + , decode_bigendian + ) where + +import qualified Data.ByteString.Lazy as L +import Data.Bits +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put (putWord32be, putLazyByteString) +import Data.Int + +{- + From RFC4251... + + string + + Arbitrary length binary string. Strings are allowed to contain + arbitrary binary data, including null characters and 8-bit + characters. They are stored as a uint32 containing its length + (number of bytes that follow) and zero (= empty string) or more + bytes that are the value of the string. Terminating null + characters are not used. + + mpint ( LengthPrefixedBE ) + + Represents multiple precision integers in two's complement format, + stored as a string, 8 bits per byte, MSB first. Negative numbers + have the value 1 as the most significant bit of the first byte of + the data partition. If the most significant bit would be set for + a positive number, the number MUST be preceded by a zero byte. + Unnecessary leading bytes with the value 0 or 255 MUST NOT be + included. The value zero MUST be stored as a string with zero + bytes of data. +-} + +newtype LengthPrefixedBE = LengthPrefixedBE Integer + +instance Binary LengthPrefixedBE where + + put (LengthPrefixedBE n) = do + putWord32be len + putLazyByteString bytes + where + bytes = encode_bigendian n + len = fromIntegral (L.length bytes) :: Word32 + + get = do + len <- get + bs <- getLazyByteString (word32_to_int64 len) + return . LengthPrefixedBE $ decode_bigendian bs + where + word32_to_int64 :: Word32 -> Int64 + word32_to_int64 = fromIntegral + + + +encode_bigendian :: (Integral a, Bits a) => a -> L.ByteString +encode_bigendian n = + if (bit /= sbyte) + then sbyte `L.cons` bytes + else bytes + where + bytes = L.reverse $ unroll n + sbyte :: Word8 + sbyte = if n<0 then 0xFF else 0 + bit = if L.null bytes + then 0x00 + else fromIntegral ((fromIntegral (L.head bytes) :: Int8) `shiftR` 7) + + unroll :: (Integral a, Bits a) => a -> L.ByteString + unroll = L.unfoldr step + -- TODO: Is reversing L.unfoldr more or less efficient + -- than using Data.List.unfoldr ? + -- Probably Data.ByteString.Lazy should export an unfoldrEnd + -- function that efficiently unfolds reversed bytestrings. + where + step 0 = Nothing + step (-1) = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + +decode_bigendian :: (Num a, Bits a) => L.ByteString -> a +decode_bigendian bs = if isneg then n - 256^(L.length bs) + else n + where + n = L.foldl (\a b -> a `shiftL` 8 .|. fromIntegral b) 0 bs + isneg = not (L.null bs) && L.head bs .&. 0x80 /= 0 + + diff --git a/lib/SSHKey.hs b/lib/SSHKey.hs new file mode 100644 index 0000000..488f55f --- /dev/null +++ b/lib/SSHKey.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +module SSHKey where + +import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.ByteString.Lazy as L +import qualified Codec.Binary.Base64 as Base64 +import Data.Binary.Get ( runGet ) +import Data.Binary.Put ( putWord32be, runPut, putByteString ) +import Data.Binary ( get, put ) +import Data.Monoid ( (<>) ) +import Data.Maybe ( listToMaybe ) +import Data.Char ( isSpace ) +import Control.Monad ( guard ) +import LengthPrefixedBE + +type Key = (Integer,Integer) + +keyblob :: Key -> L.ByteString +keyblob (n,e) = "ssh-rsa " <> blob + where + bs = sshrsa e n + blob = L8.pack $ Base64.encode (L.unpack bs) + + sshrsa :: Integer -> Integer -> L.ByteString + sshrsa e n = runPut $ do + putWord32be 7 + putByteString "ssh-rsa" + put (LengthPrefixedBE e) + put (LengthPrefixedBE n) + +blobkey :: L8.ByteString -> Maybe Key +blobkey bs = do + let (pre,bs1) = L8.splitAt 7 bs + guard $ pre == "ssh-rsa" + let (sp,bs2) = L8.span isSpace bs1 + guard $ not (L8.null sp) + bs3 <- listToMaybe $ L8.words bs2 + qq <- L.pack `fmap` Base64.decode (L8.unpack bs3) + decode_sshrsa qq + where + decode_sshrsa :: L8.ByteString -> Maybe Key + decode_sshrsa bs = do + let (pre,bs1) = L8.splitAt 11 bs + guard $ pre == runPut (putWord32be 7 >> putByteString "ssh-rsa") + let rsakey = flip runGet bs1 $ do + LengthPrefixedBE e <- get + LengthPrefixedBE n <- get + return (n,e) + return rsakey -- cgit v1.2.3