simplex-chat/tests/APIDocs.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module APIDocs where

import API.Docs.Commands
import API.Docs.Events
import API.Docs.Generate
import API.Docs.Responses
import API.Docs.Types
import API.TypeInfo
import Control.Monad
import Data.Containers.ListUtils (nubOrd)
import Data.List (foldl', intercalate, sort, (\\))
import qualified Data.Set as S
import qualified Data.Text.IO as T
import Simplex.Messaging.Util (ifM)
import System.Directory (doesFileExist)
import Test.Hspec

apiDocsTest :: Spec
apiDocsTest = do
  describe "API commands" $ do
    it "should be documented" testCommandsHaveDocs
    it "should have field names" testCommandsHaveNamedFields
    it "should have defined responses" testCommandsHaveResponses
    it "generate markdown" testGenerateCommandsMD
  describe "API responses" $ do
    it "should be documented" testResponsesHaveDocs
  describe "API events" $ do
    it "should be documented" testEventsHaveDocs
    it "generate markdown" testGenerateEventsMD
  describe "API types" $ do
    it "should be documented" testTypesHaveDocs
    it "generate markdown" testGenerateTypesMD

documentedCmds :: [String]
documentedCmds = concatMap (map consName' . commands) chatCommandsDocs

documentedCmdTypes :: [ATUnionMember]
documentedCmdTypes = concatMap (map commandType . commands) chatCommandsDocs

documentedResps :: [String]
documentedResps = map consName' chatResponsesDocs

documentedRespTypes :: [ATUnionMember]
documentedRespTypes = map responseType chatResponsesDocs

documentedEvts :: [String]
documentedEvts = concatMap (\cat -> map consName' $ mainEvents cat ++ otherEvents cat) chatEventsDocs

documentedEvtTypes :: [ATUnionMember]
documentedEvtTypes = concatMap (\cat -> map eventType $ mainEvents cat ++ otherEvents cat) chatEventsDocs

documentedTypes :: [String]
documentedTypes = map docTypeName chatTypesDocs

testCommandsHaveDocs :: IO ()
testCommandsHaveDocs = do
  let typeCmds = sort $ map consName' chatCommandsTypeInfo
      allCmds = sort $ documentedCmds ++ cliCommands ++ undocumentedCommands
      missingCmds = typeCmds \\ allCmds
      extraCmds = allCmds \\ typeCmds
  unless (null missingCmds) $ expectationFailure $ "Undocumented commands: " <> intercalate ", " missingCmds
  unless (null extraCmds) $ expectationFailure $ "Unused commands: " <> intercalate ", " extraCmds
  putStrLn $ "Documented commands: " <> show (length documentedCmds) <> "/" <> show (length allCmds)
  allCmds `shouldBe` typeCmds -- sanity check

testCommandsHaveNamedFields :: IO ()
testCommandsHaveNamedFields = do
  let docCmds = S.fromList documentedCmds
      unnamedFields = filter (\RecordTypeInfo {consName, fieldInfos} -> consName `S.member` docCmds && any (\FieldInfo {fieldName} -> null fieldName) fieldInfos) chatCommandsTypeInfo
  unless (null unnamedFields) $ expectationFailure $ "Commands with unnamed fields: " <> intercalate ", " (map consName' unnamedFields)

testResponsesHaveDocs :: IO ()
testResponsesHaveDocs = do
  let typeResps = sort $ "CRChatCmdError" : map consName' chatResponsesTypeInfo
      allResps = sort $ documentedResps ++ undocumentedResponses
      missingResps = typeResps \\ allResps
      extraResps = allResps \\ typeResps
  unless (null missingResps) $ expectationFailure $ "Undocumented responses: " <> intercalate ", " missingResps
  unless (null extraResps) $ expectationFailure $ "Unused responses: " <> intercalate ", " extraResps
  putStrLn $ "Documented responses: " <> show (length documentedResps) <> "/" <> show (length allResps)
  allResps `shouldBe` typeResps -- sanity check

testEventsHaveDocs :: IO ()
testEventsHaveDocs = do
  let typeEvts = sort $ "CEvtChatError" : map consName' chatEventsTypeInfo
      allEvts = sort $ documentedEvts ++ undocumentedEvents
      missingEvts = typeEvts \\ allEvts
      extraEvts = allEvts \\ typeEvts
  unless (null missingEvts) $ expectationFailure $ "Undocumented events: " <> intercalate ", " missingEvts
  unless (null extraEvts) $ expectationFailure $ "Unused events: " <> intercalate ", " extraEvts
  putStrLn $ "Documented events: " <> show (length documentedEvts) <> "/" <> show (length allEvts)
  allEvts `shouldBe` typeEvts -- sanity check

testTypesHaveDocs :: IO ()
testTypesHaveDocs = do
  let allDocTypes = sort $ documentedTypes ++ primitiveTypes
      apiTypes = sort $ nubOrd $ concatMap unionMemberTypes $ documentedCmdTypes ++ documentedRespTypes ++ documentedEvtTypes
      extraTypes = allDocTypes \\ apiTypes
      missingTypes = apiTypes \\ allDocTypes
  unless (null extraTypes) $ expectationFailure $ "Unused types: " <> intercalate ", " extraTypes
  unless (null missingTypes) $ expectationFailure $ "Undocumented types: " <> intercalate ", " missingTypes
  allDocTypes `shouldBe` apiTypes
  putStrLn $ "Documented types: " <> show (length allDocTypes)
  where
    unionMemberTypes :: ATUnionMember -> [ConsName]
    unionMemberTypes (ATUnionMember _ fields) = concatMap recordFiledTypes fields
    recordFiledTypes :: APIRecordField -> [ConsName]
    recordFiledTypes (APIRecordField _ t) = apiTypeTypes t
    apiTypeTypes :: APIType -> [ConsName]
    apiTypeTypes = \case
      ATPrim (PT t) -> [t]
      ATDef td -> typeDefTypes td
      ATRef t -> [t] -- ??
      ATOptional t -> apiTypeTypes t
      ATArray t _ -> apiTypeTypes t
      ATMap (PT t) v -> t : apiTypeTypes v
    typeDefTypes :: APITypeDef -> [ConsName]
    typeDefTypes (APITypeDef t td) = t : case td of
      ATDRecord fields -> concatMap recordFiledTypes fields
      ATDUnion members -> concatMap unionMemberTypes members
      ATDEnum _ -> []

testCommandsHaveResponses :: IO ()
testCommandsHaveResponses = do
  let analyzeCmd (cmdsNoResp, rs) CCDoc {consName, responses}
        | null responses = (consName : cmdsNoResp, rs)
        | otherwise = (cmdsNoResp, rs `S.union` S.fromList (map consName' responses))
      (cmdsNoResponses, cmdResponses) = foldl' analyzeCmd ([], S.empty) $ concatMap commands chatCommandsDocs
      undocResps = S.toList $ cmdResponses `S.difference` S.fromList documentedResps
      extraResps = S.toList $ S.fromList documentedResps `S.difference` cmdResponses
  unless (null cmdsNoResponses) $ expectationFailure $ "Commands without responses: " <> intercalate ", " (reverse cmdsNoResponses)
  unless (null undocResps) $ expectationFailure $ "Undocumented command responses: " <> intercalate ", " undocResps
  unless (null extraResps) $ expectationFailure $ "Unused documented command responses: " <> intercalate ", " extraResps

testGenerateCommandsMD :: IO ()
testGenerateCommandsMD = do
  cmdsDoc <- ifM (doesFileExist commandsDocFile) (T.readFile commandsDocFile) (pure "")
  T.writeFile commandsDocFile commandsDocText
  commandsDocText `shouldBe` cmdsDoc

testGenerateEventsMD :: IO ()
testGenerateEventsMD = do
  evtsDoc <- ifM (doesFileExist eventsDocFile) (T.readFile eventsDocFile) (pure "")
  T.writeFile eventsDocFile eventsDocText
  eventsDocText `shouldBe` evtsDoc

testGenerateTypesMD :: IO ()
testGenerateTypesMD = do
  typesDoc <- ifM (doesFileExist typesDocFile) (T.readFile typesDocFile) (pure "")
  T.writeFile typesDocFile typesDocText
  typesDocText `shouldBe` typesDoc