typed-protocols-doc (empty) → 0.2.0.0
raw patch · 18 files changed
+2366/−0 lines, 18 filesdep +aesondep +basedep +base64-bytestring
Dependencies added: aeson, base, base64-bytestring, blaze-html, bytestring, containers, fgl, filepath, graphviz, haddock-library, knob, mtl, optparse-applicative, serdoc-core, tasty, tasty-quickcheck, template-haskell, temporary, text, th-abstraction, time, typed-protocols, typed-protocols-doc
Files
- CHANGELOG.md +0/−0
- LICENSE +177/−0
- NOTICE +14/−0
- demo/DemoProtocol.hs +154/−0
- demo/Main.hs +20/−0
- src/Network/TypedProtocol/Documentation.hs +15/−0
- src/Network/TypedProtocol/Documentation/DefaultMain.hs +104/−0
- src/Network/TypedProtocol/Documentation/GraphViz.hs +86/−0
- src/Network/TypedProtocol/Documentation/Html.hs +423/−0
- src/Network/TypedProtocol/Documentation/TH.hs +185/−0
- src/Network/TypedProtocol/Documentation/Text.hs +391/−0
- src/Network/TypedProtocol/Documentation/Types.hs +96/−0
- test/Main.hs +8/−0
- test/Network/TypedProtocol/Tests/ControlProtocol.hs +312/−0
- test/Network/TypedProtocol/Tests/Documentation.hs +88/−0
- test/Network/TypedProtocol/Tests/TestProtocol.hs +152/−0
- test/Network/TypedProtocol/Tests/TestProtocolTH.hs +43/−0
- typed-protocols-doc.cabal +98/−0
+ CHANGELOG.md view
+ LICENSE view
@@ -0,0 +1,177 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS
+ NOTICE view
@@ -0,0 +1,14 @@+Copyright 2019-2025 Input Output Global Inc (IOG)++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+
+ demo/DemoProtocol.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-- for `deriveSerDoc`+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module DemoProtocol+where++import Control.Monad.Identity+import Control.Monad.Except++import Data.Proxy+import Data.SerDoc.Class+import Data.SerDoc.Info+import Data.SerDoc.TH+import Data.Text (Text)+import Data.Word++import Network.TypedProtocol.Core++data PongInfo =+ PongInfo+ { pongTimestamp :: Word64+ , pongPeerID :: Word64+ , pongMessage :: Text+ }+ deriving (Show, Eq)++data DemoProtocol a where+ -- | Idle state: server waits for ping.+ IdleState :: DemoProtocol a++ -- | Awaiting pong state: server has received ping, client waits for pong.+ AwaitingPongState :: DemoProtocol a++ -- | End state: either side has terminated the session+ EndState :: DemoProtocol a++data SingDemoProtocol a where+ SingIdleState :: SingDemoProtocol (IdleState :: DemoProtocol a)+ SingAwaitingPongState :: SingDemoProtocol (AwaitingPongState :: DemoProtocol a)+ SingEndState :: SingDemoProtocol (EndState :: DemoProtocol a)++instance StateTokenI IdleState where stateToken = SingIdleState+instance StateTokenI AwaitingPongState where stateToken = SingAwaitingPongState+instance StateTokenI EndState where stateToken = SingEndState++instance Protocol (DemoProtocol a) where+ data Message (DemoProtocol a) st st' where+ PingMessage :: Message (DemoProtocol a) IdleState AwaitingPongState+ PongMessage :: Message (DemoProtocol a) AwaitingPongState IdleState+ ComplexPongMessage :: Message (DemoProtocol a) AwaitingPongState IdleState+ EndMessage :: Message (DemoProtocol a) st EndState++ type StateAgency IdleState = ServerAgency+ type StateAgency AwaitingPongState = ClientAgency+ type StateAgency EndState = NobodyAgency++ type StateToken = SingDemoProtocol++++data DemoCodec a++instance Codec (DemoCodec a) where+ type MonadEncode (DemoCodec a) = Identity+ type MonadDecode (DemoCodec a) = Except String++data PongEnum = NormalPong | ComplexPong+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++data PingEnum = PingRequest | EndPing+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++deriving via (ViaEnum PongEnum)+ instance (Codec codec, HasInfo codec (DefEnumEncoding codec)) => HasInfo codec PongEnum++deriving via (ViaEnum PingEnum)+ instance (Codec codec, HasInfo codec (DefEnumEncoding codec)) => HasInfo codec PingEnum++instance HasInfo (DemoCodec b) () where+ info _ _ = basicField "()" (FixedSize 0)++instance HasInfo (DemoCodec b) Text where+ info codec _ =+ compoundField "Text"+ [ ("length", info codec (Proxy @Word32))+ , ("data", basicField "UTF8 dat" (FixedSize 0))+ ]++instance HasInfo (DemoCodec b) a => HasInfo (DemoCodec b) [a] where+ info codec (_ :: Proxy [a]) =+ compoundField "List"+ [ ( "length", info codec (Proxy @Word32))+ , ( "values"+ , listField (VarSize "length") (info codec (Proxy @a))+ )+ ]+++instance HasInfo (DemoCodec b) a => HasInfo (DemoCodec b) (Maybe a) where+ info codec (_ :: Proxy (Maybe a)) =+ compoundField "Maybe"+ [ ("isJust", info codec (Proxy @Word32))+ , ( "value"+ , sumField "isJust"+ [ ("Nothing", info codec (Proxy @()))+ , ("Just", info codec (Proxy @a))+ ]+ )+ ]++instance HasInfo (DemoCodec b) (Message (DemoProtocol a) IdleState AwaitingPongState) where+ info codec _ = infoOf "PingRequest" $ info codec (Proxy @PingEnum)++instance HasInfo (DemoCodec b) (Message (DemoProtocol a) st EndState) where+ info codec _ = infoOf "EndPing" $ info codec (Proxy @PingEnum)++instance HasInfo (DemoCodec a) Word16 where+ info _ _ = basicField "Word16" (FixedSize 2)++instance HasInfo (DemoCodec a) Word32 where+ info _ _ = basicField "Word32" (FixedSize 4)++instance HasInfo (DemoCodec a) Word64 where+ info _ _ = basicField "Word64" (FixedSize 8)++$(deriveSerDoc ''DemoCodec [] ''PongInfo)++instance HasInfo (DemoCodec b) (Message (DemoProtocol a) AwaitingPongState IdleState) where+ info codec _ =+ compoundField "Pong"+ [ ("pongType", info codec (Proxy @PongEnum))+ , ("pongData"+ , choiceField+ (IndexField "pongType")+ [ info codec (Proxy @())+ , info codec (Proxy @PongInfo)+ ]+ )+ ]
+ demo/Main.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PartialTypeSignatures #-}++module Main+where++import Network.TypedProtocol.Documentation+import DemoProtocol+import Data.SerDoc.Class++main :: IO ()+main = defaultMain+ [ $(describeProtocol ''DemoProtocol [''()] ''DemoCodec [''()])+ ]
+ src/Network/TypedProtocol/Documentation.hs view
@@ -0,0 +1,15 @@+module Network.TypedProtocol.Documentation+( + module M++, protocolToSVGFile+, protocolToDotFile++, defaultMain+)+where++import Network.TypedProtocol.Documentation.Types as M+import Network.TypedProtocol.Documentation.TH as M+import Network.TypedProtocol.Documentation.GraphViz+import Network.TypedProtocol.Documentation.DefaultMain
+ src/Network/TypedProtocol/Documentation/DefaultMain.hs view
@@ -0,0 +1,104 @@+module Network.TypedProtocol.Documentation.DefaultMain+where++import qualified Data.Text.Lazy as LText+import qualified Text.Blaze.Html.Renderer.Pretty as Pretty+import Data.SerDoc.Class hiding (info)+import Data.Word+import qualified Network.TypedProtocol.Documentation.Html as HTML+import qualified Network.TypedProtocol.Documentation.Text as TextRender+import Network.TypedProtocol.Documentation.Types+import Options.Applicative+import Control.Monad+import System.FilePath+import qualified Data.Aeson as JSON+import Data.Text.Encoding+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as Text+import System.Exit+import System.IO+import System.IO.Unsafe++data MainOptions =+ MainOptions+ { moOutputFile :: Maybe FilePath+ , moOutputFormat :: OutputFormat+ , moListProtocols :: Bool+ }++data OutputFormat+ = OutputAuto+ | OutputText+ | OutputHtml+ | OutputJSON+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++parseOutputFormat :: String -> Maybe OutputFormat+parseOutputFormat "auto" = return OutputAuto+parseOutputFormat "text" = return OutputText+parseOutputFormat "html" = return OutputHtml+parseOutputFormat "json" = return OutputJSON+parseOutputFormat _ = Nothing++pMainOptions :: Parser MainOptions+pMainOptions =+ MainOptions+ <$> option (Just <$> str)+ ( short 'o'+ <> value Nothing+ <> metavar "FILE"+ <> help "Output file (default: stdout)"+ )+ <*> option (maybeReader parseOutputFormat)+ ( short 'f'+ <> value OutputAuto+ <> metavar "FORMAT"+ <> help "Output format; one of: html, text, json, auto"+ )+ <*> switch+ ( long "list-protocols"+ <> long "list"+ <> short 'l'+ <> help "Print a list of protocols and exit"+ )+++defaultMain :: ( HasInfo codec (DefEnumEncoding codec)+ , HasInfo codec Word32+ ) => [ProtocolDescription codec] -> IO ()+defaultMain descriptions = do+ mainOptions <- execParser $ info (pMainOptions <**> helper) fullDesc+ if moListProtocols mainOptions then do+ forM_ descriptions $ \d -> do+ putStrLn (protocolName d)+ else do+ let write = maybe putStrLn writeFile $ moOutputFile mainOptions+ render = getRenderer (moOutputFormat mainOptions) (moOutputFile mainOptions)+ write . render $ descriptions++getRenderer :: ( HasInfo codec (DefEnumEncoding codec)+ , HasInfo codec Word32+ )+ => OutputFormat+ -> Maybe FilePath+ -> [ProtocolDescription codec]+ -> String+getRenderer OutputAuto path =+ case takeExtension <$> path of+ Just ".html" -> getRenderer OutputHtml path+ Just ".htm" -> getRenderer OutputHtml path+ Just ".json" -> getRenderer OutputJSON path+ Just ".txt" -> getRenderer OutputText path+ Nothing -> abort "Cannot detect output file format"+ Just ext -> abort $ "Cannot detect output file format from extension " ++ show ext+getRenderer OutputHtml _ =+ Pretty.renderHtml . HTML.wrapDocument . HTML.renderProtocolDescriptions+getRenderer OutputText _ =+ LText.unpack . TextRender.renderProtocolDescriptions+getRenderer OutputJSON _ =+ Text.unpack . decodeUtf8 . LBS.toStrict . JSON.encode++abort :: String -> a+abort msg = unsafePerformIO $ do+ hPutStrLn stderr msg+ exitFailure
+ src/Network/TypedProtocol/Documentation/GraphViz.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.TypedProtocol.Documentation.GraphViz+where++import Data.Maybe+import qualified Data.GraphViz as Dot+import qualified Data.GraphViz.Attributes.Complete as Dot+import Data.Graph.Inductive.Graph (mkGraph, Node)+import Data.Graph.Inductive.PatriciaTree (Gr)+import qualified Data.Text.Lazy as LText+import qualified Data.Map.Strict as Map+import System.IO (Handle)+import qualified Data.ByteString as BS++import Network.TypedProtocol.Documentation.Types++protocolToDot :: ProtocolDescription codec -> Dot.DotGraph Node+protocolToDot proto =+ Dot.graphToDot+ Dot.nonClusteredParams+ { Dot.fmtNode = \ (_, (name, agency)) ->+ stateToNode name agency+ , Dot.fmtEdge = \ (_, _, name) ->+ [ Dot.Label (Dot.StrLabel $ LText.pack name)+ ]+ , Dot.globalAttributes =+ [ Dot.GraphAttrs+ [ Dot.FontSize 10.0+ , Dot.LabelFontSize 10.0+ ]+ , Dot.NodeAttrs+ [ Dot.FontName "Noto Sans"+ , Dot.LabelFontName "Noto Sans"+ ]+ , Dot.EdgeAttrs+ [ Dot.FontName "Noto Sans"+ , Dot.LabelFontName "Noto Sans"+ , Dot.FontSize 8.0+ , Dot.LabelFontSize 8.0+ ]+ ]+ }+ (mkGraph numberedStateInfos edges :: Gr (StateRef, AgencyID) String)+ where+ stateInfos = [ (name, agency) | (name, _, agency) <- protocolStates proto ]+ stateNames = map fst stateInfos+ numberedStateInfos = zip [0::Int,1..] stateInfos+ numberedStateNames = zip [0::Int,1..] stateNames+ stateDict =+ Map.fromList $ map flipPair numberedStateNames++ agencyColor NobodyAgencyID = Dot.toColorList [Dot.X11Color Dot.Black]+ agencyColor ServerAgencyID = Dot.toColorList [Dot.X11Color Dot.Blue]+ agencyColor ClientAgencyID = Dot.toColorList [Dot.X11Color Dot.Brown]++ edges = catMaybes $ flip map (protocolMessages proto) $ \msg -> do+ fromIndex <- Map.lookup (messageFromState msg) stateDict+ toIndex <- Map.lookup (messageToState msg) stateDict+ return (fromIndex, toIndex, messageName msg)++ stateToNode AnyState _ =+ [ Dot.Label (Dot.StrLabel "any state")+ , Dot.Color (Dot.toColorList [Dot.X11Color Dot.Gray])+ ]+ stateToNode (State name) agency =+ [ Dot.Label (Dot.StrLabel $ LText.pack name)+ , Dot.Color (agencyColor agency)+ ]++flipPair :: (a, b) -> (b, a)+flipPair (x, y) = (y, x)++protocolToSVGFile :: ProtocolDescription codec -> FilePath -> IO FilePath+protocolToSVGFile proto =+ Dot.runGraphvizCommand Dot.Dot (protocolToDot proto) Dot.Svg++protocolToDotFile :: ProtocolDescription codec -> FilePath -> IO FilePath+protocolToDotFile proto =+ Dot.runGraphvizCommand Dot.Dot (protocolToDot proto) Dot.Canon++hProtocolToSVG :: ProtocolDescription codec -> Handle -> IO ()+hProtocolToSVG proto dst =+ Dot.graphvizWithHandle Dot.Dot (protocolToDot proto) Dot.Svg consume+ where+ consume src = BS.hGetContents src >>= BS.hPut dst
+ src/Network/TypedProtocol/Documentation/Html.hs view
@@ -0,0 +1,423 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.TypedProtocol.Documentation.Html+where++import Control.Monad+import Data.Maybe+import qualified Documentation.Haddock.Parser as Haddock+import qualified Documentation.Haddock.Types as Haddock+import Text.Blaze.Html5 (Html, (!))+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as HA+import Text.Printf+import Data.Word+import qualified Data.Knob as Knob+import Data.ByteString (ByteString)+import qualified Data.ByteString.Base64 as Base64+import System.IO.Unsafe (unsafePerformIO)+import System.IO (IOMode (..))++import Network.TypedProtocol.Documentation.Types+import Network.TypedProtocol.Documentation.GraphViz++import Data.SerDoc.Info+import Data.SerDoc.Class++renderDescriptions :: [Description] -> Html+renderDescriptions = mapM_ $ \(Description h) -> do+ let (docs :: [Haddock.DocH () String]) =+ map (Haddock.toRegular . Haddock._doc . Haddock.parseParas Nothing) h+ mapM_ (\doc -> H.p ! HA.class_ "haddock" $ renderHaddock doc) docs++renderHaddock :: Haddock.DocH mod String -> Html+renderHaddock Haddock.DocEmpty = mempty+renderHaddock (Haddock.DocAppend a b) = renderHaddock a <> renderHaddock b+renderHaddock (Haddock.DocString str) = H.string str+renderHaddock (Haddock.DocParagraph a) = H.p (renderHaddock a)+renderHaddock (Haddock.DocIdentifier i) = H.span ! HA.class_ "identifier" $ H.string i+renderHaddock (Haddock.DocIdentifierUnchecked _) = H.span ! HA.class_ "unchecked" $ "**unchecked**"+renderHaddock (Haddock.DocModule (Haddock.ModLink label _)) = H.span ! HA.class_ "module" $ H.string label+renderHaddock (Haddock.DocWarning a) = H.div ! HA.class_ "warning" $ renderHaddock a+renderHaddock (Haddock.DocEmphasis a) = H.em $ renderHaddock a+renderHaddock (Haddock.DocMonospaced a) = H.code $ renderHaddock a+renderHaddock (Haddock.DocBold a) = H.strong $ renderHaddock a+renderHaddock (Haddock.DocUnorderedList items) = H.ul $ forM_ items $ \item -> H.li (renderHaddock item)+renderHaddock (Haddock.DocOrderedList items) = H.ol $ forM_ items $ \(_, item) -> H.li (renderHaddock item)+renderHaddock (Haddock.DocDefList items) =+ H.dl $ forM_ items $ \(title, body) ->+ H.div $ do+ H.dt $ renderHaddock title+ H.dd $ renderHaddock body+renderHaddock (Haddock.DocCodeBlock a) = H.code $ renderHaddock a+renderHaddock (Haddock.DocHyperlink (Haddock.Hyperlink url a)) =+ H.a ! HA.href (H.stringValue url) $ maybe (H.string url) renderHaddock a+renderHaddock (Haddock.DocPic (Haddock.Picture url title)) =+ H.div ! HA.class_ "omitted" $ do+ forM_ title (H.p . H.string)+ H.p . H.string $ url+renderHaddock (Haddock.DocMathInline str) = H.span ! HA.class_ "math" $ H.string str+renderHaddock (Haddock.DocMathDisplay str) = H.div ! HA.class_ "math" $ H.string str+renderHaddock (Haddock.DocAName str) = H.span ! HA.class_ "aname" $ H.string str+renderHaddock (Haddock.DocProperty str) = H.span ! HA.class_ "property" $ H.string str+renderHaddock (Haddock.DocExamples examples) =+ forM_ examples $ \(Haddock.Example expr results) -> do+ H.div ! HA.class_ "example" $ do+ H.code ! HA.class_ "expr" $ H.string expr+ H.code ! HA.class_ "result" $ do+ forM_ results $ \resultLine -> do+ H.string resultLine+ H.br+renderHaddock (Haddock.DocHeader (Haddock.Header level a)) = do+ let h = case level of+ 1 -> H.h1+ 2 -> H.h2+ 3 -> H.h3+ 4 -> H.h4+ 5 -> H.h5+ _ -> H.h6+ h $ renderHaddock a+renderHaddock (Haddock.DocTable (Haddock.Table headerRows bodyRows)) = do+ H.table $ do+ H.thead $ do+ forM_ headerRows $ \row -> do+ H.tr $ do+ forM_ (Haddock.tableRowCells row) $ \(Haddock.TableCell colspan rowspan body) -> do+ H.th ! HA.colspan (H.toValue colspan)+ ! HA.rowspan (H.toValue rowspan)+ $ renderHaddock body+ H.tbody $ do+ forM_ bodyRows $ \row -> do+ H.tr $ do+ forM_ (Haddock.tableRowCells row) $ \(Haddock.TableCell colspan rowspan body) -> do+ H.td ! HA.colspan (H.toValue colspan)+ ! HA.rowspan (H.toValue rowspan)+ $ renderHaddock body++data TOC a = TOC a [TOC a]+ deriving (Show, Eq, Ord)++renderTOC :: TOC (String, String) -> Html+renderTOC (TOC (label, href) children) = do+ H.section ! HA.class_ "toc" $ do+ H.a ! HA.href (H.stringValue $ "#" ++ href) $ H.string label+ forM_ children renderTOC++stateID :: String -> String -> String+stateID protoName stateName = protoName ++ "_state_" ++ stateName++stateTOC :: String -> String -> TOC (String, String)+stateTOC protoName stateName = TOC (stateName, stateID protoName stateName) []++renderState :: String -> [MessageDescription codec] -> (StateRef, [Description], AgencyID) -> Html+renderState _ _ (AnyState, _, _) =+ return ()+renderState protoName msgs (State stateName, descriptions, agency) =+ H.div ! HA.class_ "state" $ do+ H.h3 ! HA.id (H.stringValue (stateID protoName stateName)) $ H.string stateName+ renderDescriptions descriptions+ H.p $ do+ "Agency: "+ case agency of+ ClientAgencyID -> H.strong ! HA.class_ "client-agency" $ "client"+ ServerAgencyID -> H.strong ! HA.class_ "server-agency" $ "server"+ NobodyAgencyID -> H.strong ! HA.class_ "nobody-agency" $ "nobody"+ unless (null messagesFromHere) $ do+ H.h4 "Messages from here:"+ H.ul $ do+ forM_ messagesFromHere $ \msg -> do+ H.li $ do+ H.strong $+ H.a ! HA.href (H.stringValue ("#" ++ messageID protoName (messageName msg))) $ H.string (messageName msg)+ " (to "+ formatStateRef protoName (messageToState msg)+ ")"+ unless (null messagesToHere) $ do+ H.h4 "Messages to here:"+ H.ul $ do+ forM_ messagesToHere $ \msg -> do+ H.li $ do+ H.strong $+ H.a ! HA.href (H.stringValue ("#" ++ messageID protoName (messageName msg))) $ H.string (messageName msg)+ " (from "+ formatStateRef protoName (messageFromState msg)+ ")"+ where+ messagesFromHere = filter ((matchState stateName) . messageFromState) msgs+ messagesToHere = filter ((matchState stateName) . messageToState) msgs++ matchState :: String -> StateRef -> Bool+ matchState _ AnyState = True+ matchState a (State b) = a == b++formatStateRef :: String -> StateRef -> Html+formatStateRef _ AnyState =+ H.span "any state"+formatStateRef protoName (State name) =+ H.a ! HA.href (H.stringValue ("#" ++ stateID protoName name)) $ H.string name++messageID :: String -> String -> String+messageID protoName msgName = protoName ++ "_message_" ++ msgName++messageTOC :: String -> MessageDescription codec -> TOC (String, String)+messageTOC protoName msg =+ TOC (messageName msg, messageID protoName (messageName msg)) []++formatFieldSize :: FieldSize -> String+formatFieldSize (FixedSize n) = show n+formatFieldSize (VarSize var) = var+formatFieldSize UnknownSize = "VARIABLE"+formatFieldSize EnumSize = "ENUM"+formatFieldSize (RangeSize lo hi) = "(" ++ formatFieldSize lo ++ " .. " ++ formatFieldSize hi ++ ")"+formatFieldSize (BinopSize FSPlus a b) = "(" ++ formatFieldSize a ++ " + " ++ formatFieldSize b ++ ")"+formatFieldSize (BinopSize FSMul a b) = "(" ++ formatFieldSize a ++ " * " ++ formatFieldSize b ++ ")"+formatFieldSize (BinopSize FSMax a b) = "MAX(" ++ formatFieldSize a ++ ", " ++ formatFieldSize b ++ ")"+formatFieldSize (BinopSize FSMin a b) = "MIN(" ++ formatFieldSize a ++ ", " ++ formatFieldSize b ++ ")"++renderMessage :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))+ => String -> MessageDescription codec -> Html+renderMessage protoName msg =+ H.div ! HA.class_ "message" $ do+ H.h3 ! HA.id (H.stringValue (messageID protoName (messageName msg))) $ H.string (messageName msg)+ renderDescriptions (messageDescription msg)+ H.h4 $ "State Transition"+ H.p $ do+ formatStateRef protoName (messageFromState msg)+ " -> "+ formatStateRef protoName (messageToState msg)+ unless (null $ messagePayload msg) $ do+ H.h4 "Payload"+ H.ul $ do+ forM_ (messagePayload msg) $ H.li . H.string+ H.h4 "Serialization Format"+ fieldSpecToHTML (messageInfo msg)+ +protocolTOC :: ProtocolDescription codec -> TOC (String, String)+protocolTOC proto =+ let protoName = protocolName proto+ in+ TOC (protoName, protoName)+ [ TOC ("States", protoName ++ "_states")+ [ stateTOC protoName stateName | (State stateName, _, _) <- protocolStates proto ]+ , TOC ("Messages", protoName ++ "_messages")+ [ messageTOC protoName msg | msg <- protocolMessages proto ]+ ]++protocolToSvgMem :: ProtocolDescription codec -> ByteString+protocolToSvgMem proto = unsafePerformIO $ do+ k <- Knob.newKnob ""+ Knob.withFileHandle k "unknown" WriteMode $ \h ->+ hProtocolToSVG proto h+ Knob.getContents k++renderDiagramSvg :: ProtocolDescription codec -> Html+renderDiagramSvg proto = do+ let protoSvg = protocolToSvgMem proto+ uri = "data:image/svg+xml;base64," <> Base64.encode protoSvg+ H.img ! HA.src (H.unsafeByteStringValue uri)+ ! HA.class_ "state-diagram"++renderProtocol :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))+ => ProtocolDescription codec -> Html+renderProtocol proto = do+ let protoName = protocolName proto+ msgs = protocolMessages proto+ H.section ! HA.class_ "protocol" $ do+ H.h1 ! HA.id (H.stringValue protoName) $ H.string protoName+ "Version ID: "+ H.code $ H.string (protocolIdentifier proto)+ renderDescriptions (protocolDescription proto)+ H.section $ do+ H.h2 ! HA.id (H.stringValue $ protoName ++ "_state_diagram") $ "State Diagram"+ renderDiagramSvg proto+ H.section $ do+ H.h2 ! HA.id (H.stringValue $ protoName ++ "_states") $ "States"+ mconcat <$> mapM (renderState protoName msgs) (protocolStates proto)+ H.section $ do+ H.h2 ! HA.id (H.stringValue $ protoName ++ "_messages") $ "Messages"+ mconcat <$> mapM (renderMessage protoName) msgs++fieldSpecToHTML :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))+ => FieldInfo codec -> Html+fieldSpecToHTML fi = do+ forM_ (fieldSpecAnnotations fi) (H.p . H.string)+ fromMaybe "" $ subfieldsToHTML (compoundField "" [("", fi)])++fieldSpecAnnotations :: FieldInfo codec -> [String]+fieldSpecAnnotations (AnnField ann fi) =+ ann : fieldSpecAnnotations fi+fieldSpecAnnotations _ = []++subfieldsToHTML :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))+ => FieldInfo codec -> Maybe Html+subfieldsToHTML (AnnField _ fi) =+ subfieldsToHTML fi+subfieldsToHTML (AliasField afi) =+ subfieldsToHTML (aliasFieldTarget afi)+subfieldsToHTML (CompoundField cfi) = Just $ do+ H.table $ do+ mapM_ subfieldToHtmlTR (compoundFieldSubfields cfi)+subfieldsToHTML _ = Nothing++fieldTypeToHtml :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))+ => FieldInfo codec -> Html+fieldTypeToHtml (AnnField _ fi) =+ fieldTypeToHtml fi+fieldTypeToHtml (AliasField fi) = do+ H.strong $ H.string (aliasFieldName fi)+ H.br+ H.em "This type is an alias for: "+ fieldTypeToHtml (aliasFieldTarget fi)+fieldTypeToHtml (ListField fi) = do+ H.strong $ do+ "["+ H.string (shortFieldType (listElemInfo fi))+ "]"+ H.br+ H.em $ "#items: "+ H.string $ formatFieldSize $ listSize fi+ H.br+ H.em $ "item type: "+ fieldTypeToHtml (listElemInfo fi)+ maybe "" (H.br <>) $+ subfieldsToHTML (listElemInfo fi)+fieldTypeToHtml (ChoiceField fi) = do+ H.em "Choice"+ let choiceLabel = case choiceCondition fi of+ IndexField ref -> H.string ref+ IndexFlag ref mask -> H.string ref <> " & " <> H.string (printf "0x%04x" mask)+ H.table $ do+ H.tr $ do+ H.th choiceLabel+ H.th "size"+ H.th "type"+ sequence_ $+ [ H.tr $ do+ H.td ! HA.class_ "choice-value" $ H.string (show n)+ H.td ! HA.class_ "field-size" $ do+ H.string $ formatFieldSize (fieldSize optInfo)+ H.td $ do+ fieldTypeToHtml optInfo+ fromMaybe "" $ subfieldsToHTML optInfo+ | (n :: Int, optInfo) <- zip [0,1..] (choiceFieldAlternatives fi)+ ]+fieldTypeToHtml (EnumField fi) = do+ H.strong $ H.string (enumFieldType fi)+ H.em " (enum)"+ H.table $ do+ H.tr $ do+ H.th "value"+ H.th "name"+ sequence_ $+ [ H.tr $ do+ H.td ! HA.class_ "enum-value" $ H.string (show val)+ H.td $ H.string name+ | (val, name) <- enumFieldValues fi+ ]+fieldTypeToHtml (SumField fi) = do+ H.strong $ H.string (sumFieldType fi)+ H.em " (union)"+ case sumFieldAlternatives fi of+ [(_name, sfi)] ->+ H.div $ fieldTypeToHtml sfi+ sfis ->+ H.table $ do+ H.tr $ do+ H.th "name"+ H.th "value"+ sequence_ $+ [ H.tr $ do+ H.td $ H.string name+ H.td ! HA.class_ "sum-value" $ fieldTypeToHtml sfi+ | (name, sfi) <- sfis+ ]+fieldTypeToHtml fi =+ H.strong . H.string . fieldType $ fi++subfieldToHtmlTR :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))+ => SubfieldInfo codec -> Html+subfieldToHtmlTR sfi =+ case subfieldsToHTML (subfieldInfo sfi) of+ Nothing -> do+ H.tr $ do+ H.th ! HA.colspan "2" $ H.string (subfieldName sfi)+ H.tr $ do+ H.td ! HA.class_ "field-size" $ H.string $ formatFieldSize (fieldSize (subfieldInfo sfi))+ H.td $ fieldTypeToHtml (subfieldInfo sfi)+ Just sfiHtml -> do+ H.tr $ do+ H.th ! HA.colspan "2" $ H.string (subfieldName sfi)+ H.tr $ do+ H.td ! HA.rowspan "2" ! HA.class_ "field-size" $ do+ H.string $ formatFieldSize (fieldSize (subfieldInfo sfi))+ H.td ! HA.colspan "2" $ fieldTypeToHtml (subfieldInfo sfi)+ H.tr $ do+ H.td ! HA.colspan "2" $ sfiHtml++wrapDocument :: Html -> Html+wrapDocument body = do+ H.docType+ H.html $ do+ H.head $ do+ H.style $ do+ "html { font-family: sans-serif; }"+ "body { max-width: 60rem; margin-left: auto; margin-right: auto; padding: 1rem; }"+ "h1 { font-size: 3rem; }"+ "h2 { font-size: 2rem; }"+ "h3 { font-size: 1.5rem; }"+ "h4 { font-size: 1.25rem; }"+ "h5 { font-size: 1.1rem; }"+ "h6 { font-size: 1rem; }"+ "div.state, div.message {"+ " background-color: #EEE;"+ " padding: 0.125rem 1rem; "+ " margin: 1rem 0 1rem 0;"+ "}"+ "table { "+ "border-collapse: collapse;"+ "margin-top: 0.25rem;"+ "margin-bottom: 0.25rem;"+ "}"+ "table td, table th {"+ " border: solid 1px black;"+ " text-align: left;"+ " vertical-align: top;"+ " padding: 0.25rem;"+ " background-color: white; "+ "}"+ "table th {"+ " background-color: #DDD"+ "}"+ ".choice-value,"+ ".enum-value,"+ ".field-size {"+ " text-align: right;"+ " width: 4rem;"+ "}"+ ".toc>.toc {"+ " padding-left: 2rem;"+ "}"+ ".state-diagram {"+ " padding: 2rem;"+ " width: 60%;"+ "}"+ ".client-agency {"+ " color: brown;"+ "}"+ ".server-agency {"+ " color: blue;"+ "}"+ H.body body++renderProtocolDescriptions :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))+ => [ProtocolDescription codec] -> Html+renderProtocolDescriptions protos =+ mconcat $+ tocHtml : protoHtmls+ where+ tocHtml = H.div ! HA.class_ "toc-master" $ do+ H.h1 "Table Of Contents"+ renderTOC $+ TOC ("Protocols", "") $+ map protocolTOC protos+ protoHtmls = map renderProtocol protos
+ src/Network/TypedProtocol/Documentation/TH.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++module Network.TypedProtocol.Documentation.TH+( describeProtocol+)+where++import Network.TypedProtocol.Documentation.Types++import Control.Monad+#if MIN_VERSION_template_haskell(2,17,0)+-- This import is only needed when 'getDoc' is available.+import Data.Maybe (maybeToList)+#endif+import Data.Maybe (mapMaybe)+import Data.Proxy+import Language.Haskell.TH+import Language.Haskell.TH.Datatype+import Network.TypedProtocol.Core+++applyTyArgs :: Type -> [Name] -> Type+applyTyArgs t [] = t+applyTyArgs t (x:xs) =+ applyTyArgs (AppT t (ConT x)) xs++-- | Generate a 'ProtocolDescription' runtime representation of a typed+-- protocol specification, including serialization information.+describeProtocol :: Name -> [Name] -> Name -> [Name] -> ExpQ+describeProtocol protoTyCon protoTyArgs codecTyCon codecTyArgs = do+ info <- reifyDatatype protoTyCon+ protoDescription <- getDescription protoTyCon+ let pname = nameBase (datatypeName info)++ let extractAgency :: InstanceDec -> Maybe Name+ extractAgency (TySynInstD (TySynEqn _ _ (PromotedT agency))) = Just agency+ extractAgency dec = error $ "Unexpected InstanceDec: " ++ show dec++ let extractAgencies :: [InstanceDec] -> [Name]+ extractAgencies = mapMaybe extractAgency++ let extractTheAgency :: [InstanceDec] -> Name+ extractTheAgency inst = case extractAgencies inst of+ [agency] -> agency+ xs -> error $ "Incorrect number of agencies: " ++ show xs++ pstates <- forM (datatypeCons info) $ \conInfo -> do+ let conName = constructorName conInfo+ stateDescription <- getDescription conName++ stateAgencies <- reifyInstances ''StateAgency [ConT conName]+ let agencyName = extractTheAgency stateAgencies+ agencyID = case nameBase agencyName of+ "ServerAgency" -> 'ServerAgencyID+ "ClientAgency" -> 'ClientAgencyID+ "NobodyAgency" -> 'NobodyAgencyID+ x -> error $ "Unknown agency type " ++ x ++ " in state " ++ nameBase conName++ return (conName, stateDescription, agencyID)++ let protocolTy = applyTyArgs (ConT protoTyCon) protoTyArgs++ [DataInstD _ _ _ _ cons _] <- reifyInstances ''Message [protocolTy]++ let messageInfos = map (describeProtocolMessage protoTyCon protoTyArgs codecTyCon codecTyArgs . extractConName) cons++ [| ProtocolDescription+ $(litE (stringL pname))+ protoDescription+ ""+ $(listE+ [ [| ( $(makeState $ ConT conName), stateDescription, $(conE agencyID)) |]+ | (conName, stateDescription, agencyID) <- pstates+ ]+ )+ $(listE messageInfos)+ |]++unearthType :: Type -> Type+#if MIN_VERSION_template_haskell(2,17,0)+unearthType (AppT (AppT MulArrowT _) t) = unearthType t+#endif+unearthType (SigT a _) = unearthType a+unearthType t = t+++prettyTy :: Type -> String+prettyTy = snd . go+ where+ go (ConT n) = (False, nameBase n)+ go (PromotedT n) = (False, nameBase n)+ go (VarT n) = (False, nameBase n)+ go (AppT a b) =+ let+ (_, a') = go a+ (wrap, b') = go b+ in+ (True, a' ++ " " ++ if wrap then "(" ++ b' ++ ")" else b')+ go (ForallT _ _ a) = go a+ go (ForallVisT _ a) = go a+ go (AppKindT _ a) = go a+ go t = (True, show t)++getDescription :: Name -> Q [Description]+getDescription name = do+#if MIN_VERSION_template_haskell(2,17,0)+ haddock <- maybeToList <$> getDoc (DeclDoc name)+#else+ -- 'getDoc' does not exist before template-haskell-2.17.0+ let haddock = []+#endif+ annotations <- reifyAnnotations (AnnLookupName name)+ return $ (Description . (:[]) <$> haddock) ++ annotations++unSigTy :: Type -> Type+unSigTy (SigT t _) = t+unSigTy t@(VarT {}) = t+unSigTy t@(PromotedT {}) = t+unSigTy t = error $ show t++makeState :: Type -> ExpQ+makeState (ConT name) = conE 'State `appE` (litE . stringL $ nameBase name)+makeState (PromotedT name) = conE 'State `appE` (litE . stringL $ nameBase name)+makeState (VarT _) = conE 'AnyState+makeState ty = error . show $ ty -- conE 'AnyState++describeProtocolMessage :: Name -> [Name] -> Name -> [Name] -> Name -> ExpQ+describeProtocolMessage protoTyCon protoTyArgs codecTyCon codecTyArgs msgName = do+ msgInfo <- reifyConstructor msgName+ msgTyInfo <- reifyDatatype msgName+ msgDescription <- getDescription msgName+++ let payloads = constructorFields msgInfo+#if MIN_VERSION_template_haskell(2,17,0)+ tyVarName :: TyVarBndr a -> Name+ tyVarName (PlainTV n _) = n+ tyVarName (KindedTV n _ _) = n+#else+ tyVarName :: TyVarBndr -> Name+ tyVarName (PlainTV n) = n+ tyVarName (KindedTV n _) = n+#endif++ findType :: Name -> Cxt -> Type+ findType n (AppT (AppT EqualityT (VarT vn)) t : _)+ | vn == n+ = t+ findType n (_ : xs) = findType n xs+ findType n [] = VarT n++ fromStateVar = tyVarName . last . init $ datatypeVars msgTyInfo+ toStateVar = tyVarName . last $ datatypeVars msgTyInfo+ fromState = findType fromStateVar (constructorContext msgInfo)+ toState = findType toStateVar (constructorContext msgInfo)++ [e| MessageDescription+ { messageName = $(litE . stringL . nameBase $ msgName)+ , messageDescription = msgDescription+ , messagePayload = $(listE (map (litE . stringL . prettyTy) payloads))+ , messageFromState = $(makeState . unearthType $ fromState)+ , messageToState = $(makeState . unearthType $ toState)+ , messageInfo =+ infoOf $(litE . stringL . nameBase $ msgName) $+ info + (Proxy :: Proxy $(pure $ applyTyArgs (ConT codecTyCon) codecTyArgs))+ (Proxy :: Proxy ( $(conT $ datatypeName msgTyInfo)+ $(pure $ applyTyArgs (ConT protoTyCon) protoTyArgs)+ $(pure $ unSigTy fromState)+ $(pure $ unSigTy toState)+ )+ )+ }+ |]++extractConName :: Con -> Name+extractConName con = case con of+ NormalC n _ -> n+ RecC n _ -> n+ InfixC _ n _ -> n+ ForallC _ _ c -> extractConName c+ GadtC (name:_) _ _ -> name+ RecGadtC (name:_) _ _ -> name+ x -> error $ "Cannot extract constructor name from " ++ show x
+ src/Network/TypedProtocol/Documentation/Text.hs view
@@ -0,0 +1,391 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.TypedProtocol.Documentation.Text+where++import Control.Monad+import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy.Builder as LText+import Data.Word+import qualified Documentation.Haddock.Parser as Haddock+import qualified Documentation.Haddock.Types as Haddock+import Text.Printf+import Control.Monad.RWS+import Data.List (intersperse)++import Network.TypedProtocol.Documentation.Types++import Data.SerDoc.Class+import Data.SerDoc.Info++type Build = RWS Int LText.Builder Bool ()++runBuild :: Build -> LText.Text+runBuild a = LText.toLazyText b+ where+ ((), _, b) = runRWS a 0 False++indent :: Build+indent = do+ atStart <- get+ when atStart $ do+ put False+ lvl <- ask+ replicateM_ lvl (tell " ")++assertLineStart :: Build+assertLineStart = do+ atStart <- get+ unless atStart newline++withIndent :: Int -> Build -> Build+withIndent i = local (+ i)++write :: LText.Builder -> Build+write b = indent >> tell b++string :: String -> Build+string = write . LText.fromString++newline :: Build+newline = do+ string "\n"+ put True++buildBare :: Build -> LText.Text+buildBare =+ LText.unwords . LText.words . runBuild++p :: Build -> Build+p b = b >> newline++stringLine :: String -> Build+stringLine = p . string++h :: Int -> String -> Build+h 1 s = do+ assertLineStart+ string s+ newline+ stringLine $ replicate (length s) '='+h 2 s = do+ assertLineStart+ string s+ newline+ stringLine $ replicate (length s) '-'+ newline+h n s = do+ assertLineStart+ replicateM_ n $ string "#"+ string " "+ string s+ newline++ul :: [Build] -> Build+ul items = do+ forM_ items $ \item -> do+ assertLineStart+ string "- "+ withIndent 2 item+ assertLineStart++ol :: [(Int, Build)] -> Build+ol items = do+ mapM_ (uncurry renderItem) items+ assertLineStart+ where+ renderItem :: Int -> Build -> Build+ renderItem n item = do+ assertLineStart+ string . show $ n+ string ". "+ withIndent 2 item++link :: String -> Build -> Build+link url label = do+ string "["+ label+ string "]("+ string url+ string ")"++renderDescriptions :: [Description] -> Build+renderDescriptions = mapM_ $ \(Description desc) -> do+ let (docs :: [Haddock.DocH () String]) =+ map (Haddock.toRegular . Haddock._doc . Haddock.parseParas Nothing) desc+ mapM_ (p . renderHaddock) docs++renderHaddock :: Haddock.DocH mod String -> Build+renderHaddock Haddock.DocEmpty = return ()+renderHaddock (Haddock.DocAppend a b) = renderHaddock a >> renderHaddock b+renderHaddock (Haddock.DocString str) = string str+renderHaddock (Haddock.DocParagraph a) = p (renderHaddock a)+renderHaddock (Haddock.DocIdentifier i) = string i+renderHaddock (Haddock.DocIdentifierUnchecked _) = string "**unchecked**"+renderHaddock (Haddock.DocModule (Haddock.ModLink label _)) = string label+renderHaddock (Haddock.DocWarning a) = p $ renderHaddock a+renderHaddock (Haddock.DocEmphasis a) = renderHaddock a+renderHaddock (Haddock.DocMonospaced a) = renderHaddock a+renderHaddock (Haddock.DocBold a) = renderHaddock a+renderHaddock (Haddock.DocUnorderedList items) = ul $ map renderHaddock items+renderHaddock (Haddock.DocOrderedList items) = ol $ map (\(n, item) -> (n, renderHaddock item)) items+renderHaddock (Haddock.DocDefList items) =+ ul+ [ renderHaddock title >> string ": " >> renderHaddock body+ | (title, body) <- items+ ]+renderHaddock (Haddock.DocCodeBlock a) = renderHaddock a+renderHaddock (Haddock.DocHyperlink (Haddock.Hyperlink url a)) =+ link url (maybe (string "") renderHaddock a)+renderHaddock (Haddock.DocPic (Haddock.Picture url title)) = do+ string "<image:"+ maybe (string url) string title+ string ">"+renderHaddock (Haddock.DocMathInline str) = string str+renderHaddock (Haddock.DocMathDisplay str) = p $ string str+renderHaddock (Haddock.DocAName str) = string str+renderHaddock (Haddock.DocProperty str) = string str+renderHaddock (Haddock.DocExamples examples) =+ forM_ examples $ \(Haddock.Example expr results) -> do+ p $ do+ string "$> "+ stringLine expr+ mapM_ stringLine results+renderHaddock (Haddock.DocHeader (Haddock.Header level a)) = do+ let renderH = case level of+ 1 -> h 1+ 2 -> h 2+ n -> h n+ renderH . LText.unpack . buildBare $ renderHaddock a+renderHaddock (Haddock.DocTable (Haddock.Table headerRows bodyRows)) = do+ mapM_ row headerRows+ stringLine "-----"+ mapM_ row bodyRows+ where+ row (Haddock.TableRow cells) = do+ assertLineStart+ sequence_ . intersperse (string " | ") . map renderCell $ cells+ assertLineStart+ renderCell (Haddock.TableCell _ _ content) =+ renderHaddock content++data TOC a = TOC a [TOC a]+ deriving (Show, Eq, Ord)++renderTOC :: TOC (String, String) -> Build+renderTOC (TOC (label, _href) children) = do+ stringLine label+ withIndent 2 $ forM_ children renderTOC++stateID :: String -> String -> String+stateID protoName stateName = protoName ++ "_state_" ++ stateName++stateTOC :: String -> String -> TOC (String, String)+stateTOC protoName stateName = TOC (stateName, stateID protoName stateName) []++renderMessageRef :: String -> MessageDescription codec -> Build+renderMessageRef toFrom msg = do+ string (messageName msg)+ string " ("+ string toFrom+ string " "+ formatStateRef (messageToState msg)+ string ")"++renderState :: [MessageDescription codec] -> (StateRef, [Description], AgencyID) -> Build+renderState _ (AnyState, _, _) =+ return ()+renderState msgs (State stateName, descriptions, agency) =+ p $ do+ h 3 stateName+ newline+ renderDescriptions descriptions+ p $ do+ string "Agency: "+ case agency of+ ClientAgencyID -> string "client"+ ServerAgencyID -> string "server"+ NobodyAgencyID -> string "nobody"+ unless (null messagesFromHere) $ do+ h 4 "Messages from here:"+ ul $ map (renderMessageRef "to") messagesFromHere+ unless (null messagesToHere) $ do+ h 4 "Messages to here:"+ ul $ map (renderMessageRef "from") messagesToHere+ where+ messagesFromHere = filter (matchState stateName . messageFromState) msgs+ messagesToHere = filter (matchState stateName . messageToState) msgs++ matchState :: String -> StateRef -> Bool+ matchState _ AnyState = True+ matchState a (State b) = a == b++formatStateRef :: StateRef -> Build+formatStateRef AnyState =+ string "any state"+formatStateRef (State name) =+ string name++messageID :: String -> String -> String+messageID protoName msgName = protoName ++ "_message_" ++ msgName++messageTOC :: String -> MessageDescription codec -> TOC (String, String)+messageTOC protoName msg =+ TOC (messageName msg, messageID protoName (messageName msg)) []++formatFieldSize :: FieldSize -> String+formatFieldSize (FixedSize n) = show n+formatFieldSize (VarSize var) = var+formatFieldSize UnknownSize = "VARIABLE"+formatFieldSize EnumSize = "ENUM"+formatFieldSize (RangeSize lo hi) = "(" ++ formatFieldSize lo ++ " .. " ++ formatFieldSize hi ++ ")"+formatFieldSize (BinopSize FSPlus a b) = "(" ++ formatFieldSize a ++ " + " ++ formatFieldSize b ++ ")"+formatFieldSize (BinopSize FSMul a b) = "(" ++ formatFieldSize a ++ " * " ++ formatFieldSize b ++ ")"+formatFieldSize (BinopSize FSMax a b) = "MAX(" ++ formatFieldSize a ++ ", " ++ formatFieldSize b ++ ")"+formatFieldSize (BinopSize FSMin a b) = "MIN(" ++ formatFieldSize a ++ ", " ++ formatFieldSize b ++ ")"++renderMessage :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))+ => MessageDescription codec -> Build+renderMessage msg =+ p $ do+ h 3 $ messageName msg+ newline+ renderDescriptions (messageDescription msg)+ h 4 "State Transition"+ p $ do+ formatStateRef (messageFromState msg)+ string " -> "+ formatStateRef (messageToState msg)+ unless (null $ messagePayload msg) $ do+ h 4 "Payload"+ ul $ map string (messagePayload msg)+ h 4 "Serialization Format"+ renderFieldSpec (messageInfo msg)+ newline+ +protocolTOC :: ProtocolDescription codec -> TOC (String, String)+protocolTOC proto =+ let protoName = protocolName proto+ in+ TOC (protoName, protoName)+ [ TOC ("States", protoName ++ "_states")+ [ stateTOC protoName stateName | (State stateName, _, _) <- protocolStates proto ]+ , TOC ("Messages", protoName ++ "_messages")+ [ messageTOC protoName msg | msg <- protocolMessages proto ]+ ]++renderProtocol :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))+ => ProtocolDescription codec -> Build+renderProtocol proto = do+ let protoName = protocolName proto+ msgs = protocolMessages proto+ p $ do+ h 1 protoName+ string (protocolIdentifier proto)+ assertLineStart+ renderDescriptions (protocolDescription proto)+ p $ do+ h 2 "States"+ mconcat <$> mapM (renderState msgs) (protocolStates proto)+ p $ do+ h 2 "Messages"+ mconcat <$> mapM renderMessage msgs++renderFieldSpec :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))+ => FieldInfo codec -> Build+renderFieldSpec fi = do+ forM_ (fieldSpecAnnotations fi) (p . string)+ renderSubfields (compoundField "" [("", fi)])++fieldSpecAnnotations :: FieldInfo codec -> [String]+fieldSpecAnnotations (AnnField ann fi) =+ ann : fieldSpecAnnotations fi+fieldSpecAnnotations _ = []++renderSubfields :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))+ => FieldInfo codec -> Build+renderSubfields (AnnField _ fi) =+ renderSubfields fi+renderSubfields (AliasField afi) =+ renderSubfields (aliasFieldTarget afi)+renderSubfields (CompoundField cfi) = do+ ul $ map renderSubfield (compoundFieldSubfields cfi)+renderSubfields _ = return ()++renderFieldType :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))+ => FieldInfo codec -> Build+renderFieldType (AnnField _ fi) =+ renderFieldType fi+renderFieldType (AliasField fi) = do+ string (aliasFieldName fi)+ assertLineStart++ string "This type is an alias for: "+ renderFieldType (aliasFieldTarget fi)+renderFieldType (ListField fi) = do+ string "["+ string (shortFieldType (listElemInfo fi))+ string "] "+ assertLineStart++ string "items: "+ string $ formatFieldSize $ listSize fi+ assertLineStart++ string "item type: "+ renderFieldType (listElemInfo fi)+ renderSubfields (listElemInfo fi)+renderFieldType (ChoiceField fi) = do+ string "Choice ("+ case choiceCondition fi of+ IndexField ref -> string ref+ IndexFlag ref mask -> string ref >> string " & " >> string (printf "0x%04x" mask)+ string ")"+ assertLineStart+ ul [ string (show n) >>+ string ": " >> renderSubfields optInfo >>+ assertLineStart >>+ string "size: " >> string (formatFieldSize (fieldSize optInfo)) >>+ assertLineStart+ | (n :: Int, optInfo) <- zip [0,1..] (choiceFieldAlternatives fi)+ ]+renderFieldType (EnumField fi) = do+ string (enumFieldType fi)+ string " (enum)"+ assertLineStart+ ul [ string (show val) >> string " = " >> string name+ | (val, name) <- enumFieldValues fi+ ]+renderFieldType (SumField fi) = do+ string (sumFieldType fi)+ string " (union)"+ assertLineStart+ case sumFieldAlternatives fi of+ [(_name, sfi)] ->+ p $ renderFieldType sfi+ sfis ->+ ul [ string name >> string ": " >> renderFieldType sfi+ | (name, sfi) <- sfis+ ]+renderFieldType fi =+ string . fieldType $ fi++renderSubfield :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))+ => SubfieldInfo codec -> Build+renderSubfield sfi = do+ string (subfieldName sfi)+ assertLineStart+ renderFieldType (subfieldInfo sfi)+ assertLineStart+ string "size: "+ string (formatFieldSize (fieldSize (subfieldInfo sfi)))+ string " "+ renderSubfields (subfieldInfo sfi)++renderProtocolDescriptions :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))+ => [ProtocolDescription codec] -> LText.Text+renderProtocolDescriptions protos = runBuild $ do+ h 1 "Table Of Contents"+ p $ renderTOC (TOC ("Protocols","") (map protocolTOC protos))+ mapM_ renderProtocol protos
+ src/Network/TypedProtocol/Documentation/Types.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.TypedProtocol.Documentation.Types+( AgencyID (..)+, StateRef (..)+, ProtocolDescription (..)+, MessageDescription (..)+, Description (..)+)+where++import Data.SerDoc.Info+import Language.Haskell.TH.Syntax+import Data.Aeson++-- | Represents agency at the term level. Used to indicate which side has+-- agency in a particular protocol state.+data AgencyID+ = ClientAgencyID+ | ServerAgencyID+ | NobodyAgencyID+ deriving (Show, Read, Ord, Eq, Enum, Bounded, Lift)++instance ToJSON AgencyID where+ toJSON ClientAgencyID = "client"+ toJSON ServerAgencyID = "server"+ toJSON NobodyAgencyID = "nobody"++data StateRef+ = AnyState+ | State !String+ deriving (Show, Read, Ord, Eq)++instance ToJSON StateRef where+ toJSON AnyState = Null+ toJSON (State str) = toJSON str++-- | Term-level representation of a typed protocol.+data ProtocolDescription codec =+ ProtocolDescription+ { protocolName :: String+ -- ^ Human-readable protocol name+ , protocolDescription :: [Description]+ , protocolIdentifier :: String+ -- ^ Machine-readable identifier, may be used for things like protocol+ -- version negotiation.+ , protocolStates :: [(StateRef, [Description], AgencyID)]+ -- ^ List of the protocol's possible states, each entry being a state ID,+ -- a human-readable description, and an indication of agency (client or+ -- server).+ , protocolMessages :: [MessageDescription codec]+ }+ deriving (Show)++instance ToJSON (ProtocolDescription codec) where+ toJSON p = object+ [ "name" .= protocolName p+ , "description" .= map descriptionParagraphs (protocolDescription p)+ , "identifier" .= protocolIdentifier p+ , "states" .=+ [ object+ [ "id" .= stateRef+ , "description" .= map descriptionParagraphs desc+ , "agency" .= agency+ ]+ | (stateRef, desc, agency) <- protocolStates p+ ]+ , "messages" .= protocolMessages p+ ]++-- | Term-level representation of a typed protocol message.+data MessageDescription codec =+ MessageDescription+ { messageName :: String+ , messageDescription :: [Description]+ , messagePayload :: [String]+ -- ^ List of payload values for this message (free-form descriptions or+ -- type names)+ , messageFromState :: StateRef+ -- ^ References a 'protocolState' in the parent 'ProtocolDescription' by+ -- name.+ , messageToState :: StateRef+ -- ^ References a 'protocolState' in the parent 'ProtocolDescription' by+ -- name.+ , messageInfo :: FieldInfo codec+ }+ deriving (Show)++instance ToJSON (MessageDescription codec) where+ toJSON m = object+ [ "name" .= messageName m+ , "description" .= map descriptionParagraphs (messageDescription m)+ , "payload" .= messagePayload m+ , "from-state" .= messageFromState m+ , "to-state" .= messageToState m+ ]
+ test/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import qualified Network.TypedProtocol.Tests.Documentation as Documentation++import Test.Tasty++main :: IO ()+main = defaultMain Documentation.tests
+ test/Network/TypedProtocol/Tests/ControlProtocol.hs view
@@ -0,0 +1,312 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Network.TypedProtocol.Tests.ControlProtocol where++import Network.TypedProtocol.Documentation+import Network.TypedProtocol.Tests.TestProtocol (TestCodec)++import Data.ByteString ( ByteString )+import Data.Kind+import Data.SerDoc.Class+import Data.SerDoc.Info+import Data.SerDoc.TH+import Data.Text ( Text )+import Data.Typeable+import Data.Word+import Network.TypedProtocol.Core++data AgentInfo =+ AgentInfo+ { agentInfoCurrentBundle :: !(Maybe BundleInfo)+ , agentInfoStagedKey :: !(Maybe KeyInfo)+ , agentInfoBootstrapConnections :: ![BootstrapInfo]+ }+ deriving (Show, Eq)++data Command+ = GenStagedKeyCmd+ | QueryStagedKeyCmd+ | DropStagedKeyCmd+ | InstallKeyCmd+ | RequestInfoCmd+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++deriving via (ViaEnum Command)+ instance+ ( Codec codec+ , HasInfo codec (DefEnumEncoding codec)+ ) => HasInfo codec Command++instance+ ( Codec codec+ , Serializable codec (DefEnumEncoding codec)+ , Integral (DefEnumEncoding codec)+ , Monad (MonadEncode codec)+ , Monad (MonadDecode codec)+ ) => Serializable codec Command where+ encode codec = encodeEnum codec (Proxy @(DefEnumEncoding codec))+ decode codec = decodeEnum codec (Proxy @(DefEnumEncoding codec))++newtype FakeKey = FakeKey { fakeKeyData :: ByteString }+ deriving (Show, Eq, Ord)++newtype VersionIdentifier = VersionIdentifier { versionIdentifierData :: ByteString }+ deriving (Show, Eq, Ord)++instance HasInfo TestCodec VersionIdentifier where+ info _ _ = basicField "Bytes" (FixedSize 32)++instance HasInfo TestCodec FakeKey where+ info _ _ = basicField "Bytes" (FixedSize 128)++data BootstrapInfo =+ BootstrapInfo+ { bootstrapInfoAddress :: !Text+ , bootstrapInfoStatus :: !ConnectionStatus+ }+ deriving (Show, Eq)++data ConnectionStatus+ = ConnectionUp+ | ConnectionConnecting+ | ConnectionDown+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++deriving via (ViaEnum ConnectionStatus)+ instance (Codec codec, HasInfo codec (DefEnumEncoding codec))+ => HasInfo codec ConnectionStatus++data BundleInfo =+ BundleInfo+ { bundleInfoEvolution :: !Word32+ , bundleInfoOCertN :: !Word64+ , bundleInfoVK :: !FakeKey+ }+ deriving (Show, Eq)++newtype KeyInfo =+ KeyInfo+ { keyInfoVK :: FakeKey+ }+ deriving (Show, Eq)++deriving newtype+ instance+ ( HasInfo codec FakeKey+ , Codec codec+ ) => HasInfo codec KeyInfo++$(deriveSerDoc ''TestCodec [] ''BundleInfo)+$(deriveSerDoc ''TestCodec [] ''BootstrapInfo)+$(deriveSerDoc ''TestCodec [] ''AgentInfo)++-- | The protocol for pushing KES keys.+--+-- Intended use:+--+-- - The Agent acts as the Client, and the Control Server as a Server+-- - When the Control Server connects, it pushes a key to the Agent+-- - The Agent stores the key locally in memory and pushes it to any connected+-- Nodes.+--+-- All pushes are confirmed from the receiving end, to make sure they have gone+-- through. This allows the control client to report success to the user, but it+-- also helps make things more predictable in testing, because it means that+-- sending keys is now synchronous.+data ControlProtocol (m :: Type -> Type) (c :: Type) where+ -- | Default state after connecting, but before the protocol version has been+ -- negotiated.+ InitialState :: ControlProtocol m c++ -- | System is idling, waiting for the server to push the next key.+ IdleState :: ControlProtocol m c++ -- | Client has requested a new KES key to be generated in the staging area.+ WaitForPublicKeyState :: ControlProtocol m c++ -- | Client has requested agent information+ WaitForInfoState :: ControlProtocol m c++ -- | An OpCert has been pushed, client must now confirm that it has been+ -- received, and that it matches the staged KES key.+ WaitForConfirmationState :: ControlProtocol m c++ -- | The server has closed the connection, thus signalling the end of the+ -- session.+ EndState :: ControlProtocol m c++{-# ANN VersionMessage (Description ["Announce the protocol version."]) #-}+{-# ANN GenStagedKeyMessage+ (Description+ [ "Ask the agent to generate a fresh KES sign key and store it in the staging area."+ , "Corresponds to the @gen-staged-key@ command."+ ]) #-}+{-# ANN QueryStagedKeyMessage+ (Description+ [ "Ask the agent to return the staged KES key, if any."+ , "Only the KES verification key will be returned, in order to guarantee forward security."+ , "Corresponds to the @export-staged-key@ command."+ ]) #-}+{-# ANN DropStagedKeyMessage+ (Description+ [ "Ask the agent to delete the staged KES key, if any."+ , "Corresponds to the @drop-staged-key@ command."+ ]) #-}+{-# ANN PublicKeyMessage+ (Description+ [ "Returned by the KES agent in response to an @export-staged-key@ request."+ ]) #-}+{-# ANN InstallKeyMessage+ (Description+ [ "Upload an OpCert to the KES agent, and ask it to bundle it with a staged KES key and install it."+ , "Corresponds to the @install-key@ command."+ ]) #-}+{-# ANN InstallResultMessage+ (Description+ [ "Returned by the KES agent in response to an @install-key@ command."+ ]) #-}+{-# ANN RequestInfoMessage+ (Description+ [ "Ask the KES agent to report its current state."+ , "Corresponds to the @info@ command."+ ]) #-}+{-# ANN InfoMessage+ (Description+ [ "Returned by the KES agent in response to an @info@ command."+ ]) #-}+{-# ANN AbortMessage+ (Description+ [ "Signals a failed version handshake."+ , "No data is actually sent for this message, instead it is generated when the network connection is interrupted."+ ]) #-}+{-# ANN EndMessage+ (Description+ [ "Signals an orderly end of a session."+ , "No data is actually sent for this message, instead it is generated when the network connection is interrupted."+ ]) #-}+{-# ANN ProtocolErrorMessage+ (Description+ [ "Signals a fatal protocol error that causes the session to end prematurely."+ , "No data is actually sent for this message, instead it is generated when the network connection is interrupted, or an unrecoverable error occurs."+ ]) #-}++instance Protocol (ControlProtocol m c) where+ data Message (ControlProtocol m c) st st' where++ VersionMessage :: Message (ControlProtocol m c) InitialState IdleState++ GenStagedKeyMessage :: Message (ControlProtocol m c) IdleState WaitForPublicKeyState++ QueryStagedKeyMessage :: Message (ControlProtocol m c) IdleState WaitForPublicKeyState++ DropStagedKeyMessage :: Message (ControlProtocol m c) IdleState WaitForPublicKeyState++ PublicKeyMessage :: Maybe FakeKey+ -> Message (ControlProtocol m c) WaitForPublicKeyState IdleState++ InstallKeyMessage :: FakeKey+ -> Message (ControlProtocol m c) IdleState WaitForConfirmationState++ InstallResultMessage :: Word32+ -> Message (ControlProtocol m c) WaitForConfirmationState IdleState++ RequestInfoMessage :: Message (ControlProtocol m c) IdleState WaitForInfoState++ InfoMessage :: AgentInfo+ -> Message (ControlProtocol m c) WaitForInfoState IdleState++ AbortMessage :: Message (ControlProtocol m c) InitialState EndState+ EndMessage :: Message (ControlProtocol m c) IdleState EndState+ ProtocolErrorMessage :: Message (ControlProtocol m c) a EndState++ -- | Server always has agency, except between sending a key and confirming it+ type StateAgency InitialState = ServerAgency+ type StateAgency IdleState = ServerAgency+ type StateAgency WaitForConfirmationState = ClientAgency+ type StateAgency WaitForPublicKeyState = ClientAgency+ type StateAgency WaitForInfoState = ClientAgency+ type StateAgency EndState = NobodyAgency++ type StateToken = SControlProtocol++data SControlProtocol (st :: ControlProtocol m c) where+ SInitialState :: SControlProtocol InitialState+ SIdleState :: SControlProtocol IdleState+ SWaitForConfirmationState :: SControlProtocol WaitForConfirmationState+ SWaitForPublicKeyState :: SControlProtocol WaitForPublicKeyState+ SWaitForInfoState :: SControlProtocol WaitForInfoState+ SEndState :: SControlProtocol EndState++instance HasInfo TestCodec (Message (ControlProtocol m c) InitialState IdleState) where+ info codec _ = aliasField+ ("Message<" +++ "InitialState,IdleState" +++ ">")+ (info codec (Proxy @VersionIdentifier))+instance HasInfo TestCodec (Message (ControlProtocol m c) IdleState WaitForPublicKeyState) where+ info codec _ = aliasField+ ("Message<" +++ "IdleState,WaitForPublicKeyState" +++ ">")+ (info codec (Proxy @Command))++-- infoOf c = case c of+-- GenStagedKeyMessage -> infoOf GenStagedKeyCmd+-- QueryStagedKeyMessage -> infoOf QueryStagedKeyCmd+-- DropStagedKeyMessage -> infoOf DropStagedKeyCmd++instance (HasInfo TestCodec FakeKey) => HasInfo TestCodec (Message (ControlProtocol m c) WaitForPublicKeyState IdleState) where+ info codec _ = aliasField+ ("Message<" +++ "WaitForPublicKeyState,IdleState" +++ ">")+ (info codec (Proxy @(Maybe FakeKey)))+instance (HasInfo TestCodec FakeKey) => HasInfo TestCodec (Message (ControlProtocol m c) IdleState WaitForConfirmationState) where+ info codec _ = aliasField+ ("Message<" +++ "IdleState,WaitForConfirmationState" +++ ">")+ (info codec (Proxy @FakeKey))+instance HasInfo TestCodec (Message (ControlProtocol m c) WaitForConfirmationState IdleState) where+ info codec _ = aliasField+ ("Message<" +++ "WaitForConfirmationState,IdleState" +++ ">")+ (info codec (Proxy @Word32))+instance HasInfo TestCodec (Message (ControlProtocol m c) IdleState WaitForInfoState) where+ info codec _ = aliasField+ ("Message<" +++ "IdleState,WaitForInfoState" +++ ">")+ (info codec (Proxy @()))+instance ( HasInfo TestCodec FakeKey+ , HasInfo TestCodec AgentInfo+ ) => HasInfo TestCodec (Message (ControlProtocol m c) WaitForInfoState IdleState) where+ info codec _ = aliasField+ ("Message<" +++ "WaitForInfoState,IdleState" +++ ">")+ (info codec (Proxy @AgentInfo))+instance HasInfo TestCodec (Message (ControlProtocol m c) _st EndState) where+ info codec _ = aliasField+ ("Message<" +++ "st,EndState" +++ ">")+ (info codec (Proxy @()))
+ test/Network/TypedProtocol/Tests/Documentation.hs view
@@ -0,0 +1,88 @@+{-#LANGUAGE TemplateHaskell #-}+{-#LANGUAGE DataKinds #-}++module Network.TypedProtocol.Tests.Documentation+where++import Test.Tasty+import Test.Tasty.QuickCheck++import Data.SerDoc.Class+import Data.Maybe++import Network.TypedProtocol.Documentation+import Network.TypedProtocol.Tests.TestProtocol+import Network.TypedProtocol.Tests.ControlProtocol++{-# ANN module "HLINT: ignore Use camelCase" #-}+{-# ANN module "HLINT: ignore Move brackets to avoid $" #-}++tests :: TestTree+tests = testGroup "Documentation"+ [ testProperty "no errors" (testProtocolDescription `seq` True)+ , testProperty "agencies" (p_correctAgencies testProtocolDescription)+ , testProperty "state transitions" (p_correctStateTransitions testProtocolDescription)+ ]++testProtocolDescription :: ProtocolDescription TestCodec+testProtocolDescription = $(describeProtocol ''ControlProtocol [''IO, ''()] ''TestCodec [])++p_correctAgencies :: ProtocolDescription TestCodec -> Property+p_correctAgencies d =+ counterexample (show stateAgencyMap) .+ once $+ counterexample "EndState" (lookup (State "EndState") stateAgencyMap === Just NobodyAgencyID)+ .&&.+ counterexample "InitialState" (lookup (State "InitialState") stateAgencyMap === Just ServerAgencyID)+ .&&.+ counterexample "IdleState" (lookup (State "IdleState") stateAgencyMap === Just ServerAgencyID)+ .&&.+ counterexample "WaitForConfirmationState" (lookup (State "WaitForConfirmationState") stateAgencyMap === Just ClientAgencyID)+ .&&.+ counterexample "WaitForInfoState" (lookup (State "WaitForInfoState") stateAgencyMap === Just ClientAgencyID)+ .&&.+ counterexample "WaitForPublicKeyState" (lookup (State "WaitForPublicKeyState") stateAgencyMap === Just ClientAgencyID)+ where+ stateAgencyMap = [(state, agency) | (state, _, agency) <- protocolStates d]++p_correctStateTransitions :: ProtocolDescription TestCodec -> Property+p_correctStateTransitions d =+ once $+ checkMessage "VersionMessage" (State "InitialState") (State "IdleState")+ .&&.+ checkMessage "GenStagedKeyMessage" (State "IdleState") (State "WaitForPublicKeyState")+ .&&.+ checkMessage "QueryStagedKeyMessage" (State "IdleState") (State "WaitForPublicKeyState")+ .&&.+ checkMessage "DropStagedKeyMessage" (State "IdleState") (State "WaitForPublicKeyState")+ .&&.+ checkMessage "PublicKeyMessage" (State "WaitForPublicKeyState") (State "IdleState")+ .&&.+ checkMessage "InstallKeyMessage" (State "IdleState") (State "WaitForConfirmationState")+ .&&.+ checkMessage "InstallResultMessage" (State "WaitForConfirmationState") (State "IdleState")+ .&&.+ checkMessage "RequestInfoMessage" (State "IdleState") (State "WaitForInfoState")+ .&&.+ checkMessage "InfoMessage" (State "WaitForInfoState") (State "IdleState")+ .&&.+ checkMessage "AbortMessage" (State "InitialState") (State "EndState")+ .&&.+ checkMessage "EndMessage" (State "IdleState") (State "EndState")+ .&&.+ checkMessage "ProtocolErrorMessage" AnyState (State "EndState")+ where+ checkMessage :: String -> StateRef -> StateRef -> Property+ checkMessage msgName fromState toState =+ counterexample msgName $ do+ msg <- findMessage msgName+ return $+ counterexample "fromState"+ (messageFromState msg === fromState)+ .&&.+ counterexample "toState"+ (messageToState msg === toState)++ findMessage :: String -> Maybe (MessageDescription TestCodec)+ findMessage msgName =+ listToMaybe [ msg | msg <- protocolMessages d, messageName msg == msgName ]
+ test/Network/TypedProtocol/Tests/TestProtocol.hs view
@@ -0,0 +1,152 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Network.TypedProtocol.Tests.TestProtocol+where++import Network.TypedProtocol.Core+import Data.SerDoc.Info+import Control.Monad.Identity+import Control.Monad.Except+import Data.Proxy+import Data.Word+import Data.SerDoc.Class+import Data.SerDoc.TH+import Data.Text (Text)++data PongInfo =+ PongInfo+ { pongTimestamp :: Word64+ , pongPeerID :: Word64+ , pongMessage :: Text+ }+ deriving (Show, Eq)++data TestProtocol where+ -- | Idle state: server waits for ping.+ IdleState :: TestProtocol++ -- | Awaiting pong state: server has received ping, client waits for pong.+ AwaitingPongState :: TestProtocol++ -- | End state: either side has terminated the session+ EndState :: TestProtocol++instance Protocol TestProtocol where+ data Message TestProtocol st st' where+ PingMessage :: Message TestProtocol IdleState AwaitingPongState+ PongMessage :: Message TestProtocol AwaitingPongState IdleState+ ComplexPongMessage :: Message TestProtocol AwaitingPongState IdleState+ EndMessage :: Message TestProtocol st EndState++ type StateAgency IdleState = ServerAgency+ type StateAgency AwaitingPongState = ClientAgency+ type StateAgency EndState = NobodyAgency++ type StateToken = STestProtocol++data STestProtocol (st :: TestProtocol) where+ SingIdle :: STestProtocol IdleState+ SingAwaitingPong :: STestProtocol AwaitingPongState+ SingEnd :: STestProtocol EndState++instance StateTokenI IdleState where stateToken = SingIdle+instance StateTokenI AwaitingPongState where stateToken = SingAwaitingPong+instance StateTokenI EndState where stateToken = SingEnd++data TestCodec++instance Codec TestCodec where+ type MonadEncode TestCodec = Identity+ type MonadDecode TestCodec = Except String++instance Serializable TestCodec a where+ encode _ = pure (pure ())+ decode _ = throwError "this is a mock codec"++data PongEnum = NormalPong | ComplexPong+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++data PingEnum = PingRequest | EndPing+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++deriving via (ViaEnum PongEnum)+ instance (Codec codec, HasInfo codec (DefEnumEncoding codec)) => HasInfo codec PongEnum++deriving via (ViaEnum PingEnum)+ instance (Codec codec, HasInfo codec (DefEnumEncoding codec)) => HasInfo codec PingEnum++instance HasInfo TestCodec () where+ info _ _ = basicField "()" (FixedSize 0)++instance HasInfo TestCodec Text where+ info codec _ =+ compoundField "Text"+ [ ("length", info codec (Proxy @Word32))+ , ("data", basicField "UTF8 dat" (FixedSize 0))+ ]++instance HasInfo TestCodec a => HasInfo TestCodec [a] where+ info codec (_ :: Proxy [a]) =+ compoundField "List"+ [ ( "length", info codec (Proxy @Word32))+ , ( "values"+ , listField (VarSize "length") (info codec (Proxy @a))+ )+ ]+++instance HasInfo TestCodec a => HasInfo TestCodec (Maybe a) where+ info codec (_ :: Proxy (Maybe a)) =+ compoundField "Maybe"+ [ ("isJust", info codec (Proxy @Word32))+ , ( "value"+ , sumField "isJust"+ [ ("Nothing", info codec (Proxy @()))+ , ("Just", info codec (Proxy @a))+ ]+ )+ ]++instance HasInfo TestCodec (Message TestProtocol IdleState AwaitingPongState) where+ info codec _ = infoOf "PingRequest" $ info codec (Proxy @PingEnum)++instance HasInfo TestCodec (Message TestProtocol st EndState) where+ info codec _ = infoOf "EndPing" $ info codec (Proxy @PingEnum)++instance HasInfo TestCodec Word16 where+ info _ _ = basicField "Word16" (FixedSize 2)++instance HasInfo TestCodec Word32 where+ info _ _ = basicField "Word32" (FixedSize 4)++instance HasInfo TestCodec Word64 where+ info _ _ = basicField "Word64" (FixedSize 8)++$(deriveSerDoc ''TestCodec [] ''PongInfo)++instance HasInfo TestCodec (Message TestProtocol AwaitingPongState IdleState) where+ info codec _ =+ compoundField "Pong"+ [ ("pongType", info codec (Proxy @PongEnum))+ , ("pongData"+ , choiceField+ (IndexField "pongType")+ [ info codec (Proxy @())+ , info codec (Proxy @PongInfo)+ ]+ )+ ]
+ test/Network/TypedProtocol/Tests/TestProtocolTH.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Network.TypedProtocol.Tests.TestProtocolTH+where++import Network.TypedProtocol.Documentation.Html+import Network.TypedProtocol.Documentation.Types+import Network.TypedProtocol.Documentation.TH+import Network.TypedProtocol.Tests.TestProtocol++import Data.SerDoc.Class+import Data.Text (Text)+import qualified Data.Text.Lazy as LText+import Text.Blaze.Html.Renderer.Text (renderHtml)+import qualified Text.Blaze.Html.Renderer.Pretty as Pretty++testProtocolDescription :: ProtocolDescription TestCodec+testProtocolDescription = $(describeProtocol ''TestProtocol [] ''TestCodec [])++testProtocolHtmlString :: String+testProtocolHtmlString =+ Pretty.renderHtml . wrapDocument $+ renderProtocolDescriptions [testProtocolDescription]++testProtocolHtmlFile :: FilePath -> IO ()+testProtocolHtmlFile path =+ writeFile path testProtocolHtmlString++testProtocolHtml :: Text+testProtocolHtml =+ LText.toStrict . renderHtml . wrapDocument $+ renderProtocolDescriptions [testProtocolDescription]
+ typed-protocols-doc.cabal view
@@ -0,0 +1,98 @@+cabal-version: 3.0+name: typed-protocols-doc+version: 0.2.0.0+synopsis: Derive documentation from typed-protocols source code+description: Derive documentation for protocols implemented with+ [typed-protocols](https://hackage.haskell.org/package/typed-protocols).+license: Apache-2.0+license-file: LICENSE+author: Tobias Dammers+maintainer: tobias@well-typed.com+copyright: 2023-2025 Input Output Global Inc (IOG)+category: Network+build-type: Simple+extra-doc-files: CHANGELOG.md+ NOTICE++common warnings+ ghc-options: -Wall+ -Wno-unticked-promoted-constructors+ -Wcompat+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wpartial-fields+ -Widentities+ -Wredundant-constraints++library+ import: warnings+ exposed-modules: Network.TypedProtocol.Documentation+ , Network.TypedProtocol.Documentation.Types+ , Network.TypedProtocol.Documentation.TH+ , Network.TypedProtocol.Documentation.Html+ , Network.TypedProtocol.Documentation.Text+ , Network.TypedProtocol.Documentation.GraphViz+ , Network.TypedProtocol.Documentation.DefaultMain+ -- other-modules:+ -- other-extensions:+ build-depends: base >=4.14.0.0 && <5+ , aeson >=2.0 && <2.3+ , base64-bytestring >=1.2.1.0 && <1.3+ , blaze-html >=0.9.1.2 && <0.10+ , bytestring >=0.11 && <0.13+ , containers >=0.6.8 && <0.8+ , fgl >=5.7 && <5.9+ , filepath >=1.4.2.2 && <1.6+ , graphviz >=2999.20.1 && <2999.21.0+ , haddock-library >=1.11.0 && <1.12+ , knob >=0.1 && <0.3+ , mtl >=2.3.1 && <2.4+ , optparse-applicative >=0.18.1.0 && <0.19+ , template-haskell >=2.13.0.0+ , temporary >=1.3 && <1.4+ , text >=1.1 && <2.2+ , th-abstraction >=0.6.0.0 && <0.8+ , time >=1.12 && <1.14+ , serdoc-core+ , typed-protocols ^>= 1.0+ hs-source-dirs: src+ default-language: GHC2021+ default-extensions: DataKinds+ LambdaCase++executable typed-protocols-doc-demo+ import: warnings+ default-language: GHC2021+ hs-source-dirs: demo+ main-is: Main.hs+ other-modules: DemoProtocol+ -- other-extensions:+ build-depends: base >=4.14.0.0 && <5+ , typed-protocols+ , typed-protocols-doc+ , serdoc-core+ , mtl+ , text+ ++test-suite typed-protocols-doc-test+ import: warnings+ default-language: GHC2021+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules: Network.TypedProtocol.Tests.Documentation+ , Network.TypedProtocol.Tests.ControlProtocol+ , Network.TypedProtocol.Tests.TestProtocol+ , Network.TypedProtocol.Tests.TestProtocolTH+ -- other-extensions:+ build-depends: base >=4.14.0.0 && <5+ , blaze-html >=0.9.1.2 && <0.10+ , tasty >=1.5 && <1.6+ , tasty-quickcheck >=0.10.3 && <0.11+ , typed-protocols+ , typed-protocols-doc+ , serdoc-core+ , text >=1.1 && <2.2+ , bytestring >=0.11 && <0.13+ , mtl