diff --git a/src/SSH.hs b/src/SSH.hs --- a/src/SSH.hs +++ b/src/SSH.hs @@ -2,18 +2,20 @@ import Control.Concurrent (forkIO) import Control.Concurrent.Chan -import Control.Monad (replicateM) -import Control.Monad.Trans.State +import Control.Monad.State import Data.Digest.Pure.SHA (bytestringDigest, sha1) -import Data.HMAC (hmac_md5, hmac_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 OpenSSL.BN import Network +import OpenSSL.BN (randIntegerOneToNMinusOne) import System.IO import System.Random import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as M +import qualified Data.Serialize as S import SSH.Channel import SSH.Crypto @@ -26,7 +28,7 @@ version :: String -version = "SSH-2.0-DarcsDen" +version = "SSH-2.0-Haskell" supportedKeyExchanges :: [String] supportedKeyExchanges = @@ -48,12 +50,23 @@ supportedMACs :: [(String, LBS.ByteString -> HMAC)] supportedMACs = - [ ("hmac-sha1", makeHMAC 20 hmac_sha1) - , ("hmac-md5", makeHMAC 16 hmac_md5) + [ ("hmac-sha1", makeHMAC 20) + , ("hmac-md5", makeHMAC 16) ] where - makeHMAC s f k = HMAC s $ LBS.pack . f (LBS.unpack . LBS.take (fromIntegral s) $ k) . LBS.unpack + 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 + + bsToLBS = LBS.fromChunks . (: []) + supportedCompression :: String supportedCompression = "none" @@ -69,8 +82,11 @@ waitLoop :: SessionConfig -> ChannelConfig -> Socket -> IO () waitLoop sc cc s = do (handle, hostName, port) <- accept s + + io $ hSetBinaryMode handle True + dump ("got connection from", hostName, port) - + forkIO $ do -- send SSH server version hPutStr handle (version ++ "\r\n") @@ -159,10 +175,18 @@ 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 (splitOn "," . fromLBS) + nameLists <- replicateM 10 (net readLBS) >>= return . map (wordsBy ',' . fromLBS) kpf <- net readByte dummy <- net readULong @@ -232,8 +256,8 @@ send $ Prepare oc - (head . toBlocks (cKeySize oc) $ skey) - (head . toBlocks (cBlockSize oc) $ siv) + (strictLBS $ LBS.take (fromIntegral $ cKeySize oc) $ skey) + (strictLBS $ LBS.take (fromIntegral $ cBlockSize oc) $ siv) (om sinteg) modify (\(GotKEXInit c cc h s p _ _ is _ _ ic _ im) -> @@ -249,8 +273,8 @@ , ssInSeq = is , ssInCipher = ic , ssInHMAC = im cinteg - , ssInKey = head . toBlocks (cKeySize ic) $ ckey - , ssInVector = head . toBlocks (cBlockSize ic) $ civ + , ssInKey = strictLBS $ LBS.take (fromIntegral $ cKeySize ic) $ ckey + , ssInVector = strictLBS $ LBS.take (fromIntegral $ cBlockSize ic) $ civ , ssUser = Nothing }) diff --git a/src/SSH/Channel.hs b/src/SSH/Channel.hs --- a/src/SSH/Channel.hs +++ b/src/SSH/Channel.hs @@ -3,8 +3,7 @@ import Control.Concurrent (forkIO) import Control.Concurrent.Chan -import Control.Monad (when) -import Control.Monad.Trans.State +import Control.Monad.State import Data.Word import System.Exit import System.IO @@ -83,7 +82,7 @@ } newChannel :: ChannelConfig -> (SenderMessage -> IO ()) -> Word32 -> Word32 -> Word32 -> Word32 -> String -> IO (Chan ChannelMessage) -newChannel config send us them winSize maxPacket user = do +newChannel config cssend us them winSize maxPacket user = do chan <- newChan dump ("new channel", winSize, maxPacket) @@ -100,7 +99,7 @@ { csConfig = config , csID = us , csTheirID = them - , csSend = send + , csSend = cssend , csDataReceived = 0 , csMaxPacket = maxPacket , csWindowSize = 32768 * 64 @@ -118,42 +117,44 @@ chanid <- gets csID case msg of - Request wr cr -> gets (ccRequestHandler . csConfig) >>= \f -> f wr cr - Data msg -> do - modify (\c -> c + Request wr cr -> + gets (ccRequestHandler . csConfig) >>= \f -> f wr cr + + Data d -> do + modify $ \cs -> cs { csDataReceived = - csDataReceived c + fromIntegral (LBS.length msg) - }) + csDataReceived cs + fromIntegral (LBS.length d) + } -- Adjust window size if needed rcvd <- gets csDataReceived - max <- gets csMaxPacket + maxp <- gets csMaxPacket winSize <- gets csTheirWindowSize - when (rcvd + (max * 4) >= winSize && winSize + (max * 4) <= 2^32 - 1) $ do - modify (\c -> c { csTheirWindowSize = winSize + (max * 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 (max * 4) + long (maxp * 4) -- Direct input to process's stdin - proc <- gets csProcess - case proc of + csproc <- gets csProcess + case csproc of Nothing -> dump ("got unhandled data", chanid) - Just (Process _ stdin _ _) -> do - dump ("redirecting data", chanid, LBS.length msg) - io $ LBS.hPut stdin msg - io $ hFlush stdin + Just (Process _ pin _ _) -> do + dump ("redirecting data", chanid, LBS.length d) + io $ LBS.hPut pin d + io $ hFlush pin EOF -> do - modify (\c -> c { csDataReceived = 0 }) + modify (\cs -> cs { csDataReceived = 0 }) -- Close process's stdin to indicate EOF - proc <- gets csProcess - case proc of + cproc <- gets csProcess + case cproc of Nothing -> dump ("got unhandled eof") - Just (Process _ stdin _ _) -> do + Just (Process _ pin _ _) -> do dump ("redirecting eof", chanid) - io $ hClose stdin + io $ hClose pin chanLoop c @@ -199,11 +200,8 @@ redirectHandle f d h = get >>= io . forkIO . evalStateT redirectLoop >> return () where redirectLoop = do - target <- gets csTheirID - Just (Process proc _ _ _) <- gets csProcess - dump "reading..." - l <- io $ hGetAvailable h + l <- io getAvailable dump ("read data from handle", l) if not (null l) @@ -216,29 +214,31 @@ then io $ writeChan f () else redirectLoop - hGetAvailable :: Handle -> IO String - hGetAvailable h = do + getAvailable :: IO String + getAvailable = do ready <- hReady h `catch` const (return False) if not ready then return "" else do c <- hGetChar h - cs <- hGetAvailable h + cs <- getAvailable return (c:cs) spawnProcess :: IO (Handle, Handle, Handle, ProcessHandle) -> Channel () spawnProcess cmd = do target <- gets csTheirID - (stdin, stdout, stderr, proc) <- io cmd - modify (\s -> s { csProcess = Just $ Process proc stdin stdout stderr }) + (pin, pout, perr, phdl) <- io cmd + modify (\s -> s { csProcess = Just $ Process phdl pin pout perr }) dump ("command spawned") -- redirect stdout and stderr, using a channel to signal completion done <- io newChan - redirectHandle done (byte 94 >> long target) stdout - redirectHandle done (byte 95 >> long target >> long 1) stderr + io $ hSetBinaryMode pout True + io $ hSetBinaryMode perr True + redirectHandle done (byte 94 >> long target) pout + redirectHandle done (byte 95 >> long target >> long 1) perr s <- get @@ -249,7 +249,7 @@ readChan done dump "done reading output! waiting for process..." - exit <- io $ waitForProcess proc + exit <- io $ waitForProcess phdl dump ("process exited", exit) flip evalStateT s $ do diff --git a/src/SSH/Crypto.hs b/src/SSH/Crypto.hs --- a/src/SSH/Crypto.hs +++ b/src/SSH/Crypto.hs @@ -1,17 +1,14 @@ module SSH.Crypto where -import Codec.Utils (fromOctets, i2osp) -import Control.Monad (replicateM) -import Control.Monad.Trans.State +import Control.Monad.State import Data.Digest.Pure.SHA (bytestringDigest, sha1) -import Data.Int import qualified Codec.Crypto.RSA as RSA import qualified Data.ByteString.Lazy as LBS import qualified OpenSSL.DSA as DSA import SSH.Packet import SSH.NetReader -import SSH.Util (strictLBS) +import SSH.Util data Cipher = Cipher @@ -54,23 +51,30 @@ } deriving (Eq, Show) - generator :: Integer generator = 2 safePrime :: Integer safePrime = 179769313486231590770839156793787453197860296048756011706444423684197180216158519368947833795864925541502180565485980503646440548199239100050792877003355816639229553136239076508735759914822574862575007425302077447712589550957937778424442426617334727629299387668709205606050270810842907692932019128194467627007 -toBlocks :: (Integral a, Integral b) => a -> LBS.ByteString -> [b] +toBlocks :: (Integral a) => a -> LBS.ByteString -> [LBS.ByteString] toBlocks _ m | m == LBS.empty = [] toBlocks bs m = b : rest where - b = fromOctets (256 :: Integer) (LBS.unpack (LBS.take (fromIntegral bs) m)) + b = LBS.take (fromIntegral bs) m rest = toBlocks bs (LBS.drop (fromIntegral bs) m) -fromBlocks :: Integral a => Int -> [a] -> LBS.ByteString -fromBlocks bs = LBS.concat . map (LBS.pack . i2osp bs) +fromBlocks :: [LBS.ByteString] -> LBS.ByteString +fromBlocks = LBS.concat +modexp :: Integer -> Integer -> Integer -> Integer +modexp x' e' n' = modexp' x' e' n' 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 + blob :: PublicKey -> LBS.ByteString blob (RSAPublicKey e n) = doPacket $ do string "ssh-rsa" @@ -113,3 +117,4 @@ ] where digest = strictLBS . bytestringDigest . sha1 $ m +sign x l = error ("cannot sign: " ++ show (x, l)) diff --git a/src/SSH/NetReader.hs b/src/SSH/NetReader.hs --- a/src/SSH/NetReader.hs +++ b/src/SSH/NetReader.hs @@ -1,6 +1,6 @@ module SSH.NetReader where -import Control.Monad.Trans.State +import Control.Monad.State import Data.Binary (decode) import Data.Int import Data.Word diff --git a/src/SSH/Packet.hs b/src/SSH/Packet.hs --- a/src/SSH/Packet.hs +++ b/src/SSH/Packet.hs @@ -1,13 +1,10 @@ module SSH.Packet where -import Codec.Utils (fromOctets, i2osp) -import Control.Monad.IO.Class -import Control.Monad.Trans.Writer +import Control.Monad.Writer import Data.Binary (encode) import Data.Bits ((.&.)) import Data.Digest.Pure.SHA import Data.Word -import System.IO import qualified Data.ByteString.Lazy as LBS import SSH.Util diff --git a/src/SSH/Sender.hs b/src/SSH/Sender.hs --- a/src/SSH/Sender.hs +++ b/src/SSH/Sender.hs @@ -1,18 +1,18 @@ module SSH.Sender where -import Codec.Encryption.Modes import Control.Concurrent.Chan import Control.Monad (replicateM) -import Data.LargeWord import Data.Word import System.IO import System.Random -import qualified Codec.Encryption.AES as A +import qualified Codec.Crypto.SimpleAES as A +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import SSH.Debug import SSH.Crypto import SSH.Packet +import SSH.Util data SenderState @@ -25,13 +25,13 @@ , senderOutSeq :: Word32 , senderEncrypting :: Bool , senderCipher :: Cipher - , senderKey :: Integer - , senderVector :: Integer + , senderKey :: BS.ByteString + , senderVector :: BS.ByteString , senderHMAC :: HMAC } data SenderMessage - = Prepare Cipher Integer Integer HMAC + = Prepare Cipher BS.ByteString BS.ByteString HMAC | StartEncrypting | Send LBS.ByteString @@ -58,7 +58,7 @@ let f = full msg pad case ss of - GotKeys h os True cipher key iv hmac@(HMAC _ mac) -> do + GotKeys h os True cipher key iv (HMAC _ mac) -> do dump ("sending encrypted", os, f) let (encrypted, newVector) = encrypt cipher key iv f LBS.hPut h . LBS.concat $ @@ -100,17 +100,12 @@ then paddingNeeded msg + fromIntegral blockSize else paddingNeeded msg -encrypt :: Cipher -> Integer -> Integer -> LBS.ByteString -> (LBS.ByteString, Integer) -encrypt (Cipher AES CBC bs ks) key vector m = - ( fromBlocks bs encrypted +encrypt :: Cipher -> BS.ByteString -> BS.ByteString -> LBS.ByteString -> (LBS.ByteString, BS.ByteString) +encrypt (Cipher AES CBC bs _) key vector m = + ( fromBlocks encrypted , case encrypted of - (_:_) -> fromIntegral $ last encrypted + (_:_) -> strictLBS (last encrypted) [] -> error ("encrypted data empty for `" ++ show m ++ "' in encrypt") vector ) where - ksCbc = - case ks of - 16 -> cbc A.encrypt (fromIntegral vector) (fromIntegral key :: Word128) - 24 -> cbc A.encrypt (fromIntegral vector) (fromIntegral key :: Word192) - 32 -> cbc A.encrypt (fromIntegral vector) (fromIntegral key :: Word256) - encrypted = ksCbc (toBlocks bs m) + encrypted = toBlocks bs $ A.crypt A.CBC key vector A.Encrypt m diff --git a/src/SSH/Session.hs b/src/SSH/Session.hs --- a/src/SSH/Session.hs +++ b/src/SSH/Session.hs @@ -1,15 +1,13 @@ {-# LANGUAGE TypeSynonymInstances #-} module SSH.Session where -import Codec.Encryption.Modes import Control.Concurrent.Chan -import Control.Monad.IO.Class -import Control.Monad.Trans.State +import Control.Monad.State import Data.Binary (decode, encode) -import Data.LargeWord import Data.Word import System.IO -import qualified Codec.Encryption.AES as A +import qualified Codec.Crypto.SimpleAES as A +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as M @@ -19,6 +17,7 @@ import SSH.NetReader import SSH.Packet import SSH.Sender +import SSH.Util type Session = StateT SessionState IO @@ -61,8 +60,8 @@ , ssInSeq :: Word32 , ssInCipher :: Cipher , ssInHMAC :: HMAC - , ssInKey :: Integer - , ssInVector :: Integer + , ssInKey :: BS.ByteString + , ssInVector :: BS.ByteString , ssUser :: Maybe String } @@ -120,20 +119,16 @@ s <- get case s of Final - { ssInCipher = Cipher AES CBC bs ks + { ssInCipher = Cipher AES CBC bs@16 _ , ssInKey = key , ssInVector = vector } -> do let blocks = toBlocks bs m - ksUnCbc = - case ks of - 16 -> unCbc A.decrypt (fromIntegral vector) (fromIntegral key :: Word128) - 24 -> unCbc A.decrypt (fromIntegral vector) (fromIntegral key :: Word192) - 32 -> unCbc A.decrypt (fromIntegral vector) (fromIntegral key :: Word256) - decrypted = ksUnCbc blocks + decrypted = + A.crypt A.CBC key vector A.Decrypt m - modify (\ss -> ss { ssInVector = fromIntegral $ last blocks }) - return (fromBlocks bs decrypted) + modify (\ss -> ss { ssInVector = strictLBS $ last blocks }) + return decrypted _ -> error "no decrypt for current state" getPacket :: Session () @@ -158,12 +153,21 @@ dump ("got packet", is, first, packetLen, paddingLen) restEnc <- liftIO $ LBS.hGet h (fromIntegral packetLen - firstChunk + 4) + + dump ("got rest", restEnc) + rest <- decrypt restEnc + dump ("decrypted", rest) let decrypted = first `LBS.append` rest payload = extract packetLen paddingLen decrypted + dump ("getting hmac", ms) + mac <- liftIO $ LBS.hGet h ms + + dump ("got mac", mac, decrypted, is) + dump ("hmac'd", f decrypted) dump ("got mac, valid?", verify mac is decrypted f) modify (\ss -> ss { ssPayload = payload }) diff --git a/src/SSH/Util.hs b/src/SSH/Util.hs --- a/src/SSH/Util.hs +++ b/src/SSH/Util.hs @@ -1,5 +1,6 @@ module SSH.Util where +import Data.Word (Word8) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS @@ -12,3 +13,31 @@ strictLBS :: LBS.ByteString -> BS.ByteString strictLBS = BS.concat . LBS.toChunks + +powersOf :: Integral a => a -> [a] +powersOf n = 1 : (map (*n) (powersOf n)) + +toBase :: Integral a => a -> a -> [Word8] +toBase x = + map fromIntegral . + reverse . + map (flip mod x) . + takeWhile (/=0) . + iterate (flip div x) + +toOctets :: Int -> Integer -> [Word8] +toOctets n x = (toBase n . fromIntegral) x + +fromOctets :: (Integral a, Integral b) => a -> [Word8] -> b +fromOctets n x = + fromIntegral $ + sum $ + zipWith (*) (powersOf n) (reverse (map fromIntegral x)) + +i2osp :: Int -> Integer -> [Word8] +i2osp l y = + pad ++ z + where + pad = replicate (l - unPaddedLen) (0x00::Word8) + z = toOctets 256 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.1 +version: 0.2.1 synopsis: A pure-Haskell SSH server library. description: This package was split from darcsden into its own project; documentation is @@ -27,6 +27,11 @@ library hs-source-dirs: src + if impl(ghc >= 6.12) + ghc-options: -Wall -fno-warn-unused-do-bind + else + ghc-options: -Wall + exposed-modules: SSH, SSH.Channel, SSH.Crypto, @@ -37,17 +42,19 @@ other-modules: SSH.Debug, SSH.Util - + build-depends: base >= 4 && < 5, binary, bytestring, - Crypto, + cereal, containers, + crypto-api, + cryptohash, HsOpenSSL >= 0.8, + mtl, network, process, RSA, random, SHA, - split, - transformers + SimpleAES