@@ -0,0 +1,142 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+
3+module Main
4+ ( main,
5+ )
6+where
7+
8+import Control.Lens.TH
9+import Data.ByteString as BS
10+import qualified Data.Char as C
11+import Data.Isoparsec
12+import Data.Isoparsec.ByteString
13+import Data.Isoparsec.Debugger
14+import GHC.Generics
15+import Prelude as P hiding ((.), id)
16+
17+data MessageNumber
18+ = DisconnectMsg
19+ | IgnoreMsg
20+ | UnimplementedMsg
21+ | DebugMsg
22+ | ServiceRequestMsg
23+ | ServiceAcceptMsg
24+ | KextInitMsg
25+ | NewKeysMsg
26+ deriving (Eq, Show, Ord)
27+
28+instance ToIsoparsec MessageNumber ByteString a where
29+ toIsoparsec =
30+ anyToken
31+ >>> mapIso
32+ [ (1, DisconnectMsg),
33+ (2, IgnoreMsg),
34+ (3, UnimplementedMsg),
35+ (4, DebugMsg),
36+ (5, ServiceRequestMsg),
37+ (6, ServiceAcceptMsg),
38+ (20, KextInitMsg),
39+ (21, NewKeysMsg)
40+ ]
41+
42+newtype DisconnectReasonCode
43+ = DisconnectReasonCode {unDisconnectReasonCode :: Byte32 'BE}
44+ deriving (Eq, Ord, Show, Generic)
45+
46+instance ToIsoparsec DisconnectReasonCode ByteString a
47+
48+newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}
49+ deriving (Eq, Ord, Show, Generic)
50+
51+instance ToIsoparsec AlwaysDisplay ByteString a
52+
53+newtype PacketSequenceNumber
54+ = PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}
55+ deriving (Eq, Ord, Show, Generic)
56+
57+instance ToIsoparsec PacketSequenceNumber ByteString a
58+
59+data Payload
60+ = VersionPayload String
61+ | IgnorePayload ByteString
62+ | ServiceRequest SSHString
63+ | DebugPayload AlwaysDisplay SSHString
64+ | DisconnectPayload DisconnectReasonCode String
65+ | ServiceAccept SSHString
66+ | UnimplementedPayload PacketSequenceNumber
67+ deriving (Show, Eq)
68+
69+makePrisms ''Payload
70+
71+instance ToIsoparsec Payload ByteString a where
72+ toIsoparsec =
73+ ( _DisconnectPayload
74+ <.> specific DisconnectMsg
75+ &&& auto @DisconnectReasonCode
76+ &&& (tokensWhile (const True) >>> utf8)
77+ )
78+ <+> ( _ServiceRequest <.> specific ServiceRequestMsg
79+ &&& auto @SSHString
80+ )
81+ <+> ( _VersionPayload <.> chunk "SSH-2.0-"
82+ &&& (tokensWhile (`BS.notElem` " \n\r") >>> utf8)
83+ &&& ( (chunk " " >>> takeUntil "\r\n" >>^ (maskr . turn . konst $ ""))
84+ <+> chunk "\r\n"
85+ )
86+ )
87+ <+> (_IgnorePayload <.> specific IgnoreMsg &&& tokensWhile (const True))
88+ <+> ( _DebugPayload <.> specific DebugMsg
89+ &&& auto @AlwaysDisplay
90+ &&& auto @SSHString
91+ )
92+ <+> ( _UnimplementedPayload <.> specific UnimplementedMsg
93+ &&& auto @PacketSequenceNumber
94+ )
95+ <+> ( _ServiceAccept <.> specific ServiceAcceptMsg
96+ &&& auto @SSHString
97+ )
98+
99+newtype Padding = Padding {unPadding :: ByteString}
100+ deriving (Eq, Ord, Show, Generic)
101+
102+newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}
103+ deriving (Eq, Ord, Show, Generic)
104+
105+badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding
106+badZeroPadding =
107+ throughIntegral
108+ >>> manyTokens
109+ >>^ siPure
110+ (ZeroPadding . fromIntegral . BS.length)
111+ (flip BS.replicate 0 . fromIntegral . zeroPaddingLength)
112+
113+newtype MAC = MAC {unMAC :: ByteString}
114+ deriving (Eq, Ord, Show, Generic)
115+
116+data NoneMAC = NoneMAC
117+ deriving (Eq, Ord, Show, Generic)
118+
119+instance ToIsoparsec NoneMAC b a where
120+ toIsoparsec = arr $ konst NoneMAC
121+
122+data Packet mac
123+ = Packet Payload ZeroPadding mac
124+ deriving (Eq, Show)
125+
126+makePrisms ''Packet
127+
128+instance ToIsoparsec mac ByteString a => ToIsoparsec (Packet mac) ByteString a where
129+ toIsoparsec =
130+ ( auto @(Byte32 'BE) &&& auto @Byte8
131+ >>> throughIntegral *** throughIntegral
132+ >>^ siPure
133+ (\(packetL, paddingL) -> (packetL - paddingL - 1, paddingL))
134+ (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))
135+ >>> manyTokens *** throughIntegral
136+ >>> tuck (auto @Payload) *** badZeroPadding
137+ )
138+ &&& auto @mac
139+ >>^ siPure (\((a, b), c) -> Packet a b c) (\(Packet a b c) -> ((a, b), c))
140+
141+main :: IO ()
142+main = debug @ByteString (auto @(Packet NoneMAC))