├── Setup.hs ├── src ├── SSH │ ├── Debug.hs │ ├── NetReader.hs │ ├── Util.hs │ ├── Packet.hs │ ├── Sender.hs │ ├── Crypto.hs │ ├── Session.hs │ └── Channel.hs └── SSH.hs ├── LICENSE └── ssh.cabal /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /src/SSH/Debug.hs: -------------------------------------------------------------------------------- 1 | module SSH.Debug where 2 | 3 | import Debug.Trace 4 | 5 | 6 | debugging :: Bool 7 | debugging = False 8 | 9 | debug :: (Show a, Show b) => b -> a -> a 10 | debug s v 11 | | debugging = trace (show s ++ ": " ++ show v) v 12 | | otherwise = v 13 | 14 | dump :: (Monad m, Show a) => a -> m () 15 | dump x 16 | | debugging = trace (show x) (return ()) 17 | | otherwise = return () 18 | 19 | -------------------------------------------------------------------------------- /src/SSH/NetReader.hs: -------------------------------------------------------------------------------- 1 | module SSH.NetReader where 2 | 3 | import Control.Monad.Trans.State 4 | import Data.Binary (decode) 5 | import Data.Int 6 | import Data.Word 7 | import qualified Data.ByteString.Lazy as LBS 8 | 9 | import SSH.Packet 10 | import SSH.Util (fromLBS) 11 | 12 | 13 | type NetReader = State LBS.ByteString 14 | 15 | 16 | readByte :: NetReader Word8 17 | readByte = fmap LBS.head (readBytes 1) 18 | 19 | readLong :: NetReader Int32 20 | readLong = fmap decode (readBytes 4) 21 | 22 | readULong :: NetReader Word32 23 | readULong = fmap decode (readBytes 4) 24 | 25 | readInteger :: NetReader Integer 26 | readInteger = do 27 | len <- readULong 28 | b <- readBytes (fromIntegral len) 29 | return (unmpint b) 30 | 31 | readBytes :: Int -> NetReader LBS.ByteString 32 | readBytes n = do 33 | p <- gets (LBS.take (fromIntegral n)) 34 | modify (LBS.drop (fromIntegral n)) 35 | return p 36 | 37 | readLBS :: NetReader LBS.ByteString 38 | readLBS = readULong >>= readBytes . fromIntegral 39 | 40 | readString :: NetReader String 41 | readString = fmap fromLBS readLBS 42 | 43 | readBool :: NetReader Bool 44 | readBool = readByte >>= return . (== 1) 45 | 46 | -------------------------------------------------------------------------------- /src/SSH/Util.hs: -------------------------------------------------------------------------------- 1 | module SSH.Util where 2 | 3 | import Data.Word (Word8) 4 | import qualified Data.ByteString as BS 5 | import qualified Data.ByteString.Lazy as LBS 6 | 7 | 8 | toLBS :: String -> LBS.ByteString 9 | toLBS = LBS.pack . map (fromIntegral . fromEnum) 10 | 11 | fromLBS :: LBS.ByteString -> String 12 | fromLBS = map (toEnum . fromIntegral) . LBS.unpack 13 | 14 | strictLBS :: LBS.ByteString -> BS.ByteString 15 | strictLBS = BS.concat . LBS.toChunks 16 | 17 | powersOf :: Num a => a -> [a] 18 | powersOf n = 1 : (map (*n) (powersOf n)) 19 | 20 | toBase :: (Integral a, Num b) => a -> a -> [b] 21 | toBase x = 22 | map fromIntegral . 23 | reverse . 24 | map (flip mod x) . 25 | takeWhile (/=0) . 26 | iterate (flip div x) 27 | 28 | toOctets :: (Integral a, Integral b) => a -> b -> [Word8] 29 | toOctets n x = (toBase n . fromIntegral) x 30 | 31 | fromOctets :: (Integral a, Integral b) => a -> [Word8] -> b 32 | fromOctets n x = 33 | fromIntegral $ 34 | sum $ 35 | zipWith (*) (powersOf n) (reverse (map fromIntegral x)) 36 | 37 | i2osp :: Integral a => Int -> a -> [Word8] 38 | i2osp l y = 39 | pad ++ z 40 | where 41 | pad = replicate (l - unPaddedLen) (0x00::Word8) 42 | z = toOctets (256 :: Integer) y 43 | unPaddedLen = length z -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2010, Alex Suraci 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alex Suraci nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/SSH/Packet.hs: -------------------------------------------------------------------------------- 1 | module SSH.Packet where 2 | 3 | import Control.Monad.IO.Class 4 | import Control.Monad.Trans.Writer 5 | import Data.Binary (encode) 6 | import Data.Bits ((.&.)) 7 | import Data.Digest.Pure.SHA 8 | import Data.Word 9 | import qualified Data.ByteString.Lazy as LBS 10 | 11 | import SSH.Util 12 | 13 | 14 | type Packet a = Writer LBS.ByteString a 15 | 16 | byte :: Word8 -> Packet () 17 | byte = tell . encode 18 | 19 | long :: Word32 -> Packet () 20 | long = tell . encode 21 | 22 | integer :: Integer -> Packet () 23 | integer = tell . mpint 24 | 25 | byteString :: LBS.ByteString -> Packet () 26 | byteString = tell . netLBS 27 | 28 | string :: String -> Packet () 29 | string = byteString . toLBS 30 | 31 | raw :: LBS.ByteString -> Packet () 32 | raw = tell 33 | 34 | rawString :: String -> Packet () 35 | rawString = tell . toLBS 36 | 37 | packetLength :: Packet () -> Int 38 | packetLength = fromIntegral . LBS.length . doPacket 39 | 40 | doPacket :: Packet a -> LBS.ByteString 41 | doPacket = execWriter 42 | 43 | netString :: String -> LBS.ByteString 44 | netString = netLBS . toLBS 45 | 46 | netLBS :: LBS.ByteString -> LBS.ByteString 47 | netLBS bs = encode (fromIntegral (LBS.length bs) :: Word32) `LBS.append` bs 48 | 49 | io :: MonadIO m => IO a -> m a 50 | io = liftIO 51 | 52 | unmpint :: LBS.ByteString -> Integer 53 | unmpint = fromOctets (256 :: Integer) . LBS.unpack 54 | 55 | mpint :: Integer -> LBS.ByteString 56 | mpint i = netLBS (if LBS.head enc .&. 128 > 0 57 | then 0 `LBS.cons` enc 58 | else enc) 59 | where 60 | enc = LBS.pack (i2osp 0 i) 61 | 62 | -- warning: don't try to send this; it's an infinite bytestring. 63 | -- take whatever length the key needs. 64 | makeKey :: Integer -> LBS.ByteString -> Char -> LBS.ByteString 65 | makeKey s h c = makeKey' initial 66 | where 67 | initial = bytestringDigest . sha1 . LBS.concat $ 68 | [ mpint s 69 | , h 70 | , LBS.singleton . fromIntegral . fromEnum $ c 71 | , h 72 | ] 73 | 74 | makeKey' acc = LBS.concat 75 | [ acc 76 | , makeKey' (bytestringDigest . sha1 . LBS.concat $ [mpint s, h, acc]) 77 | ] 78 | 79 | -------------------------------------------------------------------------------- /ssh.cabal: -------------------------------------------------------------------------------- 1 | name: ssh 2 | version: 0.2.8 3 | synopsis: A pure-Haskell SSH server library. 4 | description: 5 | This package was split from darcsden into its own project; documentation 6 | is lacking, but you can find example usage here: 7 | 8 | . 9 | 10 | This is not a standalone SSH server - it is intended to be used as 11 | a library for implementing your own servers that handle requests and 12 | authorization, etc. Similar to Python's Twisted Conch library. 13 | homepage: http://darcsden.com/alex/ssh 14 | license: BSD3 15 | license-file: LICENSE 16 | author: Alex Suraci 17 | maintainer: i.am@toogeneric.com 18 | category: Network 19 | build-type: Simple 20 | cabal-version: >= 1.6 21 | stability: Unstable 22 | 23 | source-repository head 24 | type: darcs 25 | location: http://darcsden.com/alex/ssh 26 | 27 | library 28 | hs-source-dirs: src 29 | 30 | if impl(ghc >= 6.12) 31 | ghc-options: -Wall -fno-warn-unused-do-bind 32 | else 33 | ghc-options: -Wall 34 | 35 | exposed-modules: SSH, 36 | SSH.Channel, 37 | SSH.Crypto, 38 | SSH.NetReader, 39 | SSH.Packet, 40 | SSH.Sender, 41 | SSH.Session 42 | 43 | other-modules: SSH.Debug, 44 | SSH.Util 45 | 46 | build-depends: asn1-data >= 0.5 && < 0.6, 47 | base >= 4 && < 5, 48 | base64-string, 49 | binary, 50 | bytestring, 51 | cereal, 52 | containers, 53 | crypto-api, 54 | cryptohash, 55 | HsOpenSSL >= 0.8, 56 | network, 57 | process, 58 | RSA>=0.1.2.1.0, 59 | crypto-pubkey-types>=0.1.1, 60 | random, 61 | SHA, 62 | SimpleAES, 63 | split, 64 | transformers 65 | -------------------------------------------------------------------------------- /src/SSH/Sender.hs: -------------------------------------------------------------------------------- 1 | module SSH.Sender where 2 | 3 | import Control.Concurrent.Chan 4 | import Control.Monad (replicateM) 5 | import Data.Word 6 | import System.IO 7 | import System.Random 8 | import qualified Codec.Crypto.SimpleAES as A 9 | import qualified Data.ByteString as BS 10 | import qualified Data.ByteString.Lazy as LBS 11 | 12 | import SSH.Debug 13 | import SSH.Crypto 14 | import SSH.Packet 15 | import SSH.Util 16 | 17 | 18 | data SenderState 19 | = NoKeys 20 | { senderThem :: Handle 21 | , senderOutSeq :: Word32 22 | } 23 | | GotKeys 24 | { senderThem :: Handle 25 | , senderOutSeq :: Word32 26 | , senderEncrypting :: Bool 27 | , senderCipher :: Cipher 28 | , senderKey :: BS.ByteString 29 | , senderVector :: BS.ByteString 30 | , senderHMAC :: HMAC 31 | } 32 | 33 | data SenderMessage 34 | = Prepare Cipher BS.ByteString BS.ByteString HMAC 35 | | StartEncrypting 36 | | Send LBS.ByteString 37 | | Stop 38 | 39 | class Sender a where 40 | send :: SenderMessage -> a () 41 | 42 | sendPacket :: Packet () -> a () 43 | sendPacket = send . Send . doPacket 44 | 45 | sender :: Chan SenderMessage -> SenderState -> IO () 46 | sender ms ss = do 47 | m <- readChan ms 48 | case m of 49 | Stop -> return () 50 | Prepare cipher key iv hmac -> do 51 | dump ("initiating encryption", key, iv) 52 | sender ms (GotKeys (senderThem ss) (senderOutSeq ss) False cipher key iv hmac) 53 | StartEncrypting -> do 54 | dump ("starting encryption") 55 | sender ms (ss { senderEncrypting = True }) 56 | Send msg -> do 57 | pad <- fmap (LBS.pack . map fromIntegral) $ 58 | replicateM (fromIntegral $ paddingLen msg) (randomRIO (0, 255 :: Int)) 59 | 60 | let f = full msg pad 61 | 62 | case ss of 63 | GotKeys h os True cipher key iv (HMAC _ mac) -> do 64 | dump ("sending encrypted", os, f) 65 | let (encrypted, newVector) = encrypt cipher key iv f 66 | LBS.hPut h . LBS.concat $ 67 | [ encrypted 68 | , mac . doPacket $ long os >> raw f 69 | ] 70 | hFlush h 71 | sender ms $ ss 72 | { senderOutSeq = senderOutSeq ss + 1 73 | , senderVector = newVector 74 | } 75 | _ -> do 76 | dump ("sending unencrypted", senderOutSeq ss, f) 77 | LBS.hPut (senderThem ss) f 78 | hFlush (senderThem ss) 79 | sender ms (ss { senderOutSeq = senderOutSeq ss + 1 }) 80 | where 81 | blockSize = 82 | case ss of 83 | GotKeys { senderCipher = Cipher _ _ bs _ } 84 | | bs > 8 -> bs 85 | _ -> 8 86 | 87 | full msg pad = doPacket $ do 88 | long (len msg) 89 | byte (paddingLen msg) 90 | raw msg 91 | raw pad 92 | 93 | len :: LBS.ByteString -> Word32 94 | len msg = 1 + fromIntegral (LBS.length msg) + fromIntegral (paddingLen msg) 95 | 96 | paddingNeeded :: LBS.ByteString -> Word8 97 | paddingNeeded msg = fromIntegral blockSize - (fromIntegral $ (5 + LBS.length msg) `mod` fromIntegral blockSize) 98 | 99 | paddingLen :: LBS.ByteString -> Word8 100 | paddingLen msg = 101 | if paddingNeeded msg < 4 102 | then paddingNeeded msg + fromIntegral blockSize 103 | else paddingNeeded msg 104 | 105 | encrypt :: Cipher -> BS.ByteString -> BS.ByteString -> LBS.ByteString -> (LBS.ByteString, BS.ByteString) 106 | encrypt (Cipher AES CBC bs _) key vector m = 107 | ( fromBlocks encrypted 108 | , case encrypted of 109 | (_:_) -> strictLBS (last encrypted) 110 | [] -> error ("encrypted data empty for `" ++ show m ++ "' in encrypt") vector 111 | ) 112 | where 113 | encrypted = toBlocks bs $ A.crypt A.CBC key vector A.Encrypt m 114 | -------------------------------------------------------------------------------- /src/SSH/Crypto.hs: -------------------------------------------------------------------------------- 1 | module SSH.Crypto where 2 | 3 | import Control.Monad (replicateM) 4 | import Control.Monad.Trans.State 5 | import Data.ASN1.BER (decodeASN1Stream) 6 | import Data.ASN1.Stream 7 | import Data.Digest.Pure.SHA (bytestringDigest, sha1) 8 | import Data.List (isPrefixOf) 9 | import qualified Codec.Binary.Base64.String as B64 10 | import qualified Codec.Crypto.RSA as RSA 11 | import qualified Crypto.Types.PubKey.RSA as RSA 12 | import qualified Data.ByteString.Lazy as LBS 13 | import qualified OpenSSL.DSA as DSA 14 | 15 | import SSH.Packet 16 | import SSH.NetReader 17 | import SSH.Util 18 | 19 | data Cipher = 20 | Cipher 21 | { cType :: CipherType 22 | , cMode :: CipherMode 23 | , cBlockSize :: Int 24 | , cKeySize :: Int 25 | } 26 | 27 | data CipherType = AES 28 | data CipherMode = CBC 29 | 30 | data HMAC = 31 | HMAC 32 | { hDigestSize :: Int 33 | , hFunction :: LBS.ByteString -> LBS.ByteString 34 | } 35 | 36 | data PublicKey 37 | = RSAPublicKey 38 | { rpubE :: Integer 39 | , rpubN :: Integer 40 | } 41 | | DSAPublicKey 42 | { dpubP :: Integer 43 | , dpubQ :: Integer 44 | , dpubG :: Integer 45 | , dpubY :: Integer 46 | } 47 | deriving (Eq, Show) 48 | 49 | data KeyPair 50 | = RSAKeyPair 51 | { rprivPub :: PublicKey 52 | , rprivD :: Integer 53 | } 54 | | DSAKeyPair 55 | { dprivPub :: PublicKey 56 | , dprivX :: Integer 57 | } 58 | deriving (Eq, Show) 59 | 60 | 61 | rsaKeyPairFromFile :: FilePath -> IO KeyPair 62 | rsaKeyPairFromFile fn = do 63 | x <- readFile fn 64 | let asn1 65 | = B64.decode 66 | . concat 67 | . filter (not . ("--" `isPrefixOf`)) 68 | . lines 69 | $ x 70 | 71 | case decodeASN1Stream (toLBS asn1) of 72 | Right (Start Sequence:ss) 73 | | all isIntVal (fst $ getConstructedEnd 0 ss) -> 74 | let (is, _) = getConstructedEnd 0 ss 75 | in return $ RSAKeyPair 76 | { rprivPub = RSAPublicKey 77 | { rpubE = intValAt 2 is 78 | , rpubN = intValAt 1 is 79 | } 80 | , rprivD = intValAt 3 is 81 | } 82 | Right u -> error ("unknown ASN1 decoding result: " ++ show u) 83 | Left e -> error ("ASN1 decoding of private key failed: " ++ show e) 84 | where 85 | isIntVal (IntVal _) = True 86 | isIntVal _ = False 87 | 88 | intValAt i is = 89 | case is !! i of 90 | IntVal n -> n 91 | x -> error ("not an IntVal: " ++ show x) 92 | 93 | generator :: Integer 94 | generator = 2 95 | 96 | safePrime :: Integer 97 | safePrime = 179769313486231590770839156793787453197860296048756011706444423684197180216158519368947833795864925541502180565485980503646440548199239100050792877003355816639229553136239076508735759914822574862575007425302077447712589550957937778424442426617334727629299387668709205606050270810842907692932019128194467627007 98 | 99 | toBlocks :: (Integral a) => a -> LBS.ByteString -> [LBS.ByteString] 100 | toBlocks _ m | m == LBS.empty = [] 101 | toBlocks bs m = b : rest 102 | where 103 | b = LBS.take (fromIntegral bs) m 104 | rest = toBlocks bs (LBS.drop (fromIntegral bs) m) 105 | 106 | fromBlocks :: [LBS.ByteString] -> LBS.ByteString 107 | fromBlocks = LBS.concat 108 | 109 | modexp :: Integer -> Integer -> Integer -> Integer 110 | modexp = modexp' 1 111 | where 112 | modexp' y _ 0 _ = y 113 | modexp' y z e n 114 | | e `mod` 2 == 1 = modexp' (y * z `mod` n) ((z ^ (2 :: Integer)) `mod` n) (e `div` 2) n 115 | | otherwise = modexp' y ((z ^ (2 :: Integer)) `mod` n) (e `div` 2) n 116 | 117 | blob :: PublicKey -> LBS.ByteString 118 | blob (RSAPublicKey e n) = doPacket $ do 119 | string "ssh-rsa" 120 | integer e 121 | integer n 122 | blob (DSAPublicKey p q g y) = doPacket $ do 123 | string "ssh-dss" 124 | integer p 125 | integer q 126 | integer g 127 | integer y 128 | 129 | blobToKey :: LBS.ByteString -> PublicKey 130 | blobToKey s = flip evalState s $ do 131 | t <- readString 132 | 133 | case t of 134 | "ssh-rsa" -> do 135 | e <- readInteger 136 | n <- readInteger 137 | return $ RSAPublicKey e n 138 | "ssh-dss" -> do 139 | [p, q, g, y] <- replicateM 4 readInteger 140 | return $ DSAPublicKey p q g y 141 | u -> error $ "unknown public key format: " ++ u 142 | 143 | sign :: KeyPair -> LBS.ByteString -> IO LBS.ByteString 144 | sign (RSAKeyPair (RSAPublicKey _ n) d) m = return $ LBS.concat 145 | [ netString "ssh-rsa" 146 | , netLBS (RSA.rsassa_pkcs1_v1_5_sign RSA.ha_SHA1 (RSA.PrivateKey 256 n d 0 0 0 0 0) m) 147 | ] 148 | sign (DSAKeyPair (DSAPublicKey p q g y) x) m = do 149 | (r, s) <- DSA.signDigestedDataWithDSA (DSA.tupleToDSAKeyPair (p, q, g, y, x)) digest 150 | return $ LBS.concat 151 | [ netString "ssh-dss" 152 | , netLBS $ LBS.concat 153 | [ LBS.pack $ i2osp 20 r 154 | , LBS.pack $ i2osp 20 s 155 | ] 156 | ] 157 | where 158 | digest = strictLBS . bytestringDigest . sha1 $ m 159 | sign _ _ = error "sign: invalid key pair" 160 | -------------------------------------------------------------------------------- /src/SSH/Session.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} 2 | module SSH.Session where 3 | 4 | import Control.Concurrent.Chan 5 | import Control.Monad.IO.Class 6 | import Control.Monad.Trans.State 7 | import Data.Binary (decode, encode) 8 | import Data.Word 9 | import System.IO 10 | import qualified Codec.Crypto.SimpleAES as A 11 | import qualified Data.ByteString as BS 12 | import qualified Data.ByteString.Lazy as LBS 13 | import qualified Data.Map as M 14 | 15 | import SSH.Channel 16 | import SSH.Crypto 17 | import SSH.Debug 18 | import SSH.NetReader 19 | import SSH.Packet 20 | import SSH.Sender 21 | import SSH.Util 22 | 23 | 24 | type Session = StateT SessionState IO 25 | 26 | data SessionState 27 | = Initial 28 | { ssConfig :: SessionConfig 29 | , ssChannelConfig :: ChannelConfig 30 | , ssThem :: Handle 31 | , ssSend :: SenderMessage -> IO () 32 | , ssPayload :: LBS.ByteString 33 | , ssTheirVersion :: String 34 | , ssOurKEXInit :: LBS.ByteString 35 | , ssInSeq :: Word32 36 | } 37 | | GotKEXInit 38 | { ssConfig :: SessionConfig 39 | , ssChannelConfig :: ChannelConfig 40 | , ssThem :: Handle 41 | , ssSend :: SenderMessage -> IO () 42 | , ssPayload :: LBS.ByteString 43 | , ssTheirVersion :: String 44 | , ssOurKEXInit :: LBS.ByteString 45 | , ssInSeq :: Word32 46 | , ssTheirKEXInit :: LBS.ByteString 47 | , ssOutCipher :: Cipher 48 | , ssInCipher :: Cipher 49 | , ssOutHMACPrep :: LBS.ByteString -> HMAC 50 | , ssInHMACPrep :: LBS.ByteString -> HMAC 51 | } 52 | | Final 53 | { ssConfig :: SessionConfig 54 | , ssChannelConfig :: ChannelConfig 55 | , ssChannels :: M.Map Word32 (Chan ChannelMessage) 56 | , ssID :: LBS.ByteString 57 | , ssThem :: Handle 58 | , ssSend :: SenderMessage -> IO () 59 | , ssPayload :: LBS.ByteString 60 | , ssGotNEWKEYS :: Bool 61 | , ssInSeq :: Word32 62 | , ssInCipher :: Cipher 63 | , ssInHMAC :: HMAC 64 | , ssInKey :: BS.ByteString 65 | , ssInVector :: BS.ByteString 66 | , ssUser :: Maybe String 67 | } 68 | 69 | data SessionConfig = 70 | SessionConfig 71 | { scAuthMethods :: [String] 72 | , scAuthorize :: Authorize -> Session Bool 73 | , scKeyPair :: KeyPair 74 | } 75 | 76 | data Authorize 77 | = Password String String 78 | | PublicKey String PublicKey 79 | 80 | instance Sender Session where 81 | send m = gets ssSend >>= io . ($ m) 82 | 83 | 84 | defaultSessionConfig :: SessionConfig 85 | defaultSessionConfig = 86 | SessionConfig 87 | { scAuthMethods = ["publickey"] 88 | , scAuthorize = const (return True) 89 | , scKeyPair = RSAKeyPair (RSAPublicKey 0 0) 0 90 | {-\(Password u p) ->-} 91 | {-return $ u == "test" && p == "test"-} 92 | } 93 | 94 | net :: NetReader a -> Session a 95 | net r = do 96 | pl <- gets ssPayload 97 | 98 | let (res, new) = runState r pl 99 | 100 | modify (\s -> s { ssPayload = new }) 101 | return res 102 | 103 | newChannelID :: Session Word32 104 | newChannelID = gets ssChannels >>= return . findNext . M.keys 105 | where 106 | findNext :: [Word32] -> Word32 107 | findNext ks = head . filter (not . (`elem` ks)) $ [0..] 108 | 109 | getChannel :: Word32 -> Session (Chan ChannelMessage) 110 | getChannel i = do 111 | mc <- gets (M.lookup i . ssChannels) 112 | case mc of 113 | Just c -> return c 114 | Nothing -> error $ "unknown channel: " ++ show i 115 | 116 | decrypt :: LBS.ByteString -> Session LBS.ByteString 117 | decrypt m 118 | | m == LBS.empty = return m 119 | | otherwise = do 120 | s <- get 121 | case s of 122 | Final 123 | { ssInCipher = Cipher AES CBC bs@16 _ 124 | , ssInKey = key 125 | , ssInVector = vector 126 | } -> do 127 | let blocks = toBlocks bs m 128 | decrypted = 129 | A.crypt A.CBC key vector A.Decrypt m 130 | 131 | modify (\ss -> ss { ssInVector = strictLBS $ last blocks }) 132 | return decrypted 133 | _ -> error "no decrypt for current state" 134 | 135 | getPacket :: Session () 136 | getPacket = do 137 | s <- get 138 | h <- gets ssThem 139 | case s of 140 | Final 141 | { ssGotNEWKEYS = True 142 | , ssInCipher = Cipher _ _ bs _ 143 | , ssInHMAC = HMAC ms f 144 | , ssInSeq = is 145 | } -> do 146 | let firstChunk = max 8 bs 147 | 148 | firstEnc <- liftIO $ LBS.hGet h firstChunk 149 | first <- decrypt firstEnc 150 | 151 | let packetLen = decode (LBS.take 4 first) :: Word32 152 | paddingLen = decode (LBS.drop 4 first) :: Word8 153 | 154 | dump ("got packet", is, first, packetLen, paddingLen) 155 | 156 | restEnc <- liftIO $ LBS.hGet h (fromIntegral packetLen - firstChunk + 4) 157 | 158 | dump ("got rest", restEnc) 159 | 160 | rest <- decrypt restEnc 161 | 162 | dump ("decrypted", rest) 163 | let decrypted = first `LBS.append` rest 164 | payload = extract packetLen paddingLen decrypted 165 | 166 | dump ("getting hmac", ms) 167 | 168 | mac <- liftIO $ LBS.hGet h ms 169 | 170 | dump ("got mac", mac, decrypted, is) 171 | dump ("hmac'd", f decrypted) 172 | dump ("got mac, valid?", verify mac is decrypted f) 173 | 174 | modify (\ss -> ss { ssPayload = payload }) 175 | _ -> do 176 | first <- liftIO $ LBS.hGet h 5 177 | 178 | let packetLen = decode (LBS.take 4 first) :: Word32 179 | paddingLen = decode (LBS.drop 4 first) :: Word8 180 | 181 | rest <- liftIO $ LBS.hGet h (fromIntegral packetLen - 5 + 4) 182 | let payload = LBS.take (fromIntegral packetLen - fromIntegral paddingLen - 1) rest 183 | modify (\ss -> ss { ssPayload = payload }) 184 | where 185 | extract pkl pdl d = LBS.take (fromIntegral pkl - fromIntegral pdl - 1) (LBS.drop 5 d) 186 | verify m is d f = m == f (encode (fromIntegral is :: Word32) `LBS.append` d) 187 | -------------------------------------------------------------------------------- /src/SSH/Channel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} 2 | module SSH.Channel where 3 | 4 | import Control.Concurrent 5 | import Control.Monad (when) 6 | import Control.Monad.Trans.State 7 | import Data.Word 8 | import System.Exit 9 | import System.IO 10 | import System.Process 11 | import qualified Data.ByteString.Lazy as LBS 12 | 13 | import SSH.Debug 14 | import SSH.Packet 15 | import SSH.Sender 16 | 17 | type Channel = StateT ChannelState IO 18 | 19 | data ChannelState = 20 | ChannelState 21 | { csConfig :: ChannelConfig 22 | , csID :: Word32 23 | , csTheirID :: Word32 24 | , csSend :: SenderMessage -> IO () 25 | , csDataReceived :: Word32 26 | , csMaxPacket :: Word32 27 | , csWindowSize :: Word32 28 | , csTheirWindowSize :: Word32 29 | , csUser :: String 30 | , csProcess :: Maybe Process 31 | , csRedirector :: Maybe ThreadId 32 | } 33 | 34 | data ChannelMessage 35 | = Request Bool ChannelRequest 36 | | Data LBS.ByteString 37 | | EOF 38 | | Interrupt 39 | deriving Show 40 | 41 | data ChannelConfig = 42 | ChannelConfig 43 | { ccRequestHandler :: Bool -> ChannelRequest -> Channel () 44 | } 45 | 46 | data ChannelRequest 47 | = Shell 48 | | Execute String 49 | | Subsystem String 50 | | X11Forwarding 51 | | Environment String String 52 | | PseudoTerminal String Word32 Word32 Word32 Word32 String 53 | | WindowChange Word32 Word32 Word32 Word32 54 | | Signal String 55 | | ExitStatus Word32 56 | | ExitSignal String Bool String String 57 | | FlowControl Bool 58 | | Unknown String 59 | deriving Show 60 | 61 | data Process = 62 | Process 63 | { pHandle :: ProcessHandle 64 | , pIn :: Handle 65 | , pOut :: Handle 66 | , pError :: Handle 67 | } 68 | 69 | instance Sender Channel where 70 | send m = gets csSend >>= io . ($ m) 71 | 72 | 73 | defaultChannelConfig :: ChannelConfig 74 | defaultChannelConfig = 75 | ChannelConfig 76 | { ccRequestHandler = \wr req -> 77 | case req of 78 | Execute cmd -> do 79 | spawnProcess (runInteractiveCommand cmd) 80 | when wr channelSuccess 81 | _ -> do 82 | channelError "accepting 'exec' requests only" 83 | when wr channelFail 84 | } 85 | 86 | newChannel :: ChannelConfig -> (SenderMessage -> IO ()) -> Word32 -> Word32 -> Word32 -> Word32 -> String -> IO (Chan ChannelMessage) 87 | newChannel config csend us them winSize maxPacket user = do 88 | chan <- newChan 89 | 90 | dump ("new channel", winSize, maxPacket) 91 | forkIO $ evalStateT (do 92 | sendPacket $ do 93 | byte 91 94 | long them 95 | long us 96 | long (32768 * 64) 97 | long 32768 98 | 99 | chanLoop chan) $ 100 | ChannelState 101 | { csConfig = config 102 | , csID = us 103 | , csTheirID = them 104 | , csSend = csend 105 | , csDataReceived = 0 106 | , csMaxPacket = maxPacket 107 | , csWindowSize = 32768 * 64 108 | , csTheirWindowSize = winSize 109 | , csUser = user 110 | , csProcess = Nothing 111 | , csRedirector = Nothing 112 | } 113 | 114 | return chan 115 | 116 | chanLoop :: Chan ChannelMessage -> Channel () 117 | chanLoop c = do 118 | msg <- io (readChan c) 119 | dump ("got channel message", msg) 120 | 121 | chanid <- gets csID 122 | case msg of 123 | Request wr cr -> do 124 | handler <- gets (ccRequestHandler . csConfig) 125 | handler wr cr 126 | 127 | chanLoop c 128 | 129 | Data datum -> do 130 | modify $ \cs -> cs 131 | { csDataReceived = 132 | csDataReceived cs + fromIntegral (LBS.length datum) 133 | } 134 | 135 | -- Adjust window size if needed 136 | rcvd <- gets csDataReceived 137 | maxp <- gets csMaxPacket 138 | winSize <- gets csTheirWindowSize 139 | when (rcvd + (maxp * 4) >= winSize && winSize + (maxp * 4) <= 2^(32 :: Integer) - 1) $ do 140 | modify $ \cs -> cs { csTheirWindowSize = winSize + (maxp * 4) } 141 | sendPacket $ do 142 | byte 93 143 | long chanid 144 | long (maxp * 4) 145 | 146 | -- Direct input to process's stdin 147 | cproc <- gets csProcess 148 | case cproc of 149 | Nothing -> dump ("got unhandled data", chanid) 150 | Just (Process _ pin _ _) -> do 151 | dump ("redirecting data", chanid, LBS.length datum) 152 | io $ LBS.hPut pin datum 153 | io $ hFlush pin 154 | 155 | chanLoop c 156 | 157 | EOF -> do 158 | modify $ \cs -> cs { csDataReceived = 0 } 159 | 160 | -- Close process's stdin to indicate EOF 161 | cproc <- gets csProcess 162 | case cproc of 163 | Nothing -> dump ("got unhandled eof") 164 | Just (Process _ pin _ _) -> do 165 | dump ("redirecting eof", chanid) 166 | io $ hClose pin 167 | 168 | chanLoop c 169 | 170 | Interrupt -> do 171 | -- shut down the i/o redirecting process 172 | redir <- gets csRedirector 173 | case redir of 174 | Nothing -> return () 175 | Just tid -> io (killThread tid) 176 | 177 | cproc <- gets csProcess 178 | case cproc of 179 | Nothing -> return () 180 | Just (Process phdl _ _ _) -> do 181 | -- NOTE: this doesn't necessarily guarantee termination 182 | -- see System.Process docs 183 | io $ terminateProcess phdl 184 | 185 | 186 | channelError :: String -> Channel () 187 | channelError msg = do 188 | target <- gets csTheirID 189 | sendPacket $ do 190 | byte 95 191 | long target 192 | long 1 193 | string (msg ++ "\r\n") 194 | 195 | channelMessage :: String -> Channel () 196 | channelMessage msg = do 197 | target <- gets csTheirID 198 | sendPacket $ do 199 | byte 94 200 | long target 201 | string (msg ++ "\r\n") 202 | 203 | channelFail :: Channel () 204 | channelFail = do 205 | target <- gets csTheirID 206 | sendPacket $ do 207 | byte 100 208 | long target 209 | 210 | channelSuccess :: Channel () 211 | channelSuccess = do 212 | target <- gets csTheirID 213 | sendPacket $ do 214 | byte 99 215 | long target 216 | 217 | channelDone :: Channel () 218 | channelDone = do 219 | target <- gets csTheirID 220 | sendPacket (byte 96 >> long target) -- eof 221 | sendPacket (byte 97 >> long target) -- close 222 | 223 | sendChunks :: Integral a => a -> Packet () -> String -> Channel () 224 | sendChunks _ _ "" = return () 225 | sendChunks n p s = do 226 | sendPacket (p >> string chunk) 227 | sendChunks n p rest 228 | where 229 | (chunk, rest) = splitAt (fromIntegral n - packetLength p) s 230 | 231 | redirectHandle :: Chan () -> Packet () -> Handle -> Channel () 232 | redirectHandle f d h = do 233 | s <- get 234 | r <- io . forkIO . evalStateT redirectLoop $ s 235 | modify $ \cs -> cs { csRedirector = Just r } 236 | where 237 | redirectLoop = do 238 | maxLen <- gets csMaxPacket 239 | 240 | dump "reading..." 241 | l <- io $ getAvailable 242 | dump ("read data from handle", l) 243 | 244 | if not (null l) 245 | then sendChunks maxLen d l 246 | else return () 247 | 248 | done <- io $ hIsEOF h 249 | dump ("eof handle?", done) 250 | if done 251 | then io $ writeChan f () 252 | else redirectLoop 253 | 254 | getAvailable :: IO String 255 | getAvailable = do 256 | ready <- hReady h `catch` const (return False) 257 | if not ready 258 | then return "" 259 | else do 260 | c <- hGetChar h 261 | cs <- getAvailable 262 | return (c:cs) 263 | 264 | spawnProcess :: IO (Handle, Handle, Handle, ProcessHandle) -> Channel () 265 | spawnProcess cmd = do 266 | target <- gets csTheirID 267 | 268 | (pin, pout, perr, phdl) <- io cmd 269 | modify (\s -> s { csProcess = Just $ Process phdl pin pout perr }) 270 | 271 | dump ("command spawned") 272 | 273 | -- redirect stdout and stderr, using a channel to signal completion 274 | done <- io newChan 275 | io $ hSetBinaryMode pout True 276 | io $ hSetBinaryMode perr True 277 | redirectHandle done (byte 94 >> long target) pout 278 | redirectHandle done (byte 95 >> long target >> long 1) perr 279 | 280 | s <- get 281 | 282 | -- spawn a thread to wait for the process to terminate 283 | io . forkIO $ do 284 | -- wait until both are done 285 | readChan done 286 | readChan done 287 | 288 | dump "done reading output! waiting for process..." 289 | exit <- io $ waitForProcess phdl 290 | dump ("process exited", exit) 291 | 292 | flip evalStateT s $ do 293 | sendPacket $ do 294 | byte 98 295 | long target 296 | string "exit-status" 297 | byte 0 298 | long (statusCode exit) 299 | 300 | channelDone 301 | 302 | return () 303 | where 304 | statusCode ExitSuccess = 0 305 | statusCode (ExitFailure n) = fromIntegral n 306 | 307 | -------------------------------------------------------------------------------- /src/SSH.hs: -------------------------------------------------------------------------------- 1 | module SSH where 2 | 3 | import Control.Concurrent (forkIO) 4 | import Control.Concurrent.Chan 5 | import Control.Monad (replicateM, when) 6 | import Control.Monad.Trans.State 7 | import Data.Digest.Pure.SHA (bytestringDigest, sha1) 8 | import Crypto.HMAC 9 | import Crypto.Hash.MD5 10 | import Crypto.Hash.SHA1 11 | import Data.List (intercalate) 12 | import Data.List.Split (splitOn) 13 | import Network 14 | import OpenSSL.BN (randIntegerOneToNMinusOne) 15 | import System.IO 16 | import System.Random 17 | import qualified Data.ByteString.Lazy as LBS 18 | import qualified Data.Map as M 19 | import qualified Data.Serialize as S 20 | 21 | import SSH.Channel 22 | import SSH.Crypto 23 | import SSH.Debug 24 | import SSH.NetReader 25 | import SSH.Packet 26 | import SSH.Sender 27 | import SSH.Session 28 | import SSH.Util 29 | 30 | 31 | version :: String 32 | version = "SSH-2.0-DarcsDen" 33 | 34 | supportedKeyExchanges :: [String] 35 | supportedKeyExchanges = 36 | {-"diffie-hellman-group-exchange-sha1," ++-} 37 | ["diffie-hellman-group1-sha1"] 38 | 39 | supportedKeyAlgorithms :: [String] 40 | supportedKeyAlgorithms = ["ssh-rsa", "ssh-dss"] 41 | 42 | supportedCiphers :: [(String, Cipher)] 43 | supportedCiphers = 44 | [ ("aes256-cbc", aesCipher CBC 32) 45 | , ("aes192-cbc", aesCipher CBC 24) 46 | , ("aes128-cbc", aesCipher CBC 16) 47 | ] 48 | where 49 | aesCipher m s = 50 | Cipher AES m 16 s 51 | 52 | supportedMACs :: [(String, LBS.ByteString -> HMAC)] 53 | supportedMACs = 54 | [ ("hmac-sha1", makeHMAC True) 55 | , ("hmac-md5", makeHMAC False) 56 | ] 57 | where 58 | makeHMAC True k = HMAC 20 $ \b -> bsToLBS . S.runPut $ S.put (hmac (MacKey (strictLBS (LBS.take 20 k))) b :: SHA1) 59 | makeHMAC False k = HMAC 16 $ \b -> bsToLBS . S.runPut $ S.put (hmac (MacKey (strictLBS (LBS.take 16 k))) b :: MD5) 60 | 61 | bsToLBS = LBS.fromChunks . (: []) 62 | 63 | supportedCompression :: String 64 | supportedCompression = "none" 65 | 66 | supportedLanguages :: String 67 | supportedLanguages = "" 68 | 69 | start :: SessionConfig -> ChannelConfig -> PortNumber -> IO () 70 | start sc cc p = withSocketsDo $ do 71 | sock <- listenOn (PortNumber p) 72 | putStrLn $ "ssh server listening on port " ++ show p 73 | waitLoop sc cc sock 74 | 75 | waitLoop :: SessionConfig -> ChannelConfig -> Socket -> IO () 76 | waitLoop sc cc s = do 77 | (handle, hostName, port) <- accept s 78 | 79 | io $ hSetBinaryMode handle True 80 | 81 | dump ("got connection from", hostName, port) 82 | 83 | forkIO $ do 84 | -- send SSH server version 85 | hPutStr handle (version ++ "\r\n") 86 | hFlush handle 87 | 88 | done <- hIsEOF handle 89 | if done 90 | then return () 91 | else do 92 | 93 | -- get the version response 94 | theirVersion <- hGetLine handle >>= return . takeWhile (/= '\r') 95 | 96 | cookie <- fmap (LBS.pack . map fromIntegral) $ 97 | replicateM 16 (randomRIO (0, 255 :: Int)) 98 | 99 | let ourKEXInit = doPacket $ pKEXInit cookie 100 | 101 | out <- newChan 102 | forkIO (sender out (NoKeys handle 0)) 103 | 104 | evalStateT 105 | (send (Send ourKEXInit) >> readLoop) 106 | (Initial 107 | { ssConfig = sc 108 | , ssChannelConfig = cc 109 | , ssThem = handle 110 | , ssSend = writeChan out 111 | , ssPayload = LBS.empty 112 | , ssTheirVersion = theirVersion 113 | , ssOurKEXInit = ourKEXInit 114 | , ssInSeq = 0 115 | }) 116 | 117 | waitLoop sc cc s 118 | where 119 | pKEXInit :: LBS.ByteString -> Packet () 120 | pKEXInit cookie = do 121 | byte 20 122 | 123 | raw cookie 124 | 125 | mapM_ string 126 | [ intercalate "," $ supportedKeyExchanges 127 | , intercalate "," $ supportedKeyAlgorithms 128 | , intercalate "," $ map fst supportedCiphers 129 | , intercalate "," $ map fst supportedCiphers 130 | , intercalate "," $ map fst supportedMACs 131 | , intercalate "," $ map fst supportedMACs 132 | , supportedCompression 133 | , supportedCompression 134 | , supportedLanguages 135 | , supportedLanguages 136 | ] 137 | 138 | byte 0 -- first_kex_packet_follows (boolean) 139 | long 0 140 | 141 | readLoop :: Session () 142 | readLoop = do 143 | done <- gets ssThem >>= io . hIsEOF 144 | if done 145 | then shutdownChannels 146 | else do 147 | 148 | getPacket 149 | 150 | msg <- net readByte 151 | 152 | if msg == 1 || msg == 97 -- disconnect || close 153 | then shutdownChannels 154 | else do 155 | 156 | case msg of 157 | 5 -> serviceRequest 158 | 20 -> kexInit 159 | 21 -> newKeys 160 | 30 -> kexDHInit 161 | 50 -> userAuthRequest 162 | 90 -> channelOpen 163 | 94 -> dataReceived 164 | 96 -> eofReceived 165 | 98 -> channelRequest 166 | u -> dump $ "unknown message: " ++ show u 167 | 168 | modify (\s -> s { ssInSeq = ssInSeq s + 1 }) 169 | readLoop 170 | where 171 | shutdownChannels = do 172 | s <- get 173 | case s of 174 | Final { ssChannels = cs } -> 175 | mapM_ (io . flip writeChan Interrupt) (M.elems cs) 176 | _ -> return () 177 | 178 | io $ ssSend s Stop 179 | 180 | kexInit :: Session () 181 | kexInit = do 182 | cookie <- net (readBytes 16) 183 | nameLists <- fmap (map (splitOn "," . fromLBS)) (replicateM 10 (net readLBS)) 184 | kpf <- net readByte 185 | dummy <- net readULong 186 | 187 | let theirKEXInit = reconstruct cookie nameLists kpf dummy 188 | ocn = match (nameLists !! 3) (map fst supportedCiphers) 189 | icn = match (nameLists !! 2) (map fst supportedCiphers) 190 | omn = match (nameLists !! 5) (map fst supportedMACs) 191 | imn = match (nameLists !! 4) (map fst supportedMACs) 192 | 193 | dump ("KEXINIT", theirKEXInit, ocn, icn, omn, imn) 194 | modify $ \st -> 195 | case st of 196 | Initial c cc h s p cv sk is -> 197 | case 198 | ( lookup ocn supportedCiphers 199 | , lookup icn supportedCiphers 200 | , lookup omn supportedMACs 201 | , lookup imn supportedMACs 202 | ) of 203 | (Just oc, Just ic, Just om, Just im) -> 204 | GotKEXInit 205 | { ssConfig = c 206 | , ssChannelConfig = cc 207 | , ssThem = h 208 | , ssSend = s 209 | , ssPayload = p 210 | , ssTheirVersion = cv 211 | , ssOurKEXInit = sk 212 | , ssTheirKEXInit = theirKEXInit 213 | , ssOutCipher = oc 214 | , ssInCipher = ic 215 | , ssOutHMACPrep = om 216 | , ssInHMACPrep = im 217 | , ssInSeq = is 218 | } 219 | _ -> 220 | error . concat $ 221 | [ "impossible: lookup failed for ciphers/macs: " 222 | , show (ocn, icn, omn, imn) 223 | ] 224 | _ -> error "impossible state transition; expected Initial" 225 | where 226 | match n h = head . filter (`elem` h) $ n 227 | reconstruct c nls kpf dummy = doPacket $ do 228 | byte 20 229 | raw c 230 | mapM_ (string . intercalate ",") nls 231 | byte kpf 232 | long dummy 233 | 234 | kexDHInit :: Session () 235 | kexDHInit = do 236 | e <- net readInteger 237 | dump ("KEXDH_INIT", e) 238 | 239 | y <- io $ randIntegerOneToNMinusOne ((safePrime - 1) `div` 2) -- q? 240 | 241 | let f = modexp generator y safePrime 242 | k = modexp e y safePrime 243 | 244 | keyPair <- gets (scKeyPair . ssConfig) 245 | 246 | let pub = 247 | case keyPair of 248 | RSAKeyPair { rprivPub = p } -> p 249 | DSAKeyPair { dprivPub = p } -> p 250 | d <- digest e f k pub 251 | 252 | let [civ, siv, ckey, skey, cinteg, sinteg] = map (makeKey k d) ['A'..'F'] 253 | dump ("DECRYPT KEY/IV", LBS.take 16 ckey, LBS.take 16 civ) 254 | 255 | oc <- gets ssOutCipher 256 | om <- gets ssOutHMACPrep 257 | send $ 258 | Prepare 259 | oc 260 | (strictLBS $ LBS.take (fromIntegral $ cKeySize oc) $ skey) 261 | (strictLBS $ LBS.take (fromIntegral $ cBlockSize oc) $ siv) 262 | (om sinteg) 263 | 264 | modify $ \st -> 265 | case st of 266 | GotKEXInit c cc h s p _ _ is _ _ ic _ im -> 267 | Final 268 | { ssConfig = c 269 | , ssChannelConfig = cc 270 | , ssChannels = M.empty 271 | , ssID = d 272 | , ssThem = h 273 | , ssSend = s 274 | , ssPayload = p 275 | , ssGotNEWKEYS = False 276 | , ssInSeq = is 277 | , ssInCipher = ic 278 | , ssInHMAC = im cinteg 279 | , ssInKey = 280 | strictLBS $ LBS.take (fromIntegral $ cKeySize ic) $ ckey 281 | , ssInVector = 282 | strictLBS $ LBS.take (fromIntegral $ cBlockSize ic) $ civ 283 | , ssUser = Nothing 284 | } 285 | 286 | _ -> error "impossible state transition; expected GotKEXInit" 287 | 288 | 289 | 290 | signed <- io $ sign keyPair d 291 | let reply = doPacket (kexDHReply f signed pub) 292 | dump ("KEXDH_REPLY", reply) 293 | 294 | send (Send reply) 295 | where 296 | kexDHReply f s p = do 297 | byte 31 298 | byteString (blob p) 299 | integer f 300 | byteString s 301 | 302 | digest e f k p = do 303 | cv <- gets ssTheirVersion 304 | ck <- gets ssTheirKEXInit 305 | sk <- gets ssOurKEXInit 306 | return . bytestringDigest . sha1 . doPacket $ do 307 | string cv 308 | string version 309 | byteString ck 310 | byteString sk 311 | byteString (blob p) 312 | integer e 313 | integer f 314 | integer k 315 | 316 | newKeys :: Session () 317 | newKeys = do 318 | sendPacket (byte 21) 319 | send StartEncrypting 320 | modify (\ss -> ss { ssGotNEWKEYS = True }) 321 | 322 | serviceRequest :: Session () 323 | serviceRequest = do 324 | name <- net readLBS 325 | sendPacket $ do 326 | byte 6 327 | byteString name 328 | 329 | userAuthRequest :: Session () 330 | userAuthRequest = do 331 | user <- net readLBS 332 | service <- net readLBS 333 | method <- net readLBS 334 | 335 | auth <- gets (scAuthorize . ssConfig) 336 | authMethods <- gets (scAuthMethods . ssConfig) 337 | 338 | dump ("userauth attempt", user, service, method) 339 | check <- case fromLBS method of 340 | x | not (x `elem` authMethods) -> 341 | return False 342 | 343 | "publickey" -> do 344 | b <- net readByte 345 | name <- net readLBS 346 | key <- net readLBS 347 | ch <- auth (PublicKey (fromLBS user) (blobToKey key)) 348 | 349 | -- if it's signed, assume it's the second one after auth 350 | if ch && b == 1 351 | then sendPacket userAuthOK 352 | else when ch (sendPacket $ userAuthPKOK name key) 353 | 354 | return ch 355 | 356 | "password" -> do 357 | 0 <- net readByte 358 | password <- net readLBS 359 | ch <- auth (Password (fromLBS user) (fromLBS password)) 360 | when ch (sendPacket userAuthOK) 361 | return ch 362 | 363 | u -> error $ "unhandled authorization type: " ++ u 364 | 365 | if check 366 | then modify (\s -> s { ssUser = Just (fromLBS user) }) 367 | else sendPacket (userAuthFail authMethods) 368 | where 369 | userAuthFail ms = do 370 | byte 51 371 | string (intercalate "," ms) 372 | byte 0 373 | 374 | userAuthPKOK name key = do 375 | byte 60 376 | byteString name 377 | byteString key 378 | 379 | userAuthOK = byte 52 380 | 381 | channelOpen :: Session () 382 | channelOpen = do 383 | name <- net readLBS 384 | them <- net readULong 385 | windowSize <- net readULong 386 | maxPacketLength <- net readULong 387 | 388 | dump ("channel open", name, them, windowSize, maxPacketLength) 389 | 390 | us <- newChannelID 391 | 392 | chan <- do 393 | c <- gets ssChannelConfig 394 | s <- gets ssSend 395 | Just u <- gets ssUser 396 | io $ newChannel c s us them windowSize maxPacketLength u 397 | 398 | modify (\s -> s 399 | { ssChannels = M.insert us chan (ssChannels s) }) 400 | 401 | channelRequest :: Session () 402 | channelRequest = do 403 | chan <- net readULong >>= getChannel 404 | typ <- net readLBS 405 | wantReply <- net readBool 406 | 407 | let sendRequest = io . writeChan chan . Request wantReply 408 | 409 | case fromLBS typ of 410 | "pty-req" -> do 411 | term <- net readString 412 | cols <- net readULong 413 | rows <- net readULong 414 | width <- net readULong 415 | height <- net readULong 416 | modes <- net readString 417 | sendRequest (PseudoTerminal term cols rows width height modes) 418 | 419 | "x11-req" -> sendRequest X11Forwarding 420 | 421 | "shell" -> sendRequest Shell 422 | 423 | "exec" -> do 424 | command <- net readString 425 | dump ("execute command", command) 426 | sendRequest (Execute command) 427 | 428 | "subsystem" -> do 429 | name <- net readString 430 | dump ("subsystem request", name) 431 | sendRequest (Subsystem name) 432 | 433 | "env" -> do 434 | name <- net readString 435 | value <- net readString 436 | dump ("environment request", name, value) 437 | sendRequest (Environment name value) 438 | 439 | "window-change" -> do 440 | cols <- net readULong 441 | rows <- net readULong 442 | width <- net readULong 443 | height <- net readULong 444 | sendRequest (WindowChange cols rows width height) 445 | 446 | "xon-xoff" -> do 447 | b <- net readBool 448 | sendRequest (FlowControl b) 449 | 450 | "signal" -> do 451 | name <- net readString 452 | sendRequest (Signal name) 453 | 454 | "exit-status" -> do 455 | status <- net readULong 456 | sendRequest (ExitStatus status) 457 | 458 | "exit-signal" -> do 459 | name <- net readString 460 | dumped <- net readBool 461 | msg <- net readString 462 | lang <- net readString 463 | sendRequest (ExitSignal name dumped msg lang) 464 | 465 | u -> sendRequest (Unknown u) 466 | 467 | dump ("request processed") 468 | 469 | dataReceived :: Session () 470 | dataReceived = do 471 | dump "got data" 472 | chan <- net readULong >>= getChannel 473 | msg <- net readLBS 474 | io $ writeChan chan (Data msg) 475 | dump "data processed" 476 | 477 | 478 | eofReceived :: Session () 479 | eofReceived = do 480 | chan <- net readULong >>= getChannel 481 | io $ writeChan chan EOF 482 | --------------------------------------------------------------------------------