ssh 0.1 → 0.2.1
raw patch · 9 files changed
+165/−104 lines, 9 filesdep +SimpleAESdep +cerealdep +crypto-apidep −Cryptodep −splitdep −transformers
Dependencies added: SimpleAES, cereal, crypto-api, cryptohash, mtl
Dependencies removed: Crypto, split, transformers
Files
- src/SSH.hs +39/−15
- src/SSH/Channel.hs +36/−36
- src/SSH/Crypto.hs +15/−10
- src/SSH/NetReader.hs +1/−1
- src/SSH/Packet.hs +1/−4
- src/SSH/Sender.hs +12/−17
- src/SSH/Session.hs +20/−16
- src/SSH/Util.hs +29/−0
- ssh.cabal +12/−5
src/SSH.hs view
@@ -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 })
src/SSH/Channel.hs view
@@ -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
src/SSH/Crypto.hs view
@@ -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))
src/SSH/NetReader.hs view
@@ -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
src/SSH/Packet.hs view
@@ -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
src/SSH/Sender.hs view
@@ -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
src/SSH/Session.hs view
@@ -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 })
src/SSH/Util.hs view
@@ -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
ssh.cabal view
@@ -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