ssh (empty) → 0.1
raw patch · 12 files changed
+1356/−0 lines, 12 filesdep +Cryptodep +HsOpenSSLdep +RSAsetup-changed
Dependencies added: Crypto, HsOpenSSL, RSA, SHA, base, binary, bytestring, containers, network, process, random, split, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/SSH.hs +436/−0
- src/SSH/Channel.hs +269/−0
- src/SSH/Crypto.hs +115/−0
- src/SSH/Debug.hs +18/−0
- src/SSH/NetReader.hs +45/−0
- src/SSH/Packet.hs +77/−0
- src/SSH/Sender.hs +116/−0
- src/SSH/Session.hs +181/−0
- src/SSH/Util.hs +14/−0
- ssh.cabal +53/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Alex Suraci++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Alex Suraci nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/SSH.hs view
@@ -0,0 +1,436 @@+module SSH where++import Control.Concurrent (forkIO)+import Control.Concurrent.Chan+import Control.Monad (replicateM)+import Control.Monad.Trans.State+import Data.Digest.Pure.SHA (bytestringDigest, sha1)+import Data.HMAC (hmac_md5, hmac_sha1)+import Data.List (intercalate)+import Data.List.Split (splitOn)+import OpenSSL.BN+import Network+import System.IO+import System.Random+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map as M++import SSH.Channel+import SSH.Crypto+import SSH.Debug+import SSH.NetReader+import SSH.Packet+import SSH.Sender+import SSH.Session+import SSH.Util+++version :: String+version = "SSH-2.0-DarcsDen"++supportedKeyExchanges :: [String]+supportedKeyExchanges =+ {-"diffie-hellman-group-exchange-sha1," ++-}+ ["diffie-hellman-group1-sha1"]++supportedKeyAlgorithms :: [String]+supportedKeyAlgorithms = ["ssh-rsa", "ssh-dss"]++supportedCiphers :: [(String, Cipher)]+supportedCiphers =+ [ ("aes256-cbc", aesCipher CBC 32)+ , ("aes192-cbc", aesCipher CBC 24)+ , ("aes128-cbc", aesCipher CBC 16)+ ]+ where+ aesCipher m s =+ Cipher AES m 16 s++supportedMACs :: [(String, LBS.ByteString -> HMAC)]+supportedMACs =+ [ ("hmac-sha1", makeHMAC 20 hmac_sha1)+ , ("hmac-md5", makeHMAC 16 hmac_md5)+ ]+ where+ makeHMAC s f k = HMAC s $ LBS.pack . f (LBS.unpack . LBS.take (fromIntegral s) $ k) . LBS.unpack++supportedCompression :: String+supportedCompression = "none"++supportedLanguages :: String+supportedLanguages = ""++start :: SessionConfig -> ChannelConfig -> PortNumber -> IO ()+start sc cc p = withSocketsDo $ do+ sock <- listenOn (PortNumber p)+ putStrLn $ "ssh server listening on port " ++ show p+ waitLoop sc cc sock++waitLoop :: SessionConfig -> ChannelConfig -> Socket -> IO ()+waitLoop sc cc s = do+ (handle, hostName, port) <- accept s+ dump ("got connection from", hostName, port)+ + forkIO $ do+ -- send SSH server version+ hPutStr handle (version ++ "\r\n")+ hFlush handle++ done <- hIsEOF handle+ if done+ then return ()+ else do++ -- get the version response+ theirVersion <- hGetLine handle >>= return . takeWhile (/= '\r')++ cookie <- fmap (LBS.pack . map fromIntegral) $+ replicateM 16 (randomRIO (0, 255 :: Int))++ let ourKEXInit = doPacket $ pKEXInit cookie++ out <- newChan+ forkIO (sender out (NoKeys handle 0))++ evalStateT+ (send (Send ourKEXInit) >> readLoop)+ (Initial+ { ssConfig = sc+ , ssChannelConfig = cc+ , ssThem = handle+ , ssSend = writeChan out+ , ssPayload = LBS.empty+ , ssTheirVersion = theirVersion+ , ssOurKEXInit = ourKEXInit+ , ssInSeq = 0+ })++ waitLoop sc cc s+ where+ pKEXInit :: LBS.ByteString -> Packet ()+ pKEXInit cookie = do+ byte 20++ raw cookie++ mapM_ string+ [ intercalate "," $ supportedKeyExchanges+ , intercalate "," $ supportedKeyAlgorithms+ , intercalate "," $ map fst supportedCiphers+ , intercalate "," $ map fst supportedCiphers+ , intercalate "," $ map fst supportedMACs+ , intercalate "," $ map fst supportedMACs+ , supportedCompression+ , supportedCompression+ , supportedLanguages+ , supportedLanguages+ ]++ byte 0 -- first_kex_packet_follows (boolean)+ long 0++readLoop :: Session ()+readLoop = do+ done <- gets ssThem >>= io . hIsEOF+ if done+ then dump "connection lost"+ else do++ getPacket++ msg <- net readByte++ if msg == 1 || msg == 97 -- disconnect || close+ then dump "disconnected"+ else do++ case msg of+ 5 -> serviceRequest+ 20 -> kexInit+ 21 -> newKeys+ 30 -> kexDHInit+ 50 -> userAuthRequest+ 90 -> channelOpen+ 94 -> dataReceived+ 96 -> eofReceived+ 98 -> channelRequest+ u -> dump $ "unknown message: " ++ show u++ modify (\s -> s { ssInSeq = ssInSeq s + 1 })+ readLoop++kexInit :: Session ()+kexInit = do+ cookie <- net $ readBytes 16+ nameLists <- replicateM 10 (net readLBS) >>= return . map (splitOn "," . fromLBS)+ kpf <- net readByte+ dummy <- net readULong++ let theirKEXInit = reconstruct cookie nameLists kpf dummy+ ocn = match (nameLists !! 3) (map fst supportedCiphers)+ icn = match (nameLists !! 2) (map fst supportedCiphers)+ omn = match (nameLists !! 5) (map fst supportedMACs)+ 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))+ where+ match n h = head . filter (`elem` h) $ n+ reconstruct c nls kpf dummy = doPacket $ do+ byte 20+ raw c+ mapM_ (string . intercalate ",") nls+ byte kpf+ long dummy++kexDHInit :: Session ()+kexDHInit = do+ e <- net readInteger+ dump ("KEXDH_INIT", e)++ y <- io $ randIntegerOneToNMinusOne ((safePrime - 1) `div` 2) -- q?++ let f = modexp generator y safePrime+ k = modexp e y safePrime++ keyPair <- gets (scKeyPair . ssConfig)++ let pub =+ case keyPair of+ RSAKeyPair { rprivPub = p } -> p+ DSAKeyPair { dprivPub = p } -> p+ d <- digest e f k pub++ let [civ, siv, ckey, skey, cinteg, sinteg] = map (makeKey k d) ['A'..'F']+ dump ("DECRYPT KEY/IV", LBS.take 16 ckey, LBS.take 16 civ)++ oc <- gets ssOutCipher+ om <- gets ssOutHMACPrep+ send $+ Prepare+ oc+ (head . toBlocks (cKeySize oc) $ skey)+ (head . toBlocks (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 = head . toBlocks (cKeySize ic) $ ckey+ , ssInVector = head . toBlocks (cBlockSize ic) $ civ+ , ssUser = Nothing+ })++ signed <- io $ sign keyPair d+ let reply = doPacket (kexDHReply f signed pub)+ dump ("KEXDH_REPLY", reply)++ send (Send reply)+ where+ kexDHReply f s p = do+ byte 31+ byteString (blob p)+ integer f+ byteString s++ digest e f k p = do+ cv <- gets ssTheirVersion+ ck <- gets ssTheirKEXInit+ sk <- gets ssOurKEXInit+ return . bytestringDigest . sha1 . doPacket $ do+ string cv+ string version+ byteString ck+ byteString sk+ byteString (blob p)+ integer e+ integer f+ integer k++newKeys :: Session ()+newKeys = do+ sendPacket (byte 21)+ send StartEncrypting+ modify (\ss -> ss { ssGotNEWKEYS = True })++serviceRequest :: Session ()+serviceRequest = do+ name <- net readLBS+ sendPacket $ do+ byte 6+ byteString name++userAuthRequest :: Session ()+userAuthRequest = do+ user <- net readLBS+ service <- net readLBS+ method <- net readLBS++ auth <- gets (scAuthorize . ssConfig)+ authMethods <- gets (scAuthMethods . ssConfig)++ dump ("userauth attempt", user, service, method)+ check <- case fromLBS method of+ x | not (x `elem` authMethods) ->+ return False++ "publickey" -> do+ 0 <- net readByte+ net readLBS+ key <- net readLBS+ auth (PublicKey (fromLBS user) (blobToKey key))++ "password" -> do+ 0 <- net readByte+ password <- net readLBS+ auth (Password (fromLBS user) (fromLBS password))++ u -> error $ "unhandled authorization type: " ++ u++ if check+ then do+ modify (\s -> s { ssUser = Just (fromLBS user) })+ sendPacket userAuthOK+ else sendPacket (userAuthFail authMethods)+ where+ userAuthFail ms = do+ byte 51+ string (intercalate "," ms)+ byte 0++ userAuthOK = byte 52++channelOpen :: Session ()+channelOpen = do+ name <- net readLBS+ them <- net readULong+ windowSize <- net readULong+ maxPacketLength <- net readULong++ dump ("channel open", name, them, windowSize, maxPacketLength)++ us <- newChannelID++ chan <- do+ c <- gets ssChannelConfig+ s <- gets ssSend+ Just u <- gets ssUser+ io $ newChannel c s us them windowSize maxPacketLength u++ modify (\s -> s+ { ssChannels = M.insert us chan (ssChannels s) })++channelRequest :: Session ()+channelRequest = do+ chan <- net readULong >>= getChannel+ typ <- net readLBS+ wantReply <- net readBool++ let sendRequest = io . writeChan chan . Request wantReply++ case fromLBS typ of+ "pty-req" -> do+ term <- net readString+ cols <- net readULong+ rows <- net readULong+ width <- net readULong+ height <- net readULong+ modes <- net readString+ sendRequest (PseudoTerminal term cols rows width height modes)++ "x11-req" -> sendRequest X11Forwarding++ "shell" -> sendRequest Shell++ "exec" -> do+ command <- net readString+ dump ("execute command", command)+ sendRequest (Execute command)++ "subsystem" -> do+ name <- net readString+ dump ("subsystem request", name)+ sendRequest (Subsystem name)++ "env" -> do+ name <- net readString+ value <- net readString+ dump ("environment request", name, value)+ sendRequest (Environment name value)++ "window-change" -> do+ cols <- net readULong+ rows <- net readULong+ width <- net readULong+ height <- net readULong+ sendRequest (WindowChange cols rows width height)++ "xon-xoff" -> do+ b <- net readBool+ sendRequest (FlowControl b)++ "signal" -> do+ name <- net readString+ sendRequest (Signal name)++ "exit-status" -> do+ status <- net readULong+ sendRequest (ExitStatus status)++ "exit-signal" -> do+ name <- net readString+ dumped <- net readBool+ msg <- net readString+ lang <- net readString+ sendRequest (ExitSignal name dumped msg lang)++ u -> sendRequest (Unknown u)++ dump ("request processed")++dataReceived :: Session ()+dataReceived = do+ dump "got data"+ chan <- net readULong >>= getChannel+ msg <- net readLBS+ io $ writeChan chan (Data msg)+ dump "data processed"+++eofReceived :: Session ()+eofReceived = do+ chan <- net readULong >>= getChannel+ io $ writeChan chan EOF
+ src/SSH/Channel.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE TypeSynonymInstances #-}+module SSH.Channel where++import Control.Concurrent (forkIO)+import Control.Concurrent.Chan+import Control.Monad (when)+import Control.Monad.Trans.State+import Data.Word+import System.Exit+import System.IO+import System.Process+import qualified Data.ByteString.Lazy as LBS++import SSH.Debug+import SSH.Packet+import SSH.Sender++type Channel = StateT ChannelState IO++data ChannelState =+ ChannelState+ { csConfig :: ChannelConfig+ , csID :: Word32+ , csTheirID :: Word32+ , csSend :: SenderMessage -> IO ()+ , csDataReceived :: Word32+ , csMaxPacket :: Word32+ , csWindowSize :: Word32+ , csTheirWindowSize :: Word32+ , csUser :: String+ , csProcess :: Maybe Process+ }++data ChannelMessage+ = Request Bool ChannelRequest+ | Data LBS.ByteString+ | EOF+ deriving Show++data ChannelConfig =+ ChannelConfig+ { ccRequestHandler :: Bool -> ChannelRequest -> Channel ()+ }++data ChannelRequest+ = Shell+ | Execute String+ | Subsystem String+ | X11Forwarding+ | Environment String String+ | PseudoTerminal String Word32 Word32 Word32 Word32 String+ | WindowChange Word32 Word32 Word32 Word32+ | Signal String+ | ExitStatus Word32+ | ExitSignal String Bool String String+ | FlowControl Bool+ | Unknown String+ deriving Show++data Process =+ Process+ { pHandle :: ProcessHandle+ , pIn :: Handle+ , pOut :: Handle+ , pError :: Handle+ }++instance Sender Channel where+ send m = gets csSend >>= io . ($ m)+++defaultChannelConfig :: ChannelConfig+defaultChannelConfig =+ ChannelConfig+ { ccRequestHandler = \wr req ->+ case req of+ Execute cmd -> do+ spawnProcess (runInteractiveCommand cmd)+ when wr channelSuccess+ _ -> do+ channelError "accepting 'exec' requests only"+ when wr channelFail+ }++newChannel :: ChannelConfig -> (SenderMessage -> IO ()) -> Word32 -> Word32 -> Word32 -> Word32 -> String -> IO (Chan ChannelMessage)+newChannel config send us them winSize maxPacket user = do+ chan <- newChan++ dump ("new channel", winSize, maxPacket)+ forkIO $ evalStateT (do+ sendPacket $ do+ byte 91+ long them+ long us+ long (32768 * 64)+ long 32768++ chanLoop chan) $+ ChannelState+ { csConfig = config+ , csID = us+ , csTheirID = them+ , csSend = send+ , csDataReceived = 0+ , csMaxPacket = maxPacket+ , csWindowSize = 32768 * 64+ , csTheirWindowSize = winSize+ , csUser = user+ , csProcess = Nothing+ }++ return chan++chanLoop :: Chan ChannelMessage -> Channel ()+chanLoop c = do+ msg <- io (readChan c)+ dump ("got channel message", msg)++ chanid <- gets csID+ case msg of+ Request wr cr -> gets (ccRequestHandler . csConfig) >>= \f -> f wr cr+ Data msg -> do+ modify (\c -> c+ { csDataReceived =+ csDataReceived c + fromIntegral (LBS.length msg)+ })++ -- Adjust window size if needed+ rcvd <- gets csDataReceived+ max <- gets csMaxPacket+ winSize <- gets csTheirWindowSize+ when (rcvd + (max * 4) >= winSize && winSize + (max * 4) <= 2^32 - 1) $ do+ modify (\c -> c { csTheirWindowSize = winSize + (max * 4) })+ sendPacket $ do+ byte 93+ long chanid+ long (max * 4)++ -- Direct input to process's stdin+ proc <- gets csProcess+ case proc 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+ EOF -> do+ modify (\c -> c { csDataReceived = 0 })++ -- Close process's stdin to indicate EOF+ proc <- gets csProcess+ case proc of+ Nothing -> dump ("got unhandled eof")+ Just (Process _ stdin _ _) -> do+ dump ("redirecting eof", chanid)+ io $ hClose stdin+++ chanLoop c++channelError :: String -> Channel ()+channelError msg = do+ target <- gets csTheirID+ sendPacket $ do+ byte 95+ long target+ long 1+ string (msg ++ "\r\n")++channelMessage :: String -> Channel ()+channelMessage msg = do+ target <- gets csTheirID+ sendPacket $ do+ byte 94+ long target+ string (msg ++ "\r\n")++channelFail :: Channel ()+channelFail = do+ target <- gets csTheirID+ sendPacket $ do+ byte 100+ long target++channelSuccess :: Channel ()+channelSuccess = do+ target <- gets csTheirID+ sendPacket $ do+ byte 99+ long target++channelDone :: Channel ()+channelDone = do+ target <- gets csTheirID+ sendPacket (byte 96 >> long target) -- eof+ sendPacket (byte 97 >> long target) -- close++redirectHandle :: Chan () -> Packet () -> Handle -> Channel ()+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+ dump ("read data from handle", l)++ if not (null l)+ then sendPacket $ d >> string l+ else return ()++ done <- io $ hIsEOF h+ dump ("eof handle?", done)+ if done+ then io $ writeChan f ()+ else redirectLoop++ hGetAvailable :: Handle -> IO String+ hGetAvailable h = do+ ready <- hReady h `catch` const (return False)+ if not ready+ then return ""+ else do+ c <- hGetChar h+ cs <- hGetAvailable h+ 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 })++ 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++ s <- get++ -- spawn a thread to wait for the process to terminate+ io . forkIO $ do+ -- wait until both are done+ readChan done+ readChan done++ dump "done reading output! waiting for process..."+ exit <- io $ waitForProcess proc+ dump ("process exited", exit)++ flip evalStateT s $ do+ sendPacket $ do+ byte 98+ long target+ string "exit-status"+ byte 0+ long (statusCode exit)++ channelDone++ return ()+ where+ statusCode ExitSuccess = 0+ statusCode (ExitFailure n) = fromIntegral n+
+ src/SSH/Crypto.hs view
@@ -0,0 +1,115 @@+module SSH.Crypto where++import Codec.Utils (fromOctets, i2osp)+import Control.Monad (replicateM)+import Control.Monad.Trans.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)++data Cipher =+ Cipher+ { cType :: CipherType+ , cMode :: CipherMode+ , cBlockSize :: Int+ , cKeySize :: Int+ }++data CipherType = AES+data CipherMode = CBC++data HMAC =+ HMAC+ { hDigestSize :: Int+ , hFunction :: LBS.ByteString -> LBS.ByteString+ }++data PublicKey+ = RSAPublicKey+ { rpubE :: Integer+ , rpubN :: Integer+ }+ | DSAPublicKey+ { dpubP :: Integer+ , dpubQ :: Integer+ , dpubG :: Integer+ , dpubY :: Integer+ }+ deriving (Eq, Show)++data KeyPair+ = RSAKeyPair+ { rprivPub :: PublicKey+ , rprivD :: Integer+ }+ | DSAKeyPair+ { dprivPub :: PublicKey+ , dprivX :: Integer+ }+ deriving (Eq, Show)+++generator :: Integer+generator = 2++safePrime :: Integer+safePrime = 179769313486231590770839156793787453197860296048756011706444423684197180216158519368947833795864925541502180565485980503646440548199239100050792877003355816639229553136239076508735759914822574862575007425302077447712589550957937778424442426617334727629299387668709205606050270810842907692932019128194467627007++toBlocks :: (Integral a, Integral b) => a -> LBS.ByteString -> [b]+toBlocks _ m | m == LBS.empty = []+toBlocks bs m = b : rest+ where+ b = fromOctets (256 :: Integer) (LBS.unpack (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)++blob :: PublicKey -> LBS.ByteString+blob (RSAPublicKey e n) = doPacket $ do+ string "ssh-rsa"+ integer e+ integer n+blob (DSAPublicKey p q g y) = doPacket $ do+ string "ssh-dss"+ integer p+ integer q+ integer g+ integer y++blobToKey :: LBS.ByteString -> PublicKey+blobToKey s = flip evalState s $ do+ t <- readString++ case t of+ "ssh-rsa" -> do+ e <- readInteger+ n <- readInteger+ return $ RSAPublicKey e n+ "ssh-dss" -> do+ [p, q, g, y] <- replicateM 4 readInteger+ return $ DSAPublicKey p q g y+ u -> error $ "unknown public key format: " ++ u++sign :: KeyPair -> LBS.ByteString -> IO LBS.ByteString+sign (RSAKeyPair (RSAPublicKey _ n) d) m = return $ LBS.concat+ [ netString "ssh-rsa"+ , netLBS (RSA.rsassa_pkcs1_v1_5_sign RSA.ha_SHA1 (RSA.PrivateKey 256 n d) m)+ ]+sign (DSAKeyPair (DSAPublicKey p q g y) x) m = do+ (r, s) <- DSA.signDigestedDataWithDSA (DSA.tupleToDSAKeyPair (p, q, g, y, x)) digest+ return $ LBS.concat+ [ netString "ssh-dss"+ , netLBS $ LBS.concat+ [ LBS.pack $ i2osp 20 r+ , LBS.pack $ i2osp 20 s+ ]+ ]+ where+ digest = strictLBS . bytestringDigest . sha1 $ m
+ src/SSH/Debug.hs view
@@ -0,0 +1,18 @@+module SSH.Debug where++import Debug.Trace+++debugging :: Bool+debugging = False++debug :: (Show a, Show b) => b -> a -> a+debug s v+ | debugging = trace (show s ++ ": " ++ show v) v+ | otherwise = v++dump :: (Monad m, Show a) => a -> m ()+dump x+ | debugging = trace (show x) (return ())+ | otherwise = return ()+
+ src/SSH/NetReader.hs view
@@ -0,0 +1,45 @@+module SSH.NetReader where++import Control.Monad.Trans.State+import Data.Binary (decode)+import Data.Int+import Data.Word+import qualified Data.ByteString.Lazy as LBS++import SSH.Packet+import SSH.Util (fromLBS)+++type NetReader = State LBS.ByteString+++readByte :: NetReader Word8+readByte = fmap LBS.head (readBytes 1)++readLong :: NetReader Int32+readLong = fmap decode (readBytes 4)++readULong :: NetReader Word32+readULong = fmap decode (readBytes 4)++readInteger :: NetReader Integer+readInteger = do+ len <- readULong+ b <- readBytes (fromIntegral len)+ return (unmpint b)++readBytes :: Int -> NetReader LBS.ByteString+readBytes n = do+ p <- gets (LBS.take (fromIntegral n))+ modify (LBS.drop (fromIntegral n))+ return p++readLBS :: NetReader LBS.ByteString+readLBS = readULong >>= readBytes . fromIntegral++readString :: NetReader String+readString = fmap fromLBS readLBS++readBool :: NetReader Bool+readBool = readByte >>= return . (== 1)+
+ src/SSH/Packet.hs view
@@ -0,0 +1,77 @@+module SSH.Packet where++import Codec.Utils (fromOctets, i2osp)+import Control.Monad.IO.Class+import Control.Monad.Trans.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+++type Packet a = Writer LBS.ByteString a++byte :: Word8 -> Packet ()+byte = tell . encode++long :: Word32 -> Packet ()+long = tell . encode++integer :: Integer -> Packet ()+integer = tell . mpint++byteString :: LBS.ByteString -> Packet ()+byteString = tell . netLBS++string :: String -> Packet ()+string = byteString . toLBS++raw :: LBS.ByteString -> Packet ()+raw = tell++rawString :: String -> Packet ()+rawString = tell . toLBS++doPacket :: Packet a -> LBS.ByteString+doPacket = execWriter++netString :: String -> LBS.ByteString+netString = netLBS . toLBS++netLBS :: LBS.ByteString -> LBS.ByteString+netLBS bs = encode (fromIntegral (LBS.length bs) :: Word32) `LBS.append` bs++io :: MonadIO m => IO a -> m a+io = liftIO++unmpint :: LBS.ByteString -> Integer+unmpint = fromOctets (256 :: Integer) . LBS.unpack++mpint :: Integer -> LBS.ByteString+mpint i = netLBS (if LBS.head enc .&. 128 > 0+ then 0 `LBS.cons` enc+ else enc)+ where+ enc = LBS.pack (i2osp 0 i)++-- warning: don't try to send this; it's an infinite bytestring.+-- take whatever length the key needs.+makeKey :: Integer -> LBS.ByteString -> Char -> LBS.ByteString+makeKey s h c = makeKey' initial+ where+ initial = bytestringDigest . sha1 . LBS.concat $+ [ mpint s+ , h+ , LBS.singleton . fromIntegral . fromEnum $ c+ , h+ ]++ makeKey' acc = LBS.concat+ [ acc+ , makeKey' (bytestringDigest . sha1 . LBS.concat $ [mpint s, h, acc])+ ]+
+ src/SSH/Sender.hs view
@@ -0,0 +1,116 @@+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 Data.ByteString.Lazy as LBS++import SSH.Debug+import SSH.Crypto+import SSH.Packet+++data SenderState+ = NoKeys+ { senderThem :: Handle+ , senderOutSeq :: Word32+ }+ | GotKeys+ { senderThem :: Handle+ , senderOutSeq :: Word32+ , senderEncrypting :: Bool+ , senderCipher :: Cipher+ , senderKey :: Integer+ , senderVector :: Integer+ , senderHMAC :: HMAC+ }++data SenderMessage+ = Prepare Cipher Integer Integer HMAC+ | StartEncrypting+ | Send LBS.ByteString++class Sender a where+ send :: SenderMessage -> a ()++ sendPacket :: Packet () -> a ()+ sendPacket = send . Send . doPacket++sender :: Chan SenderMessage -> SenderState -> IO ()+sender ms ss = do+ m <- readChan ms+ case m of+ Prepare cipher key iv hmac -> do+ dump ("initiating encryption", key, iv)+ sender ms (GotKeys (senderThem ss) (senderOutSeq ss) False cipher key iv hmac)+ StartEncrypting -> do+ dump ("starting encryption")+ sender ms (ss { senderEncrypting = True })+ Send msg -> do+ pad <- fmap (LBS.pack . map fromIntegral) $+ replicateM (fromIntegral $ paddingLen msg) (randomRIO (0, 255 :: Int))++ let f = full msg pad++ case ss of+ GotKeys h os True cipher key iv hmac@(HMAC _ mac) -> do+ dump ("sending encrypted", os, f)+ let (encrypted, newVector) = encrypt cipher key iv f+ LBS.hPut h . LBS.concat $+ [ encrypted+ , mac . doPacket $ long os >> raw f+ ]+ hFlush h+ sender ms $ ss+ { senderOutSeq = senderOutSeq ss + 1+ , senderVector = newVector+ }+ _ -> do+ dump ("sending unencrypted", senderOutSeq ss, f)+ LBS.hPut (senderThem ss) f+ hFlush (senderThem ss)+ sender ms (ss { senderOutSeq = senderOutSeq ss + 1 })+ where+ blockSize =+ case ss of+ GotKeys { senderCipher = Cipher _ _ bs _ }+ | bs > 8 -> bs+ _ -> 8++ full msg pad = doPacket $ do+ long (len msg)+ byte (paddingLen msg)+ raw msg+ raw pad++ len :: LBS.ByteString -> Word32+ len msg = 1 + fromIntegral (LBS.length msg) + fromIntegral (paddingLen msg)++ paddingNeeded :: LBS.ByteString -> Word8+ paddingNeeded msg = fromIntegral blockSize - (fromIntegral $ (5 + LBS.length msg) `mod` fromIntegral blockSize)++ paddingLen :: LBS.ByteString -> Word8+ paddingLen msg =+ if paddingNeeded msg < 4+ 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+ , case encrypted of+ (_:_) -> fromIntegral $ 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)
+ src/SSH/Session.hs view
@@ -0,0 +1,181 @@+{-# 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 Data.Binary (decode, encode)+import Data.LargeWord+import Data.Word+import System.IO+import qualified Codec.Encryption.AES as A+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map as M++import SSH.Channel+import SSH.Crypto+import SSH.Debug+import SSH.NetReader+import SSH.Packet+import SSH.Sender+++type Session = StateT SessionState IO++data SessionState+ = Initial+ { ssConfig :: SessionConfig+ , ssChannelConfig :: ChannelConfig+ , ssThem :: Handle+ , ssSend :: SenderMessage -> IO ()+ , ssPayload :: LBS.ByteString+ , ssTheirVersion :: String+ , ssOurKEXInit :: LBS.ByteString+ , ssInSeq :: Word32+ }+ | GotKEXInit+ { ssConfig :: SessionConfig+ , ssChannelConfig :: ChannelConfig+ , ssThem :: Handle+ , ssSend :: SenderMessage -> IO ()+ , ssPayload :: LBS.ByteString+ , ssTheirVersion :: String+ , ssOurKEXInit :: LBS.ByteString+ , ssInSeq :: Word32+ , ssTheirKEXInit :: LBS.ByteString+ , ssOutCipher :: Cipher+ , ssInCipher :: Cipher+ , ssOutHMACPrep :: LBS.ByteString -> HMAC+ , ssInHMACPrep :: LBS.ByteString -> HMAC+ }+ | Final+ { ssConfig :: SessionConfig+ , ssChannelConfig :: ChannelConfig+ , ssChannels :: M.Map Word32 (Chan ChannelMessage)+ , ssID :: LBS.ByteString+ , ssThem :: Handle+ , ssSend :: SenderMessage -> IO ()+ , ssPayload :: LBS.ByteString+ , ssGotNEWKEYS :: Bool+ , ssInSeq :: Word32+ , ssInCipher :: Cipher+ , ssInHMAC :: HMAC+ , ssInKey :: Integer+ , ssInVector :: Integer+ , ssUser :: Maybe String+ }++data SessionConfig =+ SessionConfig+ { scAuthMethods :: [String]+ , scAuthorize :: Authorize -> Session Bool+ , scKeyPair :: KeyPair+ }++data Authorize+ = Password String String+ | PublicKey String PublicKey++instance Sender Session where+ send m = gets ssSend >>= io . ($ m)+++defaultSessionConfig :: SessionConfig+defaultSessionConfig =+ SessionConfig+ { scAuthMethods = ["publickey"]+ , scAuthorize = const (return True)+ , scKeyPair = RSAKeyPair (RSAPublicKey 0 0) 0+ {-\(Password u p) ->-}+ {-return $ u == "test" && p == "test"-}+ }++net :: NetReader a -> Session a+net r = do+ pl <- gets ssPayload++ let (res, new) = runState r pl++ modify (\s -> s { ssPayload = new })+ return res++newChannelID :: Session Word32+newChannelID = gets ssChannels >>= return . findNext . M.keys+ where+ findNext :: [Word32] -> Word32+ findNext ks = head . filter (not . (`elem` ks)) $ [0..]++getChannel :: Word32 -> Session (Chan ChannelMessage)+getChannel i = do+ mc <- gets (M.lookup i . ssChannels)+ case mc of+ Just c -> return c+ Nothing -> error $ "unknown channel: " ++ show i++decrypt :: LBS.ByteString -> Session LBS.ByteString+decrypt m+ | m == LBS.empty = return m+ | otherwise = do+ s <- get+ case s of+ Final+ { ssInCipher = Cipher AES CBC bs ks+ , 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++ modify (\ss -> ss { ssInVector = fromIntegral $ last blocks })+ return (fromBlocks bs decrypted)+ _ -> error "no decrypt for current state"++getPacket :: Session ()+getPacket = do+ s <- get+ h <- gets ssThem+ case s of+ Final+ { ssGotNEWKEYS = True+ , ssInCipher = Cipher _ _ bs _+ , ssInHMAC = HMAC ms f+ , ssInSeq = is+ } -> do+ let firstChunk = max 8 bs++ firstEnc <- liftIO $ LBS.hGet h firstChunk+ first <- decrypt firstEnc++ let packetLen = decode (LBS.take 4 first) :: Word32+ paddingLen = decode (LBS.drop 4 first) :: Word8++ dump ("got packet", is, first, packetLen, paddingLen)++ restEnc <- liftIO $ LBS.hGet h (fromIntegral packetLen - firstChunk + 4)+ rest <- decrypt restEnc++ let decrypted = first `LBS.append` rest+ payload = extract packetLen paddingLen decrypted++ mac <- liftIO $ LBS.hGet h ms+ dump ("got mac, valid?", verify mac is decrypted f)++ modify (\ss -> ss { ssPayload = payload })+ _ -> do+ first <- liftIO $ LBS.hGet h 5++ let packetLen = decode (LBS.take 4 first) :: Word32+ paddingLen = decode (LBS.drop 4 first) :: Word8++ rest <- liftIO $ LBS.hGet h (fromIntegral packetLen - 5 + 4)+ let payload = LBS.take (fromIntegral packetLen - fromIntegral paddingLen - 1) rest+ modify (\ss -> ss { ssPayload = payload })+ where+ extract pkl pdl d = LBS.take (fromIntegral pkl - fromIntegral pdl - 1) (LBS.drop 5 d)+ verify m is d f = m == f (encode (fromIntegral is :: Word32) `LBS.append` d)
+ src/SSH/Util.hs view
@@ -0,0 +1,14 @@+module SSH.Util where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+++toLBS :: String -> LBS.ByteString+toLBS = LBS.pack . map (fromIntegral . fromEnum)++fromLBS :: LBS.ByteString -> String+fromLBS = map (toEnum . fromIntegral) . LBS.unpack++strictLBS :: LBS.ByteString -> BS.ByteString+strictLBS = BS.concat . LBS.toChunks
+ ssh.cabal view
@@ -0,0 +1,53 @@+name: ssh+version: 0.1+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:++ <http://darcsden.com/alex/darcsden/browse/Main.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+ authorization, etc. Similar to Python's Twisted Conch library.+homepage: http://darcsden.com/alex/ssh+license: BSD3+license-file: LICENSE+author: Alex Suraci+maintainer: i.am@toogeneric.com+category: Network+build-type: Simple+cabal-version: >= 1.6+stability: Unstable++source-repository head+ type: darcs+ location: http://darcsden.com/alex/ssh++library+ hs-source-dirs: src++ exposed-modules: SSH,+ SSH.Channel,+ SSH.Crypto,+ SSH.NetReader,+ SSH.Packet,+ SSH.Sender,+ SSH.Session++ other-modules: SSH.Debug,+ SSH.Util+ + build-depends: base >= 4 && < 5,+ binary,+ bytestring,+ Crypto,+ containers,+ HsOpenSSL >= 0.8,+ network,+ process,+ RSA,+ random,+ SHA,+ split,+ transformers