ssh 0.2.5 → 0.2.8
raw patch · 6 files changed
+150/−68 lines, 6 filesdep ~asn1-data
Dependency ranges changed: asn1-data
Files
- src/SSH.hs +89/−53
- src/SSH/Channel.hs +44/−6
- src/SSH/Crypto.hs +7/−4
- src/SSH/Packet.hs +3/−0
- src/SSH/Sender.hs +2/−0
- ssh.cabal +5/−5
src/SSH.hs view
@@ -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
src/SSH/Channel.hs view
@@ -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
src/SSH/Crypto.hs view
@@ -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
src/SSH/Packet.hs view
@@ -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
src/SSH/Sender.hs view
@@ -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)
ssh.cabal view
@@ -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: - <http://darcsden.com/alex/darcsden/browse/Main.hs>.+ <http://darcsden.com/alex/darcsden/browse/src/SSHServer.hs>. 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,