{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Network.SSH.Message
(
Message (..)
, MessageStream (..)
, Disconnected (..)
, DisconnectReason (..)
, Ignore (..)
, Unimplemented (..)
, Debug (..)
, ServiceRequest (..)
, ServiceAccept (..)
, KexInit (..)
, KexNewKeys (..)
, KexEcdhInit (..)
, KexEcdhReply (..)
, UserAuthRequest (..)
, UserAuthFailure (..)
, UserAuthSuccess (..)
, UserAuthBanner (..)
, UserAuthPublicKeyOk (..)
, ChannelOpen (..)
, ChannelOpenType (..)
, ChannelOpenConfirmation (..)
, ChannelOpenFailure (..)
, ChannelOpenFailureReason (..)
, ChannelWindowAdjust (..)
, ChannelData (..)
, ChannelExtendedData (..)
, ChannelEof (..)
, ChannelClose (..)
, ChannelRequest (..)
, ChannelRequestEnv (..)
, ChannelRequestPty (..)
, ChannelRequestWindowChange (..)
, ChannelRequestShell (..)
, ChannelRequestExec (..)
, ChannelRequestSignal (..)
, ChannelRequestExitStatus (..)
, ChannelRequestExitSignal (..)
, ChannelSuccess (..)
, ChannelFailure (..)
, AuthMethod (..)
, ChannelId (..)
, ChannelType (..)
, ChannelPacketSize
, ChannelWindowSize
, Cookie (), newCookie, nilCookie
, Password (..)
, PtySettings (..)
, PublicKey (..)
, SessionId (..)
, Signature (..)
, Version (..)
, ServiceName
, UserName
) where
import Control.Applicative
import Control.Monad (void)
import Crypto.Error
import qualified Crypto.PubKey.Curve25519 as Curve25519
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.RSA as RSA
import Crypto.Random
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Short as SBS
import Data.Foldable
import Data.Typeable
import Data.Word
import System.Exit
import qualified Network.SSH.Builder as B
import Network.SSH.Exception
import Network.SSH.Encoding
import Network.SSH.Key
import Network.SSH.Name
class MessageStream a where
sendMessage :: forall msg. Encoding msg => a -> msg -> IO ()
receiveMessage :: forall msg. Encoding msg => a -> IO msg
data Message
= MsgDisconnect Disconnected
| MsgIgnore Ignore
| MsgUnimplemented Unimplemented
| MsgDebug Debug
| MsgServiceRequest ServiceRequest
| MsgServiceAccept ServiceAccept
| MsgKexInit KexInit
| MsgKexNewKeys KexNewKeys
| MsgKexEcdhInit KexEcdhInit
| MsgKexEcdhReply KexEcdhReply
| MsgUserAuthRequest UserAuthRequest
| MsgUserAuthFailure UserAuthFailure
| MsgUserAuthSuccess UserAuthSuccess
| MsgUserAuthBanner UserAuthBanner
| MsgUserAuthPublicKeyOk UserAuthPublicKeyOk
| MsgChannelOpen ChannelOpen
| MsgChannelOpenConfirmation ChannelOpenConfirmation
| MsgChannelOpenFailure ChannelOpenFailure
| MsgChannelWindowAdjust ChannelWindowAdjust
| MsgChannelData ChannelData
| MsgChannelExtendedData ChannelExtendedData
| MsgChannelEof ChannelEof
| MsgChannelClose ChannelClose
| MsgChannelRequest ChannelRequest
| MsgChannelSuccess ChannelSuccess
| MsgChannelFailure ChannelFailure
| MsgUnknown Word8
deriving (Eq, Show)
data Disconnected
= Disconnected
{ disconnectedReason :: DisconnectReason
, disconnectedDescription :: SBS.ShortByteString
, disconnectedLanguageTag :: SBS.ShortByteString
}
deriving (Eq, Show, Typeable)
data Ignore
= Ignore
deriving (Eq, Show)
data Unimplemented
= Unimplemented Word32
deriving (Eq, Show)
data Debug
= Debug
{ debugAlwaysDisplay :: Bool
, debugMessage :: SBS.ShortByteString
, debugLanguageTag :: SBS.ShortByteString
}
deriving (Eq, Show)
data ServiceRequest
= ServiceRequest ServiceName
deriving (Eq, Show)
data ServiceAccept
= ServiceAccept ServiceName
deriving (Eq, Show)
data KexInit
= KexInit
{ kexCookie :: Cookie
, kexKexAlgorithms :: [Name]
, kexServerHostKeyAlgorithms :: [Name]
, kexEncryptionAlgorithmsClientToServer :: [Name]
, kexEncryptionAlgorithmsServerToClient :: [Name]
, kexMacAlgorithmsClientToServer :: [Name]
, kexMacAlgorithmsServerToClient :: [Name]
, kexCompressionAlgorithmsClientToServer :: [Name]
, kexCompressionAlgorithmsServerToClient :: [Name]
, kexLanguagesClientToServer :: [Name]
, kexLanguagesServerToClient :: [Name]
, kexFirstPacketFollows :: Bool
} deriving (Eq, Show)
data KexNewKeys
= KexNewKeys
deriving (Eq, Show)
data KexEcdhInit
= KexEcdhInit
{ kexClientEphemeralKey :: Curve25519.PublicKey
}
deriving (Eq, Show)
data KexEcdhReply
= KexEcdhReply
{ kexServerHostKey :: PublicKey
, kexServerEphemeralKey :: Curve25519.PublicKey
, kexHashSignature :: Signature
}
deriving (Eq, Show)
data UserAuthRequest
= UserAuthRequest UserName ServiceName AuthMethod
deriving (Eq, Show)
data UserAuthFailure
= UserAuthFailure [Name] Bool
deriving (Eq, Show)
data UserAuthSuccess
= UserAuthSuccess
deriving (Eq, Show)
data UserAuthBanner
= UserAuthBanner SBS.ShortByteString SBS.ShortByteString
deriving (Eq, Show)
data UserAuthPublicKeyOk
= UserAuthPublicKeyOk PublicKey
deriving (Eq, Show)
data ChannelOpen
= ChannelOpen ChannelId ChannelWindowSize ChannelPacketSize ChannelOpenType
deriving (Eq, Show)
data ChannelOpenType
= ChannelOpenSession
| ChannelOpenDirectTcpIp
{ coDestinationAddress :: SBS.ShortByteString
, coDestinationPort :: Word32
, coSourceAddress :: SBS.ShortByteString
, coSourcePort :: Word32
}
| ChannelOpenOther ChannelType
deriving (Eq, Show)
data ChannelOpenConfirmation
= ChannelOpenConfirmation ChannelId ChannelId ChannelWindowSize ChannelPacketSize
deriving (Eq, Show)
data ChannelOpenFailure
= ChannelOpenFailure ChannelId ChannelOpenFailureReason SBS.ShortByteString SBS.ShortByteString
deriving (Eq, Show)
data ChannelOpenFailureReason
= ChannelOpenAdministrativelyProhibited
| ChannelOpenConnectFailed
| ChannelOpenUnknownChannelType
| ChannelOpenResourceShortage
| ChannelOpenOtherFailure Word32
deriving (Eq, Show)
data ChannelWindowAdjust
= ChannelWindowAdjust ChannelId ChannelWindowSize
deriving (Eq, Show)
data ChannelData
= ChannelData ChannelId SBS.ShortByteString
deriving (Eq, Show)
data ChannelExtendedData
= ChannelExtendedData ChannelId Word32 SBS.ShortByteString
deriving (Eq, Show)
data ChannelEof
= ChannelEof ChannelId
deriving (Eq, Show)
data ChannelClose
= ChannelClose ChannelId
deriving (Eq, Show)
data ChannelRequest
= ChannelRequest
{ crChannel :: ChannelId
, crType :: SBS.ShortByteString
, crWantReply :: Bool
, crData :: BS.ByteString
} deriving (Eq, Show)
data ChannelRequestEnv
= ChannelRequestEnv
{ crVariableName :: SBS.ShortByteString
, crVariableValue :: SBS.ShortByteString
} deriving (Eq, Show)
data ChannelRequestPty
= ChannelRequestPty
{ crPtySettings :: PtySettings
} deriving (Eq, Show)
data ChannelRequestWindowChange
= ChannelRequestWindowChange
{ crWidth :: Word32
, crHeight :: Word32
, crWidthPixels :: Word32
, crHeightPixels :: Word32
} deriving (Eq, Show)
data ChannelRequestShell
= ChannelRequestShell
deriving (Eq, Show)
data ChannelRequestExec
= ChannelRequestExec
{ crCommand :: SBS.ShortByteString
} deriving (Eq, Show)
data ChannelRequestSignal
= ChannelRequestSignal
{ crSignal :: SBS.ShortByteString
} deriving (Eq, Show)
data ChannelRequestExitStatus
= ChannelRequestExitStatus
{ crExitStatus :: ExitCode
} deriving (Eq, Show)
data ChannelRequestExitSignal
= ChannelRequestExitSignal
{ crSignalName :: SBS.ShortByteString
, crCodeDumped :: Bool
, crErrorMessage :: SBS.ShortByteString
, crLanguageTag :: SBS.ShortByteString
} deriving (Eq, Show)
data ChannelSuccess
= ChannelSuccess ChannelId
deriving (Eq, Show)
data ChannelFailure
= ChannelFailure ChannelId
deriving (Eq, Show)
data AuthMethod
= AuthNone
| AuthHostBased
| AuthPassword Password
| AuthPublicKey PublicKey (Maybe Signature)
| AuthOther Name
deriving (Eq, Show)
instance HasName AuthMethod where
name AuthNone = Name "none"
name AuthHostBased = Name "hostbased"
name AuthPassword {} = Name "password"
name AuthPublicKey {} = Name "publickey"
name (AuthOther n) = n
data Signature
= SignatureEd25519 Ed25519.Signature
| SignatureRSA BS.ByteString
| SignatureOther Name
deriving (Eq, Show)
instance HasName Signature where
name SignatureEd25519 {} = Name "ssh-ed25519"
name SignatureRSA {} = Name "ssh-rsa"
name (SignatureOther n) = n
data PtySettings
= PtySettings
{ ptyEnv :: SBS.ShortByteString
, ptyWidthCols :: Word32
, ptyHeightRows :: Word32
, ptyWidthPixels :: Word32
, ptyHeightPixels :: Word32
, ptyModes :: SBS.ShortByteString
} deriving (Eq, Show)
type ChannelWindowSize = Word32
type ChannelPacketSize = Word32
type UserName = Name
type ServiceName = Name
newtype Cookie = Cookie SBS.ShortByteString
deriving (Eq, Ord, Show)
newtype Version = Version SBS.ShortByteString
deriving (Eq, Ord, Show)
newtype Password = Password SBS.ShortByteString
deriving (Eq, Ord, Show)
newtype SessionId = SessionId SBS.ShortByteString
deriving (Eq, Ord, Show)
newtype ChannelType = ChannelType SBS.ShortByteString
deriving (Eq, Ord, Show)
newtype ChannelId = ChannelId Word32
deriving (Eq, Ord, Show)
newCookie :: MonadRandom m => m Cookie
newCookie = Cookie . SBS.toShort <$> getRandomBytes 16
nilCookie :: Cookie
nilCookie = Cookie $ SBS.toShort $ BS.replicate 16 0
instance Encoding Message where
put = \case
MsgDisconnect x -> put x
MsgIgnore x -> put x
MsgUnimplemented x -> put x
MsgDebug x -> put x
MsgServiceRequest x -> put x
MsgServiceAccept x -> put x
MsgKexInit x -> put x
MsgKexNewKeys x -> put x
MsgKexEcdhInit x -> put x
MsgKexEcdhReply x -> put x
MsgUserAuthRequest x -> put x
MsgUserAuthFailure x -> put x
MsgUserAuthSuccess x -> put x
MsgUserAuthBanner x -> put x
MsgUserAuthPublicKeyOk x -> put x
MsgChannelOpen x -> put x
MsgChannelOpenConfirmation x -> put x
MsgChannelOpenFailure x -> put x
MsgChannelWindowAdjust x -> put x
MsgChannelData x -> put x
MsgChannelExtendedData x -> put x
MsgChannelEof x -> put x
MsgChannelClose x -> put x
MsgChannelRequest x -> put x
MsgChannelSuccess x -> put x
MsgChannelFailure x -> put x
MsgUnknown x -> putWord8 x
get =
MsgDisconnect <$> get <|>
MsgIgnore <$> get <|>
MsgUnimplemented <$> get <|>
MsgDebug <$> get <|>
MsgServiceRequest <$> get <|>
MsgServiceAccept <$> get <|>
MsgKexInit <$> get <|>
MsgKexNewKeys <$> get <|>
MsgKexEcdhInit <$> get <|>
MsgKexEcdhReply <$> get <|>
MsgUserAuthRequest <$> get <|>
MsgUserAuthFailure <$> get <|>
MsgUserAuthSuccess <$> get <|>
MsgUserAuthBanner <$> get <|>
MsgUserAuthPublicKeyOk <$> get <|>
MsgChannelOpen <$> get <|>
MsgChannelOpenConfirmation <$> get <|>
MsgChannelOpenFailure <$> get <|>
MsgChannelWindowAdjust <$> get <|>
MsgChannelData <$> get <|>
MsgChannelExtendedData <$> get <|>
MsgChannelEof <$> get <|>
MsgChannelClose <$> get <|>
MsgChannelRequest <$> get <|>
MsgChannelSuccess <$> get <|>
MsgChannelFailure <$> get <|> (MsgUnknown <$> getWord8)
instance Encoding Disconnected where
put (Disconnected r d l) =
putWord8 1 <>
put r <>
putShortString d <>
putShortString l
get = do
expectWord8 1
Disconnected <$> get <*> getShortString <*> getShortString
instance Encoding DisconnectReason where
put r = B.word32BE $ case r of
DisconnectHostNotAllowedToConnect -> 1
DisconnectProtocolError -> 2
DisconnectKeyExchangeFailed -> 3
DisconnectReserved -> 4
DisconnectMacError -> 5
DisconnectCompressionError -> 6
DisconnectServiceNotAvailable -> 7
DisconnectProtocolVersionNotSupported -> 8
DisconnectHostKeyNotVerifiable -> 9
DisconnectConnectionLost -> 10
DisconnectByApplication -> 11
DisconnectTooManyConnection -> 12
DisconnectAuthCancelledByUser -> 13
DisconnectNoMoreAuthMethodsAvailable -> 14
DisconnectIllegalUsername -> 15
DisconnectOtherReason n -> n
get = (<$> getWord32) $ \case
1 -> DisconnectHostNotAllowedToConnect
2 -> DisconnectProtocolError
3 -> DisconnectKeyExchangeFailed
4 -> DisconnectReserved
5 -> DisconnectMacError
6 -> DisconnectCompressionError
7 -> DisconnectServiceNotAvailable
8 -> DisconnectProtocolVersionNotSupported
9 -> DisconnectHostKeyNotVerifiable
10 -> DisconnectConnectionLost
11 -> DisconnectByApplication
12 -> DisconnectTooManyConnection
13 -> DisconnectAuthCancelledByUser
14 -> DisconnectNoMoreAuthMethodsAvailable
15 -> DisconnectIllegalUsername
r -> DisconnectOtherReason r
instance Encoding Ignore where
put _ = putWord8 2
get = expectWord8 2 >> pure Ignore
instance Encoding Unimplemented where
put (Unimplemented w) = putWord8 3 <> B.word32BE w
get = expectWord8 3 >> Unimplemented <$> getWord32
instance Encoding Debug where
put (Debug ad msg lang) = putWord8 4 <> putBool ad <> putShortString msg <> putShortString lang
get = expectWord8 4 >> Debug <$> getBool <*> getShortString <*> getShortString
instance Encoding ServiceRequest where
put (ServiceRequest n) = putWord8 5 <> putName n
get = expectWord8 5 >> ServiceRequest <$> getName
instance Encoding ServiceAccept where
put (ServiceAccept n) = putWord8 6 <> putName n
get = expectWord8 6 >> ServiceAccept <$> getName
instance Encoding KexInit where
put kex =
putWord8 20 <>
put (kexCookie kex) <>
putNameList (kexKexAlgorithms kex) <>
putNameList (kexServerHostKeyAlgorithms kex) <>
putNameList (kexEncryptionAlgorithmsClientToServer kex) <>
putNameList (kexEncryptionAlgorithmsServerToClient kex) <>
putNameList (kexMacAlgorithmsClientToServer kex) <>
putNameList (kexMacAlgorithmsServerToClient kex) <>
putNameList (kexCompressionAlgorithmsClientToServer kex) <>
putNameList (kexCompressionAlgorithmsServerToClient kex) <>
putNameList (kexLanguagesClientToServer kex) <>
putNameList (kexLanguagesServerToClient kex) <>
putBool (kexFirstPacketFollows kex) <>
B.word32BE 0
get = do
expectWord8 20
kex <- KexInit <$> get
<*> getNameList <*> getNameList <*> getNameList <*> getNameList
<*> getNameList <*> getNameList <*> getNameList <*> getNameList
<*> getNameList <*> getNameList <*> getBool
void getWord32
pure kex
instance Encoding KexNewKeys where
put _ = putWord8 21
get = expectWord8 21 >> pure KexNewKeys
instance Encoding KexEcdhInit where
put (KexEcdhInit key) = putWord8 30 <> put key
get = expectWord8 30 >> KexEcdhInit <$> get
instance Encoding KexEcdhReply where
put (KexEcdhReply hkey ekey sig) = putWord8 31 <> put hkey <> put ekey <> put sig
get = expectWord8 31 >> KexEcdhReply <$> get <*> get <*> get
instance Encoding UserAuthRequest where
put (UserAuthRequest un sn am) = putWord8 50 <> putName un <> putName sn <> put am
get = expectWord8 50 >> UserAuthRequest <$> getName <*> getName <*> get
instance Encoding UserAuthFailure where
put (UserAuthFailure ms ps) =
putWord8 51 <>
putNameList ms <>
putBool ps
get = do
expectWord8 51
UserAuthFailure <$> getNameList <*> getBool
instance Encoding UserAuthSuccess where
put UserAuthSuccess = putWord8 52
get = expectWord8 52 >> pure UserAuthSuccess
instance Encoding UserAuthBanner where
put (UserAuthBanner x y) = putWord8 53 <> putShortString x <> putShortString y
get = expectWord8 53 >> UserAuthBanner <$> getShortString <*> getShortString
instance Encoding UserAuthPublicKeyOk where
put (UserAuthPublicKeyOk pk) = putWord8 60 <> putName (name pk) <> put pk
get = expectWord8 60 >> getName >> UserAuthPublicKeyOk <$> get
instance Encoding ChannelOpen where
put (ChannelOpen rc rw rp ct) =
putWord8 90 <>
(case ct of
ChannelOpenSession {} -> put (ChannelType "session")
ChannelOpenDirectTcpIp {} -> put (ChannelType "direct-tcpip")
ChannelOpenOther t -> put t ) <>
put rc <>
B.word32BE rw <>
B.word32BE rp <>
case ct of
ChannelOpenSession {} -> mempty
ChannelOpenDirectTcpIp da dp sa sp ->
putShortString da <>
B.word32BE dp <>
putShortString sa <>
B.word32BE sp
ChannelOpenOther {} -> mempty
get = do
expectWord8 90
ct <- get
rc <- get
rw <- getWord32
rp <- getWord32
ChannelOpen rc rw rp <$> case ct of
ChannelType "session" ->
pure ChannelOpenSession
ChannelType "direct-tcpip" ->
ChannelOpenDirectTcpIp
<$> getShortString
<*> getWord32
<*> getShortString
<*> getWord32
other ->
pure $ ChannelOpenOther other
instance Encoding ChannelOpenConfirmation where
put (ChannelOpenConfirmation a b ws ps) =
putWord8 91 <>
put a <>
put b <>
B.word32BE ws <>
B.word32BE ps
get = do
expectWord8 91
ChannelOpenConfirmation
<$> get
<*> get
<*> getWord32
<*> getWord32
instance Encoding ChannelOpenFailure where
put (ChannelOpenFailure cid reason descr lang) =
putWord8 92 <>
put cid <>
put reason <>
putShortString descr <>
putShortString lang
get = do
expectWord8 92
ChannelOpenFailure <$> get <*> get <*> getShortString <*> getShortString
instance Encoding ChannelOpenFailureReason where
put r = B.word32BE $ case r of
ChannelOpenAdministrativelyProhibited -> 1
ChannelOpenConnectFailed -> 2
ChannelOpenUnknownChannelType -> 3
ChannelOpenResourceShortage -> 4
ChannelOpenOtherFailure w32 -> w32
get = (<$> getWord32) $ \case
1 -> ChannelOpenAdministrativelyProhibited
2 -> ChannelOpenConnectFailed
3 -> ChannelOpenUnknownChannelType
4 -> ChannelOpenResourceShortage
w32 -> ChannelOpenOtherFailure w32
instance Encoding ChannelWindowAdjust where
put (ChannelWindowAdjust cid ws) = putWord8 93 <> put cid <> B.word32BE ws
get = expectWord8 93 >> ChannelWindowAdjust <$> get <*> getWord32
instance Encoding ChannelData where
put (ChannelData cid ba) = putWord8 94 <> put cid <> putShortString ba
get = expectWord8 94 >> ChannelData <$> get <*> getShortString
instance Encoding ChannelExtendedData where
put (ChannelExtendedData cid x ba) = putWord8 95 <> put cid <> B.word32BE x <> putShortString ba
get = expectWord8 95 >> ChannelExtendedData <$> get <*> getWord32 <*> getShortString
instance Encoding ChannelEof where
put (ChannelEof cid) = putWord8 96 <> put cid
get = expectWord8 96 >> ChannelEof <$> get
instance Encoding ChannelClose where
put (ChannelClose cid) = putWord8 97 <> put cid
get = expectWord8 97 >> ChannelClose <$> get
instance Encoding ChannelRequest where
put (ChannelRequest cid typ reply dat) = putWord8 98 <> put cid <> putShortString typ <> putBool reply <> putByteString dat
get = expectWord8 98 >> ChannelRequest <$> get <*> getShortString <*> getBool <*> getRemainingByteString
instance Encoding ChannelRequestEnv where
put (ChannelRequestEnv key value) = putShortString key <> putShortString value
get = ChannelRequestEnv <$> getShortString <*> getShortString
instance Encoding ChannelRequestPty where
put (ChannelRequestPty settings) = put settings
get = ChannelRequestPty <$> get
instance Encoding ChannelRequestWindowChange where
put (ChannelRequestWindowChange x0 x1 x2 x3) = B.word32BE x0 <> B.word32BE x1 <> B.word32BE x2 <> B.word32BE x3
get = ChannelRequestWindowChange <$> getWord32 <*> getWord32 <*> getWord32 <*> getWord32
instance Encoding ChannelRequestShell where
put _ = mempty
get = pure ChannelRequestShell
instance Encoding ChannelRequestExec where
put (ChannelRequestExec c) = putShortString c
get = ChannelRequestExec <$> getShortString
instance Encoding ChannelRequestSignal where
put (ChannelRequestSignal signame) = putShortString signame
get = ChannelRequestSignal <$> getShortString
instance Encoding ChannelRequestExitStatus where
put (ChannelRequestExitStatus code) = putExitCode code
get = ChannelRequestExitStatus <$> getExitCode
instance Encoding ChannelRequestExitSignal where
put (ChannelRequestExitSignal signame core msg lang) = putShortString signame <> putBool core <> putShortString msg <> putShortString lang
get = ChannelRequestExitSignal <$> getShortString <*> getBool <*> getShortString <*> getShortString
instance Encoding ChannelSuccess where
put (ChannelSuccess cid) = putWord8 99 <> put cid
get = expectWord8 99 >> (ChannelSuccess <$> get)
instance Encoding ChannelFailure where
put (ChannelFailure cid) = putWord8 100 <> put cid
get = expectWord8 100 >> (ChannelFailure <$> get)
instance Encoding Cookie where
put (Cookie s) = B.shortByteString s
get = Cookie . SBS.toShort <$> getBytes 16
instance Encoding ChannelId where
put (ChannelId x) = B.word32BE x
get = ChannelId <$> getWord32
instance Encoding ChannelType where
put (ChannelType x) = putShortString x
get = ChannelType <$> getShortString
instance Encoding SessionId where
put (SessionId x) = putShortString x
get = SessionId <$> getShortString
instance Encoding Version where
put (Version x) =
B.shortByteString x <>
putWord8 0x0d <>
putWord8 0x0a
get = do
mapM_ expectWord8 magic
untilCRLF 0 (reverse magic)
where
magic :: [Word8]
magic = [0x53,0x53,0x48,0x2d,0x32,0x2e,0x30,0x2d]
untilCRLF !i !xs
| i >= (246 :: Int) = fail mempty
| otherwise = getWord8 >>= \case
0x0d -> getWord8 >>= \case
0x0a -> pure (Version $ SBS.toShort $ BS.pack $ reverse xs)
_ -> fail mempty
x -> untilCRLF (i+1) (x:xs)
instance Encoding AuthMethod where
put m = putName (name m) <> case m of
AuthNone -> mempty
AuthHostBased -> mempty
AuthPassword (Password pw) ->
putBool False <> putShortString pw
AuthPublicKey pk msig -> case msig of
Nothing -> putBool False <> putName (name pk) <> put pk
Just sig -> putBool True <> putName (name pk) <> put pk <> put sig
AuthOther {} -> mempty
get = getName >>= \case
Name "none" ->
pure AuthNone
Name "hostbased" ->
pure AuthHostBased
Name "password" ->
void getBool >> AuthPassword <$> (Password <$> getShortString)
Name "publickey" -> do
signed <- getBool
void getShortString
key <- get
msig <- if signed then Just <$> get else pure Nothing
pure (AuthPublicKey key msig)
other -> pure (AuthOther other)
instance Encoding PublicKey where
put k = B.word32BE (len k - 4) <> putName (name k) <> case k of
PublicKeyEd25519 key -> put key
PublicKeyRSA key -> putRsaPublicKey key
PublicKeyOther {} -> mempty
where
len = fromIntegral . B.length . put
get = getFramed $ getName >>= \case
Name "ssh-ed25519" -> PublicKeyEd25519 <$> get
Name "ssh-rsa" -> PublicKeyRSA <$> getRsaPublicKey
other -> PublicKeyOther <$> pure other
instance Encoding Signature where
put s = B.word32BE (len s - 4) <> putName (name s) <> case s of
SignatureEd25519 sig -> put sig
SignatureRSA sig -> putString sig
SignatureOther {} -> mempty
where
len = fromIntegral . B.length . put
get = getFramed $ getName >>= \case
Name "ssh-ed25519" -> SignatureEd25519 <$> get
Name "ssh-rsa" -> SignatureRSA <$> getString
other -> SignatureOther <$> pure other
instance Encoding PtySettings where
put (PtySettings env wc hc wp hp modes) =
putShortString env <> B.word32BE wc <> B.word32BE hc <> B.word32BE wp <> B.word32BE hp <> putShortString modes
get =
PtySettings <$> getShortString <*> getWord32 <*> getWord32 <*> getWord32 <*> getWord32 <*> getShortString
putNameList :: (B.Builder b) => [Name] -> b
putNameList xs = B.word32BE (fromIntegral $ g xs) <> h xs
where
g [] = 0
g ys = sum ((\(Name y) -> SBS.length y) <$> ys) + length ys - 1
h [] = mempty
h [Name y] = B.shortByteString y
h (Name y:ys) = B.shortByteString y <> B.word8 0x2c <> h ys
getNameList :: Get [Name]
getNameList = do
s <- getString :: Get BS.ByteString
pure $ Name . SBS.toShort <$> BS.split 0x2c s
instance Encoding Curve25519.PublicKey where
put = putString
get = getString >>= \s-> case Curve25519.publicKey (s :: BA.Bytes) of
CryptoPassed k -> pure k
CryptoFailed _ -> fail ""
instance Encoding Ed25519.PublicKey where
put = putString
get = getString >>= \s-> case Ed25519.publicKey (s :: BA.Bytes) of
CryptoPassed k -> pure k
CryptoFailed _ -> fail ""
instance Encoding Ed25519.Signature where
put = putString
get = getString >>= \s-> case Ed25519.signature (s :: BA.Bytes) of
CryptoPassed k -> pure k
CryptoFailed _ -> fail ""
putRsaPublicKey :: B.Builder b => RSA.PublicKey -> b
putRsaPublicKey (RSA.PublicKey _ n e) =
putInteger n <>
putInteger e
where
putInteger x = putString bs
where
bs = BA.pack $ g $ f x [] :: BS.ByteString
f 0 acc = acc
f i acc = let (q,r) = quotRem i 256
in f q (fromIntegral r : acc)
g [] = []
g yys@(y:_) | y > 128 = 0:yys
| otherwise = yys
getRsaPublicKey :: Get RSA.PublicKey
getRsaPublicKey = do
(n,_) <- getIntegerAndSize
(e,s) <- getIntegerAndSize
pure $ RSA.PublicKey s n e
where
getIntegerAndSize :: Get (Integer, Int)
getIntegerAndSize = do
ws <- dropWhile (== 0) . (BA.unpack :: BS.ByteString -> [Word8]) <$> getString
pure (foldl' (\acc w8-> acc * 256 + fromIntegral w8) 0 ws, length ws * 8)