diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/NOTICE b/NOTICE new file mode 100644 --- /dev/null +++ b/NOTICE @@ -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. + diff --git a/demo/DemoProtocol.hs b/demo/DemoProtocol.hs new file mode 100644 --- /dev/null +++ b/demo/DemoProtocol.hs @@ -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) + ] + ) + ] diff --git a/demo/Main.hs b/demo/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Main.hs @@ -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 [''()]) + ] diff --git a/src/Network/TypedProtocol/Documentation.hs b/src/Network/TypedProtocol/Documentation.hs new file mode 100644 --- /dev/null +++ b/src/Network/TypedProtocol/Documentation.hs @@ -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 diff --git a/src/Network/TypedProtocol/Documentation/DefaultMain.hs b/src/Network/TypedProtocol/Documentation/DefaultMain.hs new file mode 100644 --- /dev/null +++ b/src/Network/TypedProtocol/Documentation/DefaultMain.hs @@ -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 diff --git a/src/Network/TypedProtocol/Documentation/GraphViz.hs b/src/Network/TypedProtocol/Documentation/GraphViz.hs new file mode 100644 --- /dev/null +++ b/src/Network/TypedProtocol/Documentation/GraphViz.hs @@ -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 diff --git a/src/Network/TypedProtocol/Documentation/Html.hs b/src/Network/TypedProtocol/Documentation/Html.hs new file mode 100644 --- /dev/null +++ b/src/Network/TypedProtocol/Documentation/Html.hs @@ -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 diff --git a/src/Network/TypedProtocol/Documentation/TH.hs b/src/Network/TypedProtocol/Documentation/TH.hs new file mode 100644 --- /dev/null +++ b/src/Network/TypedProtocol/Documentation/TH.hs @@ -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 diff --git a/src/Network/TypedProtocol/Documentation/Text.hs b/src/Network/TypedProtocol/Documentation/Text.hs new file mode 100644 --- /dev/null +++ b/src/Network/TypedProtocol/Documentation/Text.hs @@ -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 "" +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 diff --git a/src/Network/TypedProtocol/Documentation/Types.hs b/src/Network/TypedProtocol/Documentation/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/TypedProtocol/Documentation/Types.hs @@ -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 + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/Network/TypedProtocol/Tests/ControlProtocol.hs b/test/Network/TypedProtocol/Tests/ControlProtocol.hs new file mode 100644 --- /dev/null +++ b/test/Network/TypedProtocol/Tests/ControlProtocol.hs @@ -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 @())) diff --git a/test/Network/TypedProtocol/Tests/Documentation.hs b/test/Network/TypedProtocol/Tests/Documentation.hs new file mode 100644 --- /dev/null +++ b/test/Network/TypedProtocol/Tests/Documentation.hs @@ -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 ] diff --git a/test/Network/TypedProtocol/Tests/TestProtocol.hs b/test/Network/TypedProtocol/Tests/TestProtocol.hs new file mode 100644 --- /dev/null +++ b/test/Network/TypedProtocol/Tests/TestProtocol.hs @@ -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) + ] + ) + ] diff --git a/test/Network/TypedProtocol/Tests/TestProtocolTH.hs b/test/Network/TypedProtocol/Tests/TestProtocolTH.hs new file mode 100644 --- /dev/null +++ b/test/Network/TypedProtocol/Tests/TestProtocolTH.hs @@ -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] diff --git a/typed-protocols-doc.cabal b/typed-protocols-doc.cabal new file mode 100644 --- /dev/null +++ b/typed-protocols-doc.cabal @@ -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