diff --git a/src/SSH.hs b/src/SSH.hs --- a/src/SSH.hs +++ b/src/SSH.hs @@ -5,11 +5,11 @@ import Control.Monad (replicateM) import Control.Monad.Trans.State import Data.Digest.Pure.SHA (bytestringDigest, sha1) -import Crypto.Classes (Hash) import Crypto.HMAC import Crypto.Hash.MD5 import Crypto.Hash.SHA1 import Data.List (intercalate) +import Data.List.Split (splitOn) import Network import OpenSSL.BN (randIntegerOneToNMinusOne) import System.IO @@ -29,7 +29,7 @@ version :: String -version = "SSH-2.0-Haskell" +version = "SSH-2.0-DarcsDen" supportedKeyExchanges :: [String] supportedKeyExchanges = @@ -51,20 +51,12 @@ supportedMACs :: [(String, LBS.ByteString -> HMAC)] supportedMACs = - [ ("hmac-sha1", makeHMAC 20) - , ("hmac-md5", makeHMAC 16) + [ ("hmac-sha1", makeHMAC True) + , ("hmac-md5", makeHMAC False) ] where - makeHMAC :: Int -> LBS.ByteString -> HMAC - makeHMAC 20 k = HMAC 20 $ \b -> runHmac (doHMAC 20 k b :: SHA1) - makeHMAC 16 k = HMAC 16 $ \b -> runHmac (doHMAC 16 k b :: MD5) - makeHMAC u k = error ("unknown key size: " ++ show (u, k)) - - doHMAC :: Hash c d => Int -> LBS.ByteString -> LBS.ByteString -> d - doHMAC s k b = hmac (MacKey (strictLBS (LBS.take (fromIntegral s) k))) b - - runHmac :: Hash c d => d -> LBS.ByteString - runHmac = bsToLBS . S.runPut . S.put + makeHMAC True k = HMAC 20 $ \b -> bsToLBS . S.runPut $ S.put (hmac (MacKey (strictLBS (LBS.take 20 k))) b :: SHA1) + makeHMAC False k = HMAC 16 $ \b -> bsToLBS . S.runPut $ S.put (hmac (MacKey (strictLBS (LBS.take 16 k))) b :: MD5) bsToLBS = LBS.fromChunks . (: []) @@ -176,18 +168,10 @@ modify (\s -> s { ssInSeq = ssInSeq s + 1 }) readLoop -wordsBy :: Char -> String -> [String] -wordsBy = wordsBy' "" - where - wordsBy' _ _ "" = [] - wordsBy' acc x (c:cs) - | x == c = acc : wordsBy' "" x cs - | otherwise = wordsBy' (acc ++ [c]) x cs - kexInit :: Session () kexInit = do cookie <- net $ readBytes 16 - nameLists <- replicateM 10 (net readLBS) >>= return . map (wordsBy ',' . fromLBS) + nameLists <- replicateM 10 (net readLBS) >>= return . map (splitOn "," . fromLBS) kpf <- net readByte dummy <- net readULong diff --git a/src/SSH/Channel.hs b/src/SSH/Channel.hs --- a/src/SSH/Channel.hs +++ b/src/SSH/Channel.hs @@ -83,7 +83,7 @@ } newChannel :: ChannelConfig -> (SenderMessage -> IO ()) -> Word32 -> Word32 -> Word32 -> Word32 -> String -> IO (Chan ChannelMessage) -newChannel config cssend us them winSize maxPacket user = do +newChannel config csend us them winSize maxPacket user = do chan <- newChan dump ("new channel", winSize, maxPacket) @@ -100,7 +100,7 @@ { csConfig = config , csID = us , csTheirID = them - , csSend = cssend + , csSend = csend , csDataReceived = 0 , csMaxPacket = maxPacket , csWindowSize = 32768 * 64 @@ -118,36 +118,34 @@ chanid <- gets csID case msg of - Request wr cr -> - gets (ccRequestHandler . csConfig) >>= \f -> f wr cr - - Data d -> do + Request wr cr -> gets (ccRequestHandler . csConfig) >>= \f -> f wr cr + Data datum -> do modify $ \cs -> cs { csDataReceived = - csDataReceived cs + fromIntegral (LBS.length d) + csDataReceived cs + fromIntegral (LBS.length datum) } -- Adjust window size if needed rcvd <- gets csDataReceived maxp <- gets csMaxPacket winSize <- gets csTheirWindowSize - when (rcvd + (maxp * 4) >= winSize && winSize + (maxp * 4) <= 2 ^ (32 :: Integer) - 1) $ do - modify (\cs -> cs { csTheirWindowSize = winSize + (maxp * 4) }) + when (rcvd + (maxp * 4) >= winSize && winSize + (maxp * 4) <= 2^(32 :: Integer) - 1) $ do + modify $ \cs -> cs { csTheirWindowSize = winSize + (maxp * 4) } sendPacket $ do byte 93 long chanid long (maxp * 4) -- Direct input to process's stdin - csproc <- gets csProcess - case csproc of + cproc <- gets csProcess + case cproc of Nothing -> dump ("got unhandled data", chanid) Just (Process _ pin _ _) -> do - dump ("redirecting data", chanid, LBS.length d) - io $ LBS.hPut pin d + dump ("redirecting data", chanid, LBS.length datum) + io $ LBS.hPut pin datum io $ hFlush pin EOF -> do - modify (\cs -> cs { csDataReceived = 0 }) + modify $ \cs -> cs { csDataReceived = 0 } -- Close process's stdin to indicate EOF cproc <- gets csProcess @@ -202,7 +200,7 @@ where redirectLoop = do dump "reading..." - l <- io getAvailable + l <- io $ getAvailable dump ("read data from handle", l) if not (null l) diff --git a/src/SSH/Crypto.hs b/src/SSH/Crypto.hs --- a/src/SSH/Crypto.hs +++ b/src/SSH/Crypto.hs @@ -69,12 +69,12 @@ fromBlocks = LBS.concat modexp :: Integer -> Integer -> Integer -> Integer -modexp x' e' n' = modexp' x' e' n' 1 +modexp = modexp' 1 where - modexp' _ 0 _ y = y - modexp' z e n y - | e `mod` 2 == 1 = modexp' ((z ^ (2 :: Integer)) `mod` n) (e `div` 2) n (y * z `mod` n) - | otherwise = modexp' ((z ^ (2 :: Integer)) `mod` n) (e `div` 2) n y + modexp' y _ 0 _ = y + modexp' y z e n + | e `mod` 2 == 1 = modexp' (y * z `mod` n) ((z ^ (2 :: Integer)) `mod` n) (e `div` 2) n + | otherwise = modexp' y ((z ^ (2 :: Integer)) `mod` n) (e `div` 2) n blob :: PublicKey -> LBS.ByteString blob (RSAPublicKey e n) = doPacket $ do @@ -118,4 +118,4 @@ ] where digest = strictLBS . bytestringDigest . sha1 $ m -sign x l = error ("cannot sign: " ++ show (x, l)) +sign _ _ = error "sign: invalid key pair" diff --git a/src/SSH/Util.hs b/src/SSH/Util.hs --- a/src/SSH/Util.hs +++ b/src/SSH/Util.hs @@ -14,10 +14,10 @@ strictLBS :: LBS.ByteString -> BS.ByteString strictLBS = BS.concat . LBS.toChunks -powersOf :: Integral a => a -> [a] +powersOf :: Num a => a -> [a] powersOf n = 1 : (map (*n) (powersOf n)) -toBase :: Integral a => a -> a -> [Word8] +toBase :: (Integral a, Num b) => a -> a -> [b] toBase x = map fromIntegral . reverse . @@ -39,5 +39,5 @@ pad ++ z where pad = replicate (l - unPaddedLen) (0x00::Word8) - z = toOctets 256 y + z = toOctets (256 :: Integer) y unPaddedLen = length z diff --git a/ssh.cabal b/ssh.cabal --- a/ssh.cabal +++ b/ssh.cabal @@ -1,5 +1,5 @@ name: ssh -version: 0.2.3 +version: 0.2.4 synopsis: A pure-Haskell SSH server library. description: This package was split from darcsden into its own project; documentation is @@ -57,4 +57,5 @@ random, SHA, SimpleAES, + split, transformers