git.iko.soy/isoparsec
on 4ba121e help sign in
04fff3e
swap
1 ahead, 4 behind
debugger/Main.hsnew file+142
since splitsnapshots
unifiedsplit
@@ -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))
package.yaml+15
@@ -28,6 +28,9 @@ dependencies:
28- mtl
28- mtl
29- profunctors
29- profunctors
30- mono-traversable
30- mono-traversable
31+- brick
32+- vty
33+- word-wrap
31
34
32library:
35library:
33 source-dirs: src
36 source-dirs: src
@@ -58,6 +61,7 @@ default-extensions:
58- TypeOperators
61- TypeOperators
59- UndecidableInstances
62- UndecidableInstances
60- RankNTypes
63- RankNTypes
64+- DeriveFunctor
61
65
62tests:
66tests:
63 isoparsec-test:
67 isoparsec-test:
@@ -78,3 +82,14 @@ tests:
78 - QuickCheck
82 - QuickCheck
79 - megaparsec
83 - megaparsec
80 - bytestring
84 - bytestring
85+
86+executable:
87+ source-dirs: debugger
88+ main: Main.hs
89+ dependencies:
90+ - isoparsec
91+ - lens
92+ ghc-options:
93+ - -threaded
94+ - -rtsopts
95+ - -with-rtsopts=-N
src/Data/Isoparsec/Debugger.hsnew file+6
@@ -0,0 +1,6 @@
1+module Data.Isoparsec.Debugger
2+ ( debug,
3+ )
4+where
5+
6+import Data.Isoparsec.Debugger.UI
src/Data/Isoparsec/Debugger/Internal.hsnew file+75
@@ -0,0 +1,75 @@
1+module Data.Isoparsec.Debugger.Internal
2+ ( IsoparsecDebugger (..),
3+ DebuggerAction (..),
4+ DebuggerArrow (..),
5+ )
6+where
7+
8+import Data.Isoparsec
9+import Prelude hiding ((.), id)
10+
11+data IsoparsecDebugger
12+ = DEmpty
13+ | DSeq IsoparsecDebugger IsoparsecDebugger
14+ | DAlt IsoparsecDebugger IsoparsecDebugger
15+ | DAction DebuggerAction
16+ deriving (Show)
17+
18+data DebuggerAction
19+ = AnyToken
20+ | Token String
21+ | Token'
22+ | Tokens String
23+ | Tokens'
24+ | Chunk String
25+ | Chunk'
26+ | NotToken String
27+ | TokenWhere
28+ | ManyTokens
29+ | TakeUntil String
30+ | TokensWhile
31+ | TokensWhile1
32+ | Other String
33+ deriving (Eq, Ord, Show)
34+
35+newtype DebuggerArrow s a b = DebuggerArrow {runDebuggerArrow :: IsoparsecDebugger}
36+
37+instance Category (DebuggerArrow s) where
38+ id = DebuggerArrow DEmpty
39+ (DebuggerArrow a) . (DebuggerArrow b) = DebuggerArrow $ DSeq b a
40+
41+instance BaseArrow (DebuggerArrow s) where
42+ (DebuggerArrow a) *** (DebuggerArrow b) = DebuggerArrow $ DSeq b a
43+ (DebuggerArrow a) &&& (DebuggerArrow b) = DebuggerArrow $ DSeq b a
44+ first (DebuggerArrow a) = DebuggerArrow a
45+ second (DebuggerArrow a) = DebuggerArrow a
46+
47+instance ArrowZero (DebuggerArrow s) where
48+ zeroArrow = DebuggerArrow DEmpty
49+
50+instance ArrowPlus (DebuggerArrow s) where
51+ (DebuggerArrow a) <+> (DebuggerArrow b) = DebuggerArrow $ DAlt b a
52+
53+instance ArrowChoice (DebuggerArrow s) where
54+ (DebuggerArrow a) ||| (DebuggerArrow b) = DebuggerArrow $ DAlt b a
55+ (DebuggerArrow a) +++ (DebuggerArrow b) = DebuggerArrow $ DAlt b a
56+
57+instance PolyArrow p (DebuggerArrow s) where
58+ arr _ = DebuggerArrow DEmpty
59+
60+instance (IsSequence s, Show s) => Isoparsec (DebuggerArrow s) s where
61+ anyToken = DebuggerArrow $ DAction AnyToken
62+ token = DebuggerArrow . DAction . Token . show . singleton @s
63+ token' = DebuggerArrow $ DAction Token'
64+ tokens = DebuggerArrow . DAction . Tokens . show . fromList @s
65+ tokens' = DebuggerArrow $ DAction Tokens'
66+ chunk = DebuggerArrow . DAction . Chunk . show
67+ chunk' = DebuggerArrow $ DAction Chunk'
68+ notToken = DebuggerArrow . DAction . NotToken . show . singleton @s
69+ tokenWhere _ = DebuggerArrow $ DAction TokenWhere
70+ manyTokens = DebuggerArrow $ DAction ManyTokens
71+ takeUntil = DebuggerArrow . DAction . TakeUntil . show
72+ tokensWhile _ = DebuggerArrow $ DAction TokensWhile
73+ tokensWhile1 _ = DebuggerArrow $ DAction TokensWhile1
74+ tuck (DebuggerArrow a) = DebuggerArrow a
75+ tuck' (DebuggerArrow a) = DebuggerArrow a
src/Data/Isoparsec/Debugger/UI.hsnew file+120
@@ -0,0 +1,120 @@
1+module Data.Isoparsec.Debugger.UI
2+ ( debug,
3+ )
4+where
5+
6+import Brick
7+import Brick.Widgets.Border
8+import Brick.Widgets.Center
9+import Control.Monad
10+import Control.Monad.IO.Class
11+import Data.Isoparsec.Debugger.Internal
12+import Graphics.Vty
13+import Text.Wrap
14+
15+debug :: DebuggerArrow s a b -> IO ()
16+debug (DebuggerArrow debugger) = do
17+ putStrLn . take 200 . show . rebalanceState $ debugger
18+ void $
19+ defaultMain
20+ app
21+ DebuggerState
22+ { displayedState = startDisplaying . rebalanceState $ debugger
23+ }
24+
25+app :: App DebuggerState DebuggerEvent DebuggerName
26+app =
27+ App
28+ { appDraw = pure . renderState This . Rendered . displayedState,
29+ appChooseCursor = showFirstCursor,
30+ appHandleEvent = eventHandler,
31+ appStartEvent = \s -> do
32+ vty <- getVtyHandle
33+ let output = outputIface vty
34+ when (supportsMode output Mouse)
35+ $ liftIO
36+ $ setMode output Mouse True
37+ return s,
38+ appAttrMap = const $ attrMap defAttr []
39+ }
40+
41+eventHandler :: DebuggerState -> BrickEvent DebuggerName DebuggerEvent -> EventM DebuggerName (Next DebuggerState)
42+eventHandler s (VtyEvent (EvKey KEsc _)) = halt s
43+eventHandler s (MouseUp n _ _) =
44+ continue $ s {displayedState = unRender $ expand n (Rendered $ displayedState s)}
45+eventHandler s _ = continue s
46+
47+data DebuggerState
48+ = DebuggerState
49+ { displayedState :: DisplayDebuggerState
50+ }
51+
52+data DisplayDebuggerState
53+ = DDSeq (DebugRenderState DisplayDebuggerState) (DebugRenderState DisplayDebuggerState)
54+ | DDAlt (DebugRenderState DisplayDebuggerState) (DebugRenderState DisplayDebuggerState)
55+ | DDAction DebuggerAction
56+ | DDEmpty
57+ deriving (Show)
58+
59+data DebugRenderState a
60+ = Rendered a
61+ | Delayed a
62+ deriving (Show, Functor)
63+
64+unRender :: DebugRenderState a -> a
65+unRender (Rendered a) = a
66+unRender (Delayed a) = a
67+
68+startDisplaying :: IsoparsecDebugger -> DisplayDebuggerState
69+startDisplaying DEmpty = DDEmpty
70+startDisplaying (DAction a) = DDAction a
71+startDisplaying (DSeq a b) =
72+ DDSeq (Rendered $ startDisplaying a) (Delayed $ startDisplaying b)
73+startDisplaying (DAlt a b) =
74+ DDAlt (Rendered $ startDisplaying a) (Delayed $ startDisplaying b)
75+
76+renderState :: DebuggerName -> DebugRenderState DisplayDebuggerState -> Widget DebuggerName
77+renderState n (Delayed _) = clickable n $ renderSmallNode " + "
78+renderState _ (Rendered DDEmpty) = renderSmallNode "*"
79+renderState _ (Rendered (DDAction a)) = renderNode $ show a
80+renderState n (Rendered (DDSeq a b)) = renderState (L n) a <=> renderState (R n) b
81+renderState n (Rendered (DDAlt a b)) = renderState (L n) a <+> renderState (R n) b
82+
83+rebalanceState :: IsoparsecDebugger -> IsoparsecDebugger
84+rebalanceState DEmpty = DEmpty
85+rebalanceState a@(DAction _) = a
86+rebalanceState (DAlt (DAlt a b) c) = rebalanceState $ DAlt (rebalanceState a) (rebalanceState $ DAlt b c)
87+rebalanceState (DAlt a b) = DAlt (rebalanceState a) (rebalanceState b)
88+rebalanceState (DSeq (DSeq a b) c) = rebalanceState $ DSeq (rebalanceState a) (rebalanceState $ DSeq b c)
89+rebalanceState (DSeq DEmpty c) = rebalanceState c
90+rebalanceState (DSeq a b) = DSeq (rebalanceState a) (rebalanceState b)
91+
92+expand ::
93+ DebuggerName ->
94+ DebugRenderState DisplayDebuggerState ->
95+ DebugRenderState DisplayDebuggerState
96+expand This (Delayed s) = Rendered s
97+expand (L n) (Rendered (DDSeq l r)) = Rendered $ DDSeq (expand n l) r
98+expand (L n) (Rendered (DDAlt l r)) = Rendered $ DDAlt (expand n l) r
99+expand (R n) (Rendered (DDAlt l r)) = Rendered $ DDAlt l (expand n r)
100+expand (R n) (Rendered (DDSeq l r)) = Rendered $ DDSeq l (expand n r)
101+expand n (Delayed s) = expand n (Rendered s)
102+expand _ s = s
103+
104+data DebuggerName
105+ = This
106+ | L DebuggerName
107+ | R DebuggerName
108+ deriving (Eq, Ord, Show)
109+
110+data DebuggerEvent = U
111+ deriving (Show)
112+
113+nodeWidth :: Int
114+nodeWidth = 16
115+
116+renderSmallNode :: String -> Widget n
117+renderSmallNode = hLimit nodeWidth . hCenter . border . str
118+
119+renderNode :: String -> Widget n
120+renderNode = hLimit nodeWidth . hCenter . border . strWrapWith (WrapSettings False True)