diff --git a/src/SSH.hs b/src/SSH.hs --- a/src/SSH.hs +++ b/src/SSH.hs @@ -2,7 +2,7 @@ import Control.Concurrent (forkIO) import Control.Concurrent.Chan -import Control.Monad (replicateM) +import Control.Monad (replicateM, when) import Control.Monad.Trans.State import Data.Digest.Pure.SHA (bytestringDigest, sha1) import Crypto.HMAC @@ -142,7 +142,7 @@ readLoop = do done <- gets ssThem >>= io . hIsEOF if done - then dump "connection lost" + then shutdownChannels else do getPacket @@ -150,7 +150,7 @@ msg <- net readByte if msg == 1 || msg == 97 -- disconnect || close - then dump "disconnected" + then shutdownChannels else do case msg of @@ -167,11 +167,20 @@ modify (\s -> s { ssInSeq = ssInSeq s + 1 }) readLoop + where + shutdownChannels = do + s <- get + case s of + Final { ssChannels = cs } -> + mapM_ (io . flip writeChan Interrupt) (M.elems cs) + _ -> return () + io $ ssSend s Stop + kexInit :: Session () kexInit = do - cookie <- net $ readBytes 16 - nameLists <- replicateM 10 (net readLBS) >>= return . map (splitOn "," . fromLBS) + cookie <- net (readBytes 16) + nameLists <- fmap (map (splitOn "," . fromLBS)) (replicateM 10 (net readLBS)) kpf <- net readByte dummy <- net readULong @@ -182,30 +191,37 @@ imn = match (nameLists !! 4) (map fst supportedMACs) dump ("KEXINIT", theirKEXInit, ocn, icn, omn, imn) - modify (\(Initial c cc h s p cv sk is) -> - case - ( lookup ocn supportedCiphers - , lookup icn supportedCiphers - , lookup omn supportedMACs - , lookup imn supportedMACs - ) of - (Just oc, Just ic, Just om, Just im) -> - GotKEXInit - { ssConfig = c - , ssChannelConfig = cc - , ssThem = h - , ssSend = s - , ssPayload = p - , ssTheirVersion = cv - , ssOurKEXInit = sk - , ssTheirKEXInit = theirKEXInit - , ssOutCipher = oc - , ssInCipher = ic - , ssOutHMACPrep = om - , ssInHMACPrep = im - , ssInSeq = is - } - _ -> error $ "impossible: lookup failed for ciphers/macs: " ++ show (ocn, icn, omn, imn)) + modify $ \st -> + case st of + Initial c cc h s p cv sk is -> + case + ( lookup ocn supportedCiphers + , lookup icn supportedCiphers + , lookup omn supportedMACs + , lookup imn supportedMACs + ) of + (Just oc, Just ic, Just om, Just im) -> + GotKEXInit + { ssConfig = c + , ssChannelConfig = cc + , ssThem = h + , ssSend = s + , ssPayload = p + , ssTheirVersion = cv + , ssOurKEXInit = sk + , ssTheirKEXInit = theirKEXInit + , ssOutCipher = oc + , ssInCipher = ic + , ssOutHMACPrep = om + , ssInHMACPrep = im + , ssInSeq = is + } + _ -> + error . concat $ + [ "impossible: lookup failed for ciphers/macs: " + , show (ocn, icn, omn, imn) + ] + _ -> error "impossible state transition; expected Initial" where match n h = head . filter (`elem` h) $ n reconstruct c nls kpf dummy = doPacket $ do @@ -245,24 +261,32 @@ (strictLBS $ LBS.take (fromIntegral $ cBlockSize oc) $ siv) (om sinteg) - modify (\(GotKEXInit c cc h s p _ _ is _ _ ic _ im) -> - Final - { ssConfig = c - , ssChannelConfig = cc - , ssChannels = M.empty - , ssID = d - , ssThem = h - , ssSend = s - , ssPayload = p - , ssGotNEWKEYS = False - , ssInSeq = is - , ssInCipher = ic - , ssInHMAC = im cinteg - , ssInKey = strictLBS $ LBS.take (fromIntegral $ cKeySize ic) $ ckey - , ssInVector = strictLBS $ LBS.take (fromIntegral $ cBlockSize ic) $ civ - , ssUser = Nothing - }) + modify $ \st -> + case st of + GotKEXInit c cc h s p _ _ is _ _ ic _ im -> + Final + { ssConfig = c + , ssChannelConfig = cc + , ssChannels = M.empty + , ssID = d + , ssThem = h + , ssSend = s + , ssPayload = p + , ssGotNEWKEYS = False + , ssInSeq = is + , ssInCipher = ic + , ssInHMAC = im cinteg + , ssInKey = + strictLBS $ LBS.take (fromIntegral $ cKeySize ic) $ ckey + , ssInVector = + strictLBS $ LBS.take (fromIntegral $ cBlockSize ic) $ civ + , ssUser = Nothing + } + _ -> error "impossible state transition; expected GotKEXInit" + + + signed <- io $ sign keyPair d let reply = doPacket (kexDHReply f signed pub) dump ("KEXDH_REPLY", reply) @@ -317,28 +341,40 @@ return False "publickey" -> do - 0 <- net readByte - net readLBS + b <- net readByte + name <- net readLBS key <- net readLBS - auth (PublicKey (fromLBS user) (blobToKey key)) + ch <- auth (PublicKey (fromLBS user) (blobToKey key)) + -- if it's signed, assume it's the second one after auth + if ch && b == 1 + then sendPacket userAuthOK + else when ch (sendPacket $ userAuthPKOK name key) + + return ch + "password" -> do 0 <- net readByte password <- net readLBS - auth (Password (fromLBS user) (fromLBS password)) + ch <- auth (Password (fromLBS user) (fromLBS password)) + when ch (sendPacket userAuthOK) + return ch u -> error $ "unhandled authorization type: " ++ u if check - then do - modify (\s -> s { ssUser = Just (fromLBS user) }) - sendPacket userAuthOK + then modify (\s -> s { ssUser = Just (fromLBS user) }) else sendPacket (userAuthFail authMethods) where userAuthFail ms = do byte 51 string (intercalate "," ms) byte 0 + + userAuthPKOK name key = do + byte 60 + byteString name + byteString key userAuthOK = byte 52 diff --git a/src/SSH/Channel.hs b/src/SSH/Channel.hs --- a/src/SSH/Channel.hs +++ b/src/SSH/Channel.hs @@ -1,8 +1,7 @@ {-# LANGUAGE TypeSynonymInstances #-} module SSH.Channel where -import Control.Concurrent (forkIO) -import Control.Concurrent.Chan +import Control.Concurrent import Control.Monad (when) import Control.Monad.Trans.State import Data.Word @@ -29,12 +28,14 @@ , csTheirWindowSize :: Word32 , csUser :: String , csProcess :: Maybe Process + , csRedirector :: Maybe ThreadId } data ChannelMessage = Request Bool ChannelRequest | Data LBS.ByteString | EOF + | Interrupt deriving Show data ChannelConfig = @@ -107,6 +108,7 @@ , csTheirWindowSize = winSize , csUser = user , csProcess = Nothing + , csRedirector = Nothing } return chan @@ -118,7 +120,12 @@ chanid <- gets csID case msg of - Request wr cr -> gets (ccRequestHandler . csConfig) >>= \f -> f wr cr + Request wr cr -> do + handler <- gets (ccRequestHandler . csConfig) + handler wr cr + + chanLoop c + Data datum -> do modify $ \cs -> cs { csDataReceived = @@ -144,6 +151,9 @@ dump ("redirecting data", chanid, LBS.length datum) io $ LBS.hPut pin datum io $ hFlush pin + + chanLoop c + EOF -> do modify $ \cs -> cs { csDataReceived = 0 } @@ -155,9 +165,24 @@ dump ("redirecting eof", chanid) io $ hClose pin + chanLoop c - chanLoop c + Interrupt -> do + -- shut down the i/o redirecting process + redir <- gets csRedirector + case redir of + Nothing -> return () + Just tid -> io (killThread tid) + cproc <- gets csProcess + case cproc of + Nothing -> return () + Just (Process phdl _ _ _) -> do + -- NOTE: this doesn't necessarily guarantee termination + -- see System.Process docs + io $ terminateProcess phdl + + channelError :: String -> Channel () channelError msg = do target <- gets csTheirID @@ -195,16 +220,29 @@ sendPacket (byte 96 >> long target) -- eof sendPacket (byte 97 >> long target) -- close +sendChunks :: Integral a => a -> Packet () -> String -> Channel () +sendChunks _ _ "" = return () +sendChunks n p s = do + sendPacket (p >> string chunk) + sendChunks n p rest + where + (chunk, rest) = splitAt (fromIntegral n - packetLength p) s + redirectHandle :: Chan () -> Packet () -> Handle -> Channel () -redirectHandle f d h = get >>= io . forkIO . evalStateT redirectLoop >> return () +redirectHandle f d h = do + s <- get + r <- io . forkIO . evalStateT redirectLoop $ s + modify $ \cs -> cs { csRedirector = Just r } where redirectLoop = do + maxLen <- gets csMaxPacket + dump "reading..." l <- io $ getAvailable dump ("read data from handle", l) if not (null l) - then sendPacket $ d >> string l + then sendChunks maxLen d l else return () done <- io $ hIsEOF h diff --git a/src/SSH/Crypto.hs b/src/SSH/Crypto.hs --- a/src/SSH/Crypto.hs +++ b/src/SSH/Crypto.hs @@ -2,7 +2,8 @@ import Control.Monad (replicateM) import Control.Monad.Trans.State -import Data.ASN1.BER +import Data.ASN1.BER (decodeASN1Stream) +import Data.ASN1.Stream import Data.Digest.Pure.SHA (bytestringDigest, sha1) import Data.List (isPrefixOf) import qualified Codec.Binary.Base64.String as B64 @@ -66,9 +67,11 @@ . lines $ x - case decodeASN1 (toLBS asn1) of - Right (Sequence is) | all isIntVal is -> - return $ RSAKeyPair + case decodeASN1Stream (toLBS asn1) of + Right (Start Sequence:ss) + | all isIntVal (fst $ getConstructedEnd 0 ss) -> + let (is, _) = getConstructedEnd 0 ss + in return $ RSAKeyPair { rprivPub = RSAPublicKey { rpubE = intValAt 2 is , rpubN = intValAt 1 is diff --git a/src/SSH/Packet.hs b/src/SSH/Packet.hs --- a/src/SSH/Packet.hs +++ b/src/SSH/Packet.hs @@ -34,6 +34,9 @@ rawString :: String -> Packet () rawString = tell . toLBS +packetLength :: Packet () -> Int +packetLength = fromIntegral . LBS.length . doPacket + doPacket :: Packet a -> LBS.ByteString doPacket = execWriter diff --git a/src/SSH/Sender.hs b/src/SSH/Sender.hs --- a/src/SSH/Sender.hs +++ b/src/SSH/Sender.hs @@ -34,6 +34,7 @@ = Prepare Cipher BS.ByteString BS.ByteString HMAC | StartEncrypting | Send LBS.ByteString + | Stop class Sender a where send :: SenderMessage -> a () @@ -45,6 +46,7 @@ sender ms ss = do m <- readChan ms case m of + Stop -> return () Prepare cipher key iv hmac -> do dump ("initiating encryption", key, iv) sender ms (GotKeys (senderThem ss) (senderOutSeq ss) False cipher key iv hmac) diff --git a/ssh.cabal b/ssh.cabal --- a/ssh.cabal +++ b/ssh.cabal @@ -1,11 +1,11 @@ name: ssh -version: 0.2.5 +version: 0.2.8 synopsis: A pure-Haskell SSH server library. description: - This package was split from darcsden into its own project; documentation is - lacking, but you can find example usage here: + This package was split from darcsden into its own project; documentation + is lacking, but you can find example usage here: - . + . This is not a standalone SSH server - it is intended to be used as a library for implementing your own servers that handle requests and @@ -43,7 +43,7 @@ other-modules: SSH.Debug, SSH.Util - build-depends: asn1-data, + build-depends: asn1-data >= 0.5 && < 0.6, base >= 4 && < 5, base64-string, binary,