diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/SSH.hs b/src/SSH.hs new file mode 100644 --- /dev/null +++ b/src/SSH.hs @@ -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 diff --git a/src/SSH/Channel.hs b/src/SSH/Channel.hs new file mode 100644 --- /dev/null +++ b/src/SSH/Channel.hs @@ -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 + diff --git a/src/SSH/Crypto.hs b/src/SSH/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/SSH/Crypto.hs @@ -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 diff --git a/src/SSH/Debug.hs b/src/SSH/Debug.hs new file mode 100644 --- /dev/null +++ b/src/SSH/Debug.hs @@ -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 () + diff --git a/src/SSH/NetReader.hs b/src/SSH/NetReader.hs new file mode 100644 --- /dev/null +++ b/src/SSH/NetReader.hs @@ -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) + diff --git a/src/SSH/Packet.hs b/src/SSH/Packet.hs new file mode 100644 --- /dev/null +++ b/src/SSH/Packet.hs @@ -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]) + ] + diff --git a/src/SSH/Sender.hs b/src/SSH/Sender.hs new file mode 100644 --- /dev/null +++ b/src/SSH/Sender.hs @@ -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) diff --git a/src/SSH/Session.hs b/src/SSH/Session.hs new file mode 100644 --- /dev/null +++ b/src/SSH/Session.hs @@ -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) diff --git a/src/SSH/Util.hs b/src/SSH/Util.hs new file mode 100644 --- /dev/null +++ b/src/SSH/Util.hs @@ -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 diff --git a/ssh.cabal b/ssh.cabal new file mode 100644 --- /dev/null +++ b/ssh.cabal @@ -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: + + . + + 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