mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-02 20:46:46 +00:00
docs: bots API (#6091)
* docs: bot API commands * generate API commands doc * generate commands docs with parameters and responses * add API types * more types * document all types (with some deviations from JSON encodings) * rename types * interface objects * separator * command syntax * more syntax * API events * event types * fix all type definitions * pre-process types outside of rendering * pre-process event types * overview * pre-process commands * param syntax WIP * syntax for types in command parameters * API error response and chat event * remove unsupported/deprecated command parameters * reorder * syntax for choice * show command errors * event descriptions * python syntax for commands and types (#6099) * python syntax for commands and types * python snippets: convert numbers to string * fixes * update readme, enable all tests * fix operators test * update plans --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny
@@ -0,0 +1,462 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module API.Docs.Commands where
|
||||
|
||||
import API.Docs.Responses
|
||||
import API.Docs.Syntax.Types
|
||||
import API.Docs.Types
|
||||
import API.TypeInfo
|
||||
import Data.String
|
||||
import Data.List (find)
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Messaging.Parsers (dropPrefix, fstToLower)
|
||||
|
||||
chatCommandsDocs :: [CCCategory]
|
||||
chatCommandsDocs = map toCategory chatCommandsDocsData
|
||||
where
|
||||
toCategory (categoryName, categoryDescr, commandsData) =
|
||||
CCCategory {categoryName, categoryDescr, commands = map toCmd commandsData}
|
||||
toCmd (consName, hideParams, commandDescr, respNames, errors, network, syntax) = case find ((consName ==) . consName') chatCommandsTypeInfo of
|
||||
Just RecordTypeInfo {fieldInfos} ->
|
||||
let fields = filter ((`notElem` hideParams) . fieldName') $ map (toAPIField consName) fieldInfos
|
||||
commandType = ATUnionMember (fstToLower consName) fields
|
||||
findResp name = case find ((name ==) . consName') chatResponsesDocs of
|
||||
Just resp -> resp
|
||||
Nothing -> error $ "Missing response doc for " <> name
|
||||
responses = map findResp respNames
|
||||
errors' = map (\(TD err descr) -> TD (dropPrefix "CE" err) descr) errors
|
||||
in CCDoc {consName, commandType, commandDescr, responses, errors = errors', network, syntax}
|
||||
Nothing -> error $ "Missing command type info for " <> consName
|
||||
|
||||
deriving instance Generic ChatCommand
|
||||
|
||||
chatCommandsTypeInfo :: [RecordTypeInfo]
|
||||
chatCommandsTypeInfo = recordTypesInfo @ChatCommand
|
||||
|
||||
data CCCategory = CCCategory
|
||||
{ categoryName :: String,
|
||||
categoryDescr :: String,
|
||||
commands :: [CCDoc]
|
||||
}
|
||||
|
||||
data CCDoc = CCDoc
|
||||
{ consName :: ConsName,
|
||||
commandType :: ATUnionMember,
|
||||
commandDescr :: Text,
|
||||
responses :: [CRDoc],
|
||||
errors :: [ErrorTypeDoc],
|
||||
network :: Maybe UsesNetwork,
|
||||
syntax :: Expr
|
||||
}
|
||||
|
||||
instance ConstructorName CCDoc where consName' CCDoc {consName} = consName
|
||||
|
||||
data ErrorTypeDoc = TD
|
||||
{ consName :: ConsName,
|
||||
description :: String
|
||||
}
|
||||
|
||||
data UsesNetwork = UNBackground | UNInteractive
|
||||
|
||||
instance IsString ErrorTypeDoc where fromString s = TD s ""
|
||||
|
||||
|
||||
-- category name, category description, commands
|
||||
-- inner: constructor, description, responses, errors (ChatErrorType constructors), network usage, syntax
|
||||
chatCommandsDocsData :: [(String, String, [(ConsName, [String], Text, [ConsName], [ErrorTypeDoc], Maybe UsesNetwork, Expr)])]
|
||||
chatCommandsDocsData =
|
||||
[ ( "Address commands",
|
||||
"Bots can use these commands to automatically check and create address when initialized",
|
||||
[ ("APICreateMyAddress", [], "Create bot address.", ["CRUserContactLinkCreated"], [], Just UNInteractive, "/_address " <> Param "userId"),
|
||||
("APIDeleteMyAddress", [], "Delete bot address.", ["CRUserContactLinkDeleted"], [], Just UNBackground, "/_delete_address " <> Param "userId"),
|
||||
("APIShowMyAddress", [], "Get bot address and settings.", ["CRUserContactLink"], [], Nothing, "/_show_address " <> Param "userId"),
|
||||
("APISetProfileAddress", [], "Add address to bot profile.", ["CRUserProfileUpdated"], [], Just UNInteractive, "/_profile_address " <> Param "userId" <> " " <> OnOff "enable"),
|
||||
("APISetAddressSettings", [], "Set bot address settings.", ["CRUserContactLinkUpdated"], [], Just UNInteractive, "/_address_settings " <> Param "userId" <> " " <> Json "settings")
|
||||
]
|
||||
),
|
||||
( "Message commands",
|
||||
"Commands to send, update, delete, moderate messages and set message reactions",
|
||||
[ ("APISendMessages", [], "Send messages.", ["CRNewChatItems"], [], Just UNBackground, "/_send " <> Param "sendRef" <> OnOffParam "live" "liveMessage" (Just False) <> Optional "" (" ttl=" <> Param "$0") "ttl" <> " json " <> Json "composedMessages"),
|
||||
( "APIUpdateChatItem",
|
||||
[],
|
||||
"Update message.",
|
||||
["CRChatItemUpdated", "CRChatItemNotChanged", "CRChatCmdError"],
|
||||
[TD "CEInvalidChatItemUpdate" "Not user's message or cannot be edited"],
|
||||
Just UNBackground,
|
||||
"/_update item " <> Param "chatRef" <> " " <> Param "chatItemId" <> OnOffParam "live" "liveMessage" (Just False) <> " json " <> Json "updatedMessage"
|
||||
),
|
||||
("APIDeleteChatItem", [], "Delete message.", ["CRChatItemsDeleted"], [], Just UNBackground, "/_delete item " <> Param "chatRef" <> " " <> Join ',' "chatItemIds" <> " " <> Param "deleteMode"),
|
||||
("APIDeleteMemberChatItem", [], "Moderate message. Requires Moderator role (and higher than message author's).", ["CRChatItemsDeleted"], [], Just UNBackground, "/_delete member item #" <> Param "groupId" <> " " <> Join ',' "chatItemIds"),
|
||||
("APIChatItemReaction", [], "Add/remove message reaction.", ["CRChatItemReaction"], [], Just UNBackground, "/_reaction " <> Param "chatRef" <> " " <> Param "chatItemId" <> " " <> OnOff "add" <> " " <> Json "reaction")
|
||||
]
|
||||
),
|
||||
( "File commands",
|
||||
"Commands to receive and to cancel files. Files are sent as part of the message, there are no separate commands to send files.",
|
||||
[ ("ReceiveFile", [], "Receive file.", ["CRRcvFileAccepted", "CRRcvFileAcceptedSndCancelled"], [], Nothing, "/freceive " <> Param "fileId" <> OnOffParam "approved_relays" "userApprovedRelays" (Just False) <> OnOffParam "encrypt" "storeEncrypted" Nothing <> OnOffParam "inline" "fileInline" Nothing <> Optional "" (" " <> Param "$0") "filePath"),
|
||||
("CancelFile", [], "Cancel file.", ["CRSndFileCancelled", "CRRcvFileCancelled", "CRChatCmdError"], [TD "CEFileCancel" "Cannot cancel file"], Just UNBackground, "/fcancel " <> Param "fileId")
|
||||
]
|
||||
),
|
||||
( "Group commands",
|
||||
"Commands to manage and moderate groups. These commands can be used with business chats as well - they are groups. E.g., a common scenario would be to add human agents to business chat with the customer who connected via business address.",
|
||||
[ ("APIAddMember", [], "Add contact to group. Requires bot to have Admin role.", ["CRSentGroupInvitation"], [], Just UNInteractive, "/_add #" <> Param "groupId" <> " " <> Param "contactId" <> " " <> Param "memberRole"),
|
||||
("APIJoinGroup", ["enableNtfs"], "Join group.", ["CRUserAcceptedGroupSent"], [], Just UNInteractive, "/_join #" <> Param "groupId"),
|
||||
("APIAcceptMember", [], "Accept group member. Requires Admin role.", ["CRMemberAccepted", "CRChatCmdError"], [TD "CEGroupMemberNotActive" "Member is not connected yet"], Just UNBackground, "/_accept member #" <> Param "groupId" <> " " <> Param "groupMemberId" <> " " <> Param "memberRole"),
|
||||
("APIMembersRole", [], "Set members role. Requires Admin role.", ["CRMembersRoleUser"], [], Just UNBackground, "/_member role #" <> Param "groupId" <> " " <> Join ',' "groupMemberIds" <> " " <> Param "memberRole"),
|
||||
("APIBlockMembersForAll", [], "Block members. Requires Moderator role.", ["CRMembersBlockedForAllUser"], [], Just UNBackground, "/_block #" <> Param "groupId" <> " " <> Join ',' "groupMemberIds" <> OnOffParam "blocked" "blocked" Nothing),
|
||||
("APIRemoveMembers", [], "Remove members. Requires Admin role.", ["CRUserDeletedMembers", "CRChatCmdError"], ["CEGroupMemberNotFound"], Just UNBackground, "/_remove #" <> Param "groupId" <> " " <> Join ',' "groupMemberIds" <> OnOffParam "messages" "withMessages" (Just False)),
|
||||
("APILeaveGroup", [], "Leave group.", ["CRLeftMemberUser"], [], Just UNBackground, "/_leave #" <> Param "groupId")
|
||||
-- ("APIListMembers", [], "Get group members.", ["CRGroupMembers"], [], Nothing, ""),
|
||||
-- ("APINewGroup", [], "Create group.", ["CRGroupCreated"], [], Nothing, ""),
|
||||
-- ("APIUpdateGroupProfile", [], "Update group profile.", ["CRGroupUpdated"], [], Just UNBackground, [])
|
||||
]
|
||||
),
|
||||
( "Group link commands",
|
||||
"These commands can be used by bots that manage multiple public groups",
|
||||
[ ("APICreateGroupLink", [], "Create group link.", ["CRGroupLinkCreated"], [], Just UNInteractive, "/_create link #" <> Param "groupId" <> " " <> Param "memberRole"),
|
||||
("APIGroupLinkMemberRole", [], "Set member role for group link.", ["CRGroupLink"], [], Nothing, "/_set link role #" <> Param "groupId" <> " " <> Param "memberRole"),
|
||||
("APIDeleteGroupLink", [], "Delete group link.", ["CRGroupLinkDeleted"], [], Just UNBackground, "/_delete link #" <> Param "groupId"),
|
||||
("APIGetGroupLink", [], "Get group link.", ["CRGroupLink"], [], Nothing, "/_get link #" <> Param "groupId")
|
||||
]
|
||||
),
|
||||
( "Connection commands",
|
||||
"These commands may be used to create connections. Most bots do not need to use them - bot users will connect via bot address with auto-accept enabled.",
|
||||
[ ("APIAddContact", [], "Create 1-time invitation link.", ["CRInvitation"], [], Just UNInteractive, "/_connect " <> Param "userId" <> OnOffParam "incognito" "incognito" (Just False)),
|
||||
("APIConnectPlan", [], "Determine SimpleX link type and if the bot is already connected via this link.", ["CRConnectionPlan"], [], Just UNInteractive, "/_connect plan " <> Param "userId" <> " " <> Param "connectionLink"),
|
||||
("APIConnect", [], "Connect via SimpleX link. The link can be 1-time invitation link, contact address or group link", ["CRSentConfirmation", "CRContactAlreadyExists", "CRSentInvitation"], [], Just UNInteractive, "/_connect " <> Param "userId" <> " " <> Param "connLink_"),
|
||||
("APIAcceptContact", ["incognito"], "Accept contact request.", ["CRAcceptingContactRequest"], [], Just UNInteractive, "/_accept " <> Param "contactReqId"),
|
||||
("APIRejectContact", [], "Reject contact request. The user who sent the request is **not notified**.", ["CRContactRequestRejected"], [], Nothing, "/_reject " <> Param "contactReqId")
|
||||
]
|
||||
),
|
||||
( "Chat commands",
|
||||
"Commands to list and delete coversations.",
|
||||
[ ("APIListContacts", [], "Get contacts.", ["CRContactsList"], [], Nothing, "/_contacts " <> Param "userId"),
|
||||
("APIListGroups", [], "Get groups.", ["CRGroupsList"], [], Nothing, "/_groups " <> Param "userId" <> Optional "" (" @" <> Param "$0") "contactId_" <> Optional "" (" " <> Param "$0") "search"),
|
||||
("APIDeleteChat", [], "Delete chat.", ["CRContactDeleted", "CRContactConnectionDeleted", "CRGroupDeletedUser"], [], Just UNBackground, "/_delete " <> Param "chatRef" <> " " <> Param "chatDeleteMode")
|
||||
-- ("APIChatItemsRead", [], "Mark items as read.", ["CRItemsReadForChat"], [], Nothing, ""),
|
||||
-- ("APIChatRead", [], "Mark chat as read.", ["CRCmdOk"], [], Nothing, ""),
|
||||
-- ("APIChatUnread", [], "Mark chat as unread.", ["CRCmdOk"], [], Nothing, ""),
|
||||
-- ("APIClearChat", [], "Clear chat.", ["CRChatCleared"], [], Nothing, ""),
|
||||
-- ("APIGetChat", [], "Get chat.", ["CRApiChat"], [], Nothing, ""),
|
||||
-- ("APIGetChatItemInfo", [], "Get message information.", ["CRChatItemInfo"], [], Nothing, ""),
|
||||
-- ("APIGetChatItems", [], "Get the most recent messages from all chats.", ["CRChatItems"], [], Nothing, ""),
|
||||
-- ("APIGetChats", [], "Get chats.", ["CRApiChats"], [], Nothing, ""),
|
||||
-- ("APISetChatSettings", [], "Set chat settings.", ["CRCmdOk"], [], Nothing, ""),
|
||||
-- ("APISetChatTTL", [], "Set TTL for chat messages.", ["CRCmdOk"], [], Nothing, ""),
|
||||
-- ("APISetConnectionAlias", [], "Set connection alias.", ["CRConnectionAliasUpdated"], [], Nothing, ""),
|
||||
-- ("APISetContactAlias", [], "Set contact alias.", ["CRContactAliasUpdated"], [], Nothing, ""),
|
||||
-- ("APISetContactPrefs", [], "Set contact preferences.", ["CRContactPrefsUpdated"], [], Just UNBackground, ""),
|
||||
-- ("APISetGroupAlias", [], "Set group alias.", ["CRGroupAliasUpdated"], [], Nothing, ""),
|
||||
-- ("APISyncContactRatchet", [], "Synchronize encryption with contact.", ["CRContactRatchetSyncStarted"], [], Just UNBackground, ""),
|
||||
-- ("APISyncGroupMemberRatchet", [], "Synchronize encryption with member.", ["CRGroupMemberRatchetSyncStarted"], [], Just UNBackground, ""),
|
||||
]
|
||||
),
|
||||
( "User profile commands",
|
||||
"Most bots don't need to use these commands, as bot profile can be configured manually via CLI or desktop client. These commands can be used by bots that need to manage multiple user profiles (e.g., the profiles of support agents).",
|
||||
[ ("ShowActiveUser", [], "Get active user profile", ["CRActiveUser"], [], Nothing, "/user"),
|
||||
( "CreateActiveUser",
|
||||
[],
|
||||
"Create new user profile",
|
||||
["CRActiveUser"],
|
||||
[TD "CEUserExists" "User or contact with this name already exists", TD "CEInvalidDisplayName" "Invalid user display name"],
|
||||
Nothing,
|
||||
"/_create user " <> Json "newUser"
|
||||
),
|
||||
("ListUsers", [], "Get all user profiles", ["CRUsersList"], [], Nothing, "/users"),
|
||||
("APISetActiveUser", [], "Set active user profile", ["CRActiveUser"], ["CEChatNotStarted"], Nothing, "/_user " <> Param "userId" <> Optional "" (" " <> Json "$0") "viewPwd"),
|
||||
("APIDeleteUser", [], "Delete user profile.", ["CRCmdOk"], [], Just UNBackground, "/_delete user " <> Param "userId" <> OnOffParam "del_smp" "delSMPQueues" Nothing <> Optional "" (" " <> Json "$0") "viewPwd"),
|
||||
("APIUpdateProfile", [], "Update user profile.", ["CRUserProfileUpdated"], [], Just UNBackground, "/_profile " <> Param "userId" <> " " <> Json "profile")
|
||||
]
|
||||
)
|
||||
]
|
||||
|
||||
cliCommands :: [ConsName]
|
||||
cliCommands =
|
||||
[ "AbortSwitchContact",
|
||||
"AbortSwitchGroupMember",
|
||||
"AcceptContact",
|
||||
"AcceptMember",
|
||||
"AddContact",
|
||||
"AddMember",
|
||||
"BlockForAll",
|
||||
"ChatHelp",
|
||||
"ClearContact",
|
||||
"ClearGroup",
|
||||
"ClearNoteFolder",
|
||||
"Connect",
|
||||
"ConnectSimplex",
|
||||
"ContactInfo",
|
||||
"ContactQueueInfo",
|
||||
"CreateGroupLink",
|
||||
"CreateMyAddress",
|
||||
"DeleteContact",
|
||||
"DeleteGroup",
|
||||
"DeleteGroupLink",
|
||||
"DeleteMemberMessage",
|
||||
"DeleteMessage",
|
||||
"DeleteMyAddress",
|
||||
"DeleteUser",
|
||||
"EditMessage",
|
||||
"EnableContact",
|
||||
"EnableGroupMember",
|
||||
"FileStatus",
|
||||
"ForwardFile",
|
||||
"ForwardGroupMessage",
|
||||
"ForwardImage",
|
||||
"ForwardLocalMessage",
|
||||
"ForwardMessage",
|
||||
"GetChatTTL",
|
||||
"GetContactCode",
|
||||
"GetGroupMemberCode",
|
||||
"GroupLinkMemberRole",
|
||||
"GroupMemberInfo",
|
||||
"GroupMemberQueueInfo",
|
||||
"HideUser",
|
||||
"JoinGroup",
|
||||
"LastChatItemId",
|
||||
"LastChats",
|
||||
"LastMessages",
|
||||
"LeaveGroup",
|
||||
"ListContacts",
|
||||
"ListGroups",
|
||||
"ListMembers",
|
||||
"ListMemberSupportChats",
|
||||
"MemberRole",
|
||||
"MuteUser",
|
||||
"NewGroup",
|
||||
"QuitChat",
|
||||
"ReactToMessage",
|
||||
"RejectContact",
|
||||
"RemoveMembers",
|
||||
"ReportMessage",
|
||||
"SendCallInvitation",
|
||||
"SendFile",
|
||||
"SendFileDescription",
|
||||
"SendGroupMessageQuote",
|
||||
"SendImage",
|
||||
"SendLiveMessage",
|
||||
"SendMemberContactMessage",
|
||||
"SendMessage",
|
||||
"SendMessageBroadcast",
|
||||
"SendMessageQuote",
|
||||
"SetActiveUser",
|
||||
"SetAddressSettings",
|
||||
"SetChatTTL",
|
||||
"SetContactFeature",
|
||||
"SetContactTimedMessages",
|
||||
"SetGroupFeature",
|
||||
"SetGroupFeatureRole",
|
||||
"SetGroupMemberAdmissionReview",
|
||||
"SetGroupTimedMessages",
|
||||
"SetLocalDeviceName",
|
||||
"SetProfileAddress",
|
||||
"SetSendReceipts",
|
||||
"SetShowMemberMessages",
|
||||
"SetShowMessages",
|
||||
"SetUserContactReceipts",
|
||||
"SetUserFeature",
|
||||
"SetUserGroupReceipts",
|
||||
"SetUserTimedMessages",
|
||||
"ShowChatItem",
|
||||
"ShowChatItemInfo",
|
||||
"ShowGroupDescription",
|
||||
"ShowGroupInfo",
|
||||
"ShowGroupLink",
|
||||
"ShowGroupProfile",
|
||||
"ShowLiveItems",
|
||||
"ShowMyAddress",
|
||||
"ShowProfile",
|
||||
"ShowProfileImage",
|
||||
"ShowVersion",
|
||||
"SwitchContact",
|
||||
"SwitchGroupMember",
|
||||
"SyncContactRatchet",
|
||||
"SyncGroupMemberRatchet",
|
||||
"UnhideUser",
|
||||
"UnmuteUser",
|
||||
"UpdateGroupDescription",
|
||||
"UpdateGroupNames",
|
||||
"UpdateLiveMessage",
|
||||
"UpdateProfile",
|
||||
"UpdateProfileImage",
|
||||
"UserRead",
|
||||
"VerifyContact",
|
||||
"VerifyGroupMember",
|
||||
"Welcome"
|
||||
]
|
||||
|
||||
undocumentedCommands :: [ConsName]
|
||||
undocumentedCommands =
|
||||
[ "APIAbortSwitchContact",
|
||||
"APIAbortSwitchGroupMember",
|
||||
"APIAcceptConditions",
|
||||
"APIActivateChat",
|
||||
"APIAddGroupShortLink",
|
||||
"APIAddMyAddressShortLink",
|
||||
"APIArchiveReceivedReports",
|
||||
"APICallStatus",
|
||||
"APIChangeConnectionUser",
|
||||
"APIChangePreparedContactUser",
|
||||
"APIChangePreparedGroupUser",
|
||||
"APIChatItemsRead",
|
||||
"APIChatRead",
|
||||
"APIChatUnread",
|
||||
"APICheckToken",
|
||||
"APIClearChat",
|
||||
"APIConnectContactViaAddress",
|
||||
"APIConnectPreparedContact",
|
||||
"APIConnectPreparedGroup",
|
||||
"APIContactInfo",
|
||||
"APIContactQueueInfo",
|
||||
"APICreateChatItems",
|
||||
"APICreateChatTag",
|
||||
"APICreateMemberContact",
|
||||
"APIDeleteChatTag",
|
||||
"APIDeleteMemberSupportChat",
|
||||
"APIDeleteReceivedReports",
|
||||
"APIDeleteStorage",
|
||||
"APIDeleteToken",
|
||||
"APIDownloadStandaloneFile",
|
||||
"APIEnableContact",
|
||||
"APIEnableGroupMember",
|
||||
"APIEndCall",
|
||||
"APIExportArchive",
|
||||
"APIForwardChatItems",
|
||||
"APIGetAppSettings",
|
||||
"APIGetCallInvitations",
|
||||
"APIGetChat",
|
||||
"APIGetChatItemInfo",
|
||||
"APIGetChatItems",
|
||||
"APIGetChatItemTTL",
|
||||
"APIGetChats",
|
||||
"APIGetChatTags",
|
||||
"APIGetConnNtfMessages",
|
||||
"APIGetContactCode",
|
||||
"APIGetGroupMemberCode",
|
||||
"APIGetNetworkConfig",
|
||||
"APIGetNetworkStatuses",
|
||||
"APIGetNtfConns",
|
||||
"APIGetNtfToken",
|
||||
"APIGetReactionMembers",
|
||||
"APIGetServerOperators",
|
||||
"APIGetUsageConditions",
|
||||
"APIGetUserServers",
|
||||
"APIGroupInfo",
|
||||
"APIGroupMemberInfo",
|
||||
"APIGroupMemberQueueInfo",
|
||||
"APIHideUser",
|
||||
"APIImportArchive",
|
||||
"APIListMembers",
|
||||
"APIMuteUser",
|
||||
"APINewGroup",
|
||||
"APIPlanForwardChatItems",
|
||||
"APIPrepareContact",
|
||||
"APIPrepareGroup",
|
||||
"APIRegisterToken",
|
||||
"APIRejectCall",
|
||||
"APIReorderChatTags",
|
||||
"APIReportMessage",
|
||||
"APISaveAppSettings",
|
||||
"APISendCallAnswer",
|
||||
"APISendCallExtraInfo",
|
||||
"APISendCallInvitation",
|
||||
"APISendCallOffer",
|
||||
"APISendMemberContactInvitation",
|
||||
"APISetAppFilePaths",
|
||||
"APISetChatItemTTL",
|
||||
"APISetChatSettings",
|
||||
"APISetChatTags",
|
||||
"APISetChatTTL",
|
||||
"APISetChatUIThemes",
|
||||
"APISetConditionsNotified",
|
||||
"APISetConnectionAlias",
|
||||
"APISetConnectionIncognito",
|
||||
"APISetContactAlias",
|
||||
"APISetContactPrefs",
|
||||
"APISetEncryptLocalFiles",
|
||||
"APISetGroupAlias",
|
||||
"APISetMemberSettings",
|
||||
"APISetNetworkConfig",
|
||||
"APISetNetworkInfo",
|
||||
"APISetServerOperators",
|
||||
"APISetUserContactReceipts",
|
||||
"APISetUserGroupReceipts",
|
||||
"APISetUserServers",
|
||||
"APISetUserUIThemes",
|
||||
"APIStandaloneFileInfo",
|
||||
"APIStopChat",
|
||||
"APIStorageEncryption",
|
||||
"APISuspendChat",
|
||||
"APISwitchContact",
|
||||
"APISwitchGroupMember",
|
||||
"APISyncContactRatchet",
|
||||
"APISyncGroupMemberRatchet",
|
||||
"APITestProtoServer",
|
||||
"APIUnhideUser",
|
||||
"APIUnmuteUser",
|
||||
"APIUpdateChatTag",
|
||||
"APIUpdateGroupProfile",
|
||||
"APIUploadStandaloneFile",
|
||||
"APIUserRead",
|
||||
"APIValidateServers",
|
||||
"APIVerifyContact",
|
||||
"APIVerifyGroupMember",
|
||||
"APIVerifyToken",
|
||||
"CheckChatRunning",
|
||||
"ConfirmRemoteCtrl",
|
||||
"ConnectRemoteCtrl",
|
||||
"CustomChatCommand",
|
||||
"DebugEvent",
|
||||
"DebugLocks",
|
||||
"DeleteRemoteCtrl",
|
||||
"DeleteRemoteHost",
|
||||
"ExecAgentStoreSQL",
|
||||
"ExecChatStoreSQL",
|
||||
"ExportArchive",
|
||||
"FindKnownRemoteCtrl",
|
||||
"GetAgentQueuesInfo",
|
||||
"GetAgentServersSummary",
|
||||
"GetAgentSubs",
|
||||
"GetAgentSubsDetails",
|
||||
"GetAgentSubsTotal",
|
||||
"GetAgentWorkers",
|
||||
"GetAgentWorkersDetails",
|
||||
"GetChatItemTTL",
|
||||
"GetRemoteFile",
|
||||
"GetUserProtoServers",
|
||||
"ListRemoteCtrls",
|
||||
"ListRemoteHosts",
|
||||
"ReconnectAllServers",
|
||||
"ReconnectServer",
|
||||
"ResetAgentServersStats",
|
||||
"ResubscribeAllConnections",
|
||||
"SetAllContactReceipts",
|
||||
"SetChatItemTTL",
|
||||
"SetContactMergeEnabled",
|
||||
"SetFilesFolder",
|
||||
"SetFileToReceive",
|
||||
"SetNetworkConfig",
|
||||
"SetRemoteHostsFolder",
|
||||
"SetServerOperators",
|
||||
"SetTempFolder",
|
||||
"SetUserProtoServers",
|
||||
"SlowSQLQueries",
|
||||
"StartChat",
|
||||
"StartRemoteHost",
|
||||
"StopRemoteCtrl",
|
||||
"StopRemoteHost",
|
||||
"StoreRemoteFile",
|
||||
"SwitchRemoteHost",
|
||||
"TestProtoServer",
|
||||
"TestStorageEncryption",
|
||||
"VerifyRemoteCtrlSession"
|
||||
]
|
||||
@@ -0,0 +1,216 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module API.Docs.Events where
|
||||
|
||||
import API.Docs.Types
|
||||
import API.TypeInfo
|
||||
import Data.List (find)
|
||||
import GHC.Generics
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Messaging.Parsers (dropPrefix)
|
||||
|
||||
data CECategory = CECategory
|
||||
{ categoryName :: String,
|
||||
categoryDescr :: String,
|
||||
mainEvents :: [CEDoc],
|
||||
otherEvents :: [CEDoc]
|
||||
}
|
||||
|
||||
data CEDoc = CEDoc
|
||||
{ consName :: ConsName,
|
||||
eventType :: ATUnionMember,
|
||||
eventDescr :: String
|
||||
}
|
||||
|
||||
instance ConstructorName CEDoc where consName' CEDoc {consName} = consName
|
||||
|
||||
chatEventsDocs :: [CECategory]
|
||||
chatEventsDocs = map toCategory chatEventsDocsData
|
||||
where
|
||||
toCategory (categoryName, categoryDescr, mainEvts, otherEvts) =
|
||||
CECategory {categoryName, categoryDescr, mainEvents = map toEvt mainEvts, otherEvents = map toEvt otherEvts}
|
||||
toEvt (consName, eventDescr)
|
||||
| consName == "CEvtChatError" =
|
||||
let field = toAPIField consName $ FieldInfo "chatError" (ti "ChatError")
|
||||
eventType = ATUnionMember (dropPrefix "CEvt" consName) [field]
|
||||
in CEDoc {consName, eventType, eventDescr}
|
||||
| otherwise = case find ((consName ==) . consName') chatEventsTypeInfo of
|
||||
Just RecordTypeInfo {fieldInfos} ->
|
||||
let fields = map (toAPIField consName) fieldInfos
|
||||
eventType = ATUnionMember (dropPrefix "CEvt" consName) fields
|
||||
in CEDoc {consName, eventType, eventDescr}
|
||||
Nothing -> error $ "Missing event type info for " <> consName
|
||||
|
||||
deriving instance Generic ChatEvent
|
||||
|
||||
chatEventsTypeInfo :: [RecordTypeInfo]
|
||||
chatEventsTypeInfo = recordTypesInfo @ChatEvent
|
||||
|
||||
chatEventsDocsData :: [(String, String, [(ConsName, String)], [(ConsName, String)])]
|
||||
chatEventsDocsData =
|
||||
[ ( "Contact connection events", -- which event should be processed by a bot that has business address. Maybe needs a separate category.
|
||||
"Bots must use these events to process connecting users.\n\n\
|
||||
\Most bots enable auto-accept and don't need to accept connections via commands.\n\n\
|
||||
\You may create bot SimpleX address manually via CLI or desktop app or from bot code with these commands:\n\
|
||||
\- [APIShowMyAddress](./COMMANDS.md#apishowmyaddress) to check if address exists,\n\
|
||||
\- [APICreateMyAddress](./COMMANDS.md#apicreatemyaddress) to create address,\n\
|
||||
\- [APISetAddressSettings](./COMMANDS.md#apisetaddresssettings) to enable auto-access.",
|
||||
[ ( "CEvtContactConnected", "This event is sent after a user connects via bot SimpleX address (not a business address).")
|
||||
],
|
||||
[
|
||||
("CEvtContactUpdated", "Contact profile of another user is updated."),
|
||||
("CEvtContactDeletedByContact", "Bot user's connection with another contact is deleted (conversation is kept)."),
|
||||
("CEvtReceivedContactRequest", "Contact request received.\n\nThis event is only sent when auto-accept is disabled.\n\nThe request needs to be accepted using [APIAcceptContact](./COMMANDS.md#apiacceptcontact) command"),
|
||||
("CEvtNewMemberContactReceivedInv", "Received invitation to connect directly with a group member.\n\nThis event only needs to be processed to associate contact with group, the connection will proceed automatically."),
|
||||
("CEvtContactSndReady", "Connecting via 1-time invitation or after accepting contact request.\n\nAfter this event bot can send messages to this contact.") -- JOINED
|
||||
]
|
||||
),
|
||||
( "Message events",
|
||||
"Bots must use these events to process received messages.",
|
||||
[ ("CEvtNewChatItems", "Received message(s).")
|
||||
],
|
||||
[ ("CEvtChatItemReaction", "Received message reaction."),
|
||||
("CEvtChatItemsDeleted", "Message was deleted by another user."),
|
||||
("CEvtChatItemUpdated", "Message was updated by another user."),
|
||||
("CEvtGroupChatItemsDeleted", "Group messages are deleted or moderated."),
|
||||
("CEvtChatItemsStatusesUpdated", "Message delivery status updates.")
|
||||
]
|
||||
),
|
||||
( "Group events",
|
||||
"Bots may use these events to manage users' groups and business address groups.\n\n\
|
||||
\*Please note*: programming groups is more complex than programming direct connections",
|
||||
[ ("CEvtReceivedGroupInvitation", ""),
|
||||
("CEvtUserJoinedGroup", "Bot user joined group. Received when connection via group link completes."),
|
||||
("CEvtGroupUpdated", "Group profile or preferences updated."),
|
||||
("CEvtJoinedGroupMember", "Another member joined group."),
|
||||
("CEvtMemberRole", "Member (or bot user's) group role changed."),
|
||||
("CEvtDeletedMember", "Another member is removed from the group."),
|
||||
("CEvtLeftMember", "Another member left the group."),
|
||||
("CEvtDeletedMemberUser", "Bot user was removed from the group."),
|
||||
("CEvtGroupDeleted", "Group was deleted by the owner (not bot user).")
|
||||
],
|
||||
[ ("CEvtConnectedToGroupMember", "Connected to another group member."),
|
||||
("CEvtMemberAcceptedByOther", "Another group owner, admin or moderator accepted member to the group after review (\"knocking\")."),
|
||||
("CEvtMemberBlockedForAll", "Another member blocked for all members."),
|
||||
("CEvtGroupMemberUpdated", "Another group member profile updated.")
|
||||
]
|
||||
),
|
||||
( "File events",
|
||||
"Bots that send or receive files may process these events to track delivery status and to process completion.\n\n\
|
||||
\Bots that need to receive or moderate files (e.g., based on name, size or extension), \
|
||||
\can use relevant commands (e.g., [ReceiveFile](./COMMANDS.md#receivefile) or \
|
||||
\[APIDeleteMemberChatItem](./COMMANDS.md#apideletememberchatitem)) \
|
||||
\when processing [NewChatItems](#newchatitems) event.\n\n\
|
||||
\Bots that need to send files should use [APISendMessages](./COMMANDS.md#apisendmessages) command.",
|
||||
[ ( "CEvtRcvFileDescrReady",
|
||||
"File is ready to be received.\n\n\
|
||||
\This event is useful for processing sender file servers and monitoring file reception progress.\n\n\
|
||||
\[ReceiveFile](./COMMANDS.md#receivefile) command can be used before this event."
|
||||
),
|
||||
("CEvtRcvFileComplete", "File reception is competed."),
|
||||
("CEvtSndFileCompleteXFTP", "File upload is competed.")
|
||||
],
|
||||
[ ("CEvtRcvFileStart", "File reception started. This event will be sent after [CEvtRcvFileDescrReady](#rcvfiledescrready) event."),
|
||||
("CEvtRcvFileSndCancelled", "File was cancelled by the sender. This event may be sent instead of [CEvtRcvFileDescrReady](#rcvfiledescrready) event."),
|
||||
("CEvtRcvFileAccepted", "This event will be sent when file is automatically accepted because of CLI option."),
|
||||
("CEvtRcvFileError", "Error receiving file."),
|
||||
("CEvtRcvFileWarning", "Warning when receiving file. It can happen when CLI settings do not allow to connect to file server(s)."),
|
||||
("CEvtSndFileError", "Error sending file."),
|
||||
("CEvtSndFileWarning", "Warning when sending file.")
|
||||
]
|
||||
),
|
||||
( "Connection progress events",
|
||||
"Bots may use these events to track progress of connections for monitoring or debugging.",
|
||||
[ ("CEvtAcceptingContactRequest", "Automatically accepting contact request via bot's SimpleX address with auto-accept enabled."),
|
||||
("CEvtAcceptingBusinessRequest", "Automatically accepting contact request via bot's business address."),
|
||||
("CEvtContactConnecting", "Contact confirmed connection.\n\nSent when contact started connecting via bot's 1-time invitation link or when bot connects to another SimpleX address."), -- CONF
|
||||
("CEvtBusinessLinkConnecting", "Contact confirmed connection.\n\nSent when bot connects to another business address."), -- CONF
|
||||
("CEvtJoinedGroupMemberConnecting", "Group member is announced to the group and will be connecting to bot."), -- MSG
|
||||
("CEvtSentGroupInvitation", "Sent when another user joins group via bot's link."), -- INV
|
||||
("CEvtGroupLinkConnecting", "Sent when bot joins group via another user link.") -- CONF
|
||||
],
|
||||
[]
|
||||
),
|
||||
( "Error events",
|
||||
"Bots may log these events for debugging. \
|
||||
\There will be many error events - this does NOT indicate a malfunction - \
|
||||
\e.g., they may happen because of bad network connectivity, \
|
||||
\or because messages may be delivered to deleted chats for a short period of time \
|
||||
\(they will be ignored).",
|
||||
[ ("CEvtMessageError", ""),
|
||||
("CEvtChatError", ""), -- only used in WebSockets API, Haskell code uses Either, with error in Left
|
||||
("CEvtChatErrors", "")
|
||||
],
|
||||
[]
|
||||
)
|
||||
]
|
||||
|
||||
undocumentedEvents :: [ConsName]
|
||||
undocumentedEvents =
|
||||
[ "CEvtAcceptingGroupJoinRequestMember",
|
||||
"CEvtAgentConnsDeleted",
|
||||
"CEvtAgentRcvQueuesDeleted",
|
||||
"CEvtAgentUserDeleted",
|
||||
"CEvtBusinessRequestAlreadyAccepted",
|
||||
"CEvtCallAnswer",
|
||||
"CEvtCallEnded",
|
||||
"CEvtCallExtraInfo",
|
||||
"CEvtCallInvitation",
|
||||
"CEvtCallOffer",
|
||||
"CEvtChatInfoUpdated",
|
||||
"CEvtChatItemDeletedNotFound",
|
||||
"CEvtChatItemNotChanged",
|
||||
"CEvtChatSuspended",
|
||||
"CEvtConnectionDisabled",
|
||||
"CEvtConnectionInactive",
|
||||
"CEvtContactAndMemberAssociated",
|
||||
"CEvtContactAnotherClient",
|
||||
"CEvtContactDisabled",
|
||||
"CEvtContactPQEnabled",
|
||||
"CEvtContactRatchetSync",
|
||||
"CEvtContactRequestAlreadyAccepted",
|
||||
"CEvtContactsDisconnected",
|
||||
"CEvtContactsMerged",
|
||||
"CEvtContactsSubscribed",
|
||||
"CEvtContactSubError",
|
||||
"CEvtContactSubSummary",
|
||||
"CEvtContactSwitch",
|
||||
"CEvtCustomChatEvent",
|
||||
"CEvtGroupMemberRatchetSync",
|
||||
"CEvtGroupMemberSwitch",
|
||||
"CEvtHostConnected",
|
||||
"CEvtHostDisconnected",
|
||||
"CEvtNetworkStatus",
|
||||
"CEvtNetworkStatuses",
|
||||
"CEvtNewRemoteHost",
|
||||
"CEvtNoMemberContactCreating",
|
||||
"CEvtNtfMessage",
|
||||
"CEvtRcvFileAcceptedSndCancelled", -- only sent with legacy SMP files when they are cancelled
|
||||
"CEvtRcvFileProgressXFTP",
|
||||
"CEvtRcvStandaloneFileComplete",
|
||||
"CEvtRemoteCtrlFound",
|
||||
"CEvtRemoteCtrlSessionCode",
|
||||
"CEvtRemoteCtrlStopped",
|
||||
"CEvtRemoteHostConnected",
|
||||
"CEvtRemoteHostSessionCode",
|
||||
"CEvtRemoteHostStopped",
|
||||
"CEvtSndFileComplete", -- legacy SMP files
|
||||
"CEvtSndFileProgressXFTP",
|
||||
"CEvtSndFileRcvCancelled", -- legacy SMP files
|
||||
"CEvtSndFileRedirectStartXFTP",
|
||||
"CEvtSndFileStart", -- legacy SMP files
|
||||
"CEvtSndStandaloneFileComplete",
|
||||
"CEvtSubscriptionEnd",
|
||||
"CEvtTerminalEvent",
|
||||
"CEvtTimedAction",
|
||||
"CEvtUnknownMemberAnnounced",
|
||||
"CEvtUnknownMemberBlocked",
|
||||
"CEvtUnknownMemberCreated",
|
||||
"CEvtUserAcceptedGroupSent", -- repeat group invitation after it was accepted by the user
|
||||
"CEvtUserContactSubSummary"
|
||||
]
|
||||
@@ -0,0 +1,164 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module API.Docs.Generate where
|
||||
|
||||
import API.Docs.Commands
|
||||
import API.Docs.Events
|
||||
import API.Docs.Responses
|
||||
import API.Docs.Syntax
|
||||
import API.Docs.Syntax.Types
|
||||
import API.Docs.Types
|
||||
import API.TypeInfo
|
||||
import Data.Char (isSpace, isUpper, toLower, toUpper)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
||||
commandsDocFile :: FilePath
|
||||
commandsDocFile = "./bots/api/COMMANDS.md"
|
||||
|
||||
eventsDocFile :: FilePath
|
||||
eventsDocFile = "./bots/api/EVENTS.md"
|
||||
|
||||
typesDocFile :: FilePath
|
||||
typesDocFile = "./bots/api/TYPES.md"
|
||||
|
||||
commandsDocText :: Text
|
||||
commandsDocText =
|
||||
("# API Commands and Responses\n\n" <> autoGenerated <> "\n")
|
||||
<> foldMap commandCatTOC chatCommandsDocs
|
||||
<> "\n---\n"
|
||||
<> foldMap commandCatText chatCommandsDocs
|
||||
where
|
||||
commandCatTOC CCCategory {categoryName, commands} =
|
||||
(T.pack $ "\n" <> withLink "" categoryName <> "\n")
|
||||
<> foldMap commandTOC commands
|
||||
where
|
||||
commandTOC CCDoc {commandType = ATUnionMember tag _} = T.pack $ "- " <> withLink "" (fstToUpper tag) <> "\n"
|
||||
commandCatText CCCategory {categoryName, categoryDescr, commands} =
|
||||
(T.pack $ "\n\n## " <> categoryName <> "\n\n" <> categoryDescr <> "\n")
|
||||
<> foldMap commandDocText commands
|
||||
where
|
||||
commandDocText CCDoc {commandType = ATUnionMember tag params, commandDescr, network, syntax, responses, errors} =
|
||||
("\n\n### " <> T.pack (fstToUpper tag) <> "\n\n" <> commandDescr <> "\n\n*Network usage*: " <> networkUsage <> ".\n")
|
||||
<> (if null params then "" else paramsText)
|
||||
<> (if syntax == "" then "" else syntaxText (tag, params) syntax)
|
||||
<> (if length responses > 1 then "\n**Responses**:\n" else "\n**Response**:\n")
|
||||
<> foldMap responseText responses
|
||||
<> (if null errors then "" else "\n**Errors**:\n")
|
||||
<> foldMap errorText errors
|
||||
<> "\n---\n"
|
||||
where
|
||||
networkUsage = case network of
|
||||
Nothing -> "no"
|
||||
Just UNInteractive -> "interactive"
|
||||
Just UNBackground -> "background"
|
||||
paramsText = "\n**Parameters**:\n" <> fieldsText "./TYPES.md" params
|
||||
responseText CRDoc {responseType = ATUnionMember tag fields, responseDescr} =
|
||||
(T.pack $ "\n" <> fstToUpper tag <> ": " <> respDescr <> ".\n")
|
||||
<> ("- type: \"" <> T.pack tag <> "\"\n")
|
||||
<> fieldsText "./TYPES.md" fields
|
||||
where
|
||||
respDescr = if null responseDescr then camelToSpace tag else responseDescr
|
||||
errorText (TD err descr) =
|
||||
let descr' = if null descr then camelToSpace err else descr
|
||||
in T.pack $ "- " <> fstToUpper err <> ": " <> descr' <> ".\n"
|
||||
|
||||
syntaxText :: TypeAndFields -> Expr -> Text
|
||||
syntaxText r syntax =
|
||||
"\n**Syntax**:\n"
|
||||
<> "\n```\n" <> docSyntaxText r syntax <> "\n```\n"
|
||||
<> (if isConst syntax then "" else "\n```javascript\n" <> jsSyntaxText r syntax <> " // JavaScript\n```\n")
|
||||
<> (if isConst syntax then "" else "\n```python\n" <> pySyntaxText r syntax <> " # Python\n```\n")
|
||||
|
||||
camelToSpace :: String -> String
|
||||
camelToSpace [] = []
|
||||
camelToSpace (x : xs) = toUpper x : go xs
|
||||
where
|
||||
go [] = []
|
||||
go (y : ys)
|
||||
| isUpper y = ' ' : toLower y : go ys
|
||||
| otherwise = y : go ys
|
||||
|
||||
eventsDocText :: Text
|
||||
eventsDocText =
|
||||
("# API Events\n\n" <> autoGenerated <> "\n")
|
||||
<> foldMap eventCatTOC chatEventsDocs
|
||||
<> "\n---\n"
|
||||
<> foldMap eventCatText chatEventsDocs
|
||||
where
|
||||
eventCatTOC CECategory {categoryName, mainEvents, otherEvents} =
|
||||
(T.pack $ "\n" <> withLink "" categoryName <> "\n")
|
||||
<> (if hasOthers then "- Main event" <> plural mainEvents <> "\n" else "")
|
||||
<> foldMap eventTOC mainEvents
|
||||
<> (if hasOthers then "- Other event" <> plural otherEvents <> "\n" <> foldMap eventTOC otherEvents else "")
|
||||
where
|
||||
eventTOC CEDoc {eventType = ATUnionMember tag _} = T.pack $ indent <> "- " <> withLink "" (fstToUpper tag) <> "\n"
|
||||
hasOthers = not $ null otherEvents
|
||||
indent = if hasOthers then " " else ""
|
||||
eventCatText CECategory {categoryName, categoryDescr, mainEvents, otherEvents} =
|
||||
(T.pack $ "\n\n## " <> categoryName <> "\n\n" <> categoryDescr <> "\n")
|
||||
<> foldMap eventDocText (mainEvents ++ otherEvents)
|
||||
where
|
||||
eventDocText CEDoc {eventType = ATUnionMember tag fields, eventDescr} =
|
||||
(T.pack $ "\n\n### " <> fstToUpper tag <> "\n\n" <> evtDescr)
|
||||
<> "\n\n**Record type**:\n"
|
||||
<> ("- type: \"" <> T.pack tag <> "\"\n")
|
||||
<> fieldsText "./TYPES.md" fields
|
||||
<> "\n---\n"
|
||||
where
|
||||
evtDescr = if null eventDescr then camelToSpace tag <> "." else eventDescr
|
||||
plural evts = if length evts == 1 then "" else "s"
|
||||
|
||||
typesDocText :: Text
|
||||
typesDocText =
|
||||
("# API Types\n\n" <> autoGenerated <> "\n")
|
||||
<> (foldMap (\t -> T.pack $ "\n- " <> withLink "" (docTypeName t)) chatTypesDocs <> "\n")
|
||||
<> foldMap typeDocText chatTypesDocs
|
||||
where
|
||||
typeDocText CTDoc {typeDef = td@APITypeDef {typeName' = name, typeDef}, typeDescr, typeSyntax} =
|
||||
("\n\n---\n\n## " <> T.pack name <> "\n")
|
||||
<> (if T.null typeDescr then "" else "\n" <> typeDescr <> "\n")
|
||||
<> typeDefText typeDef
|
||||
<> (if typeSyntax == "" then "" else syntaxText (name, self : typeFields) typeSyntax)
|
||||
where
|
||||
self = APIRecordField "self" (ATDef td)
|
||||
typeFields = case typeDef of
|
||||
ATDRecord fs -> L.toList fs
|
||||
ATDUnion ms -> APIRecordField "type" tagType : concatMap (\(ATUnionMember _ fs) -> fs) ms
|
||||
where
|
||||
tagType = ATDef $ APITypeDef (name <> ".type") $ ATDEnum tags
|
||||
tags = L.map (\(ATUnionMember tag _) -> tag) ms
|
||||
ATDEnum _ -> []
|
||||
typeDefText = \case
|
||||
ATDRecord fields -> "\n**Record type**:\n" <> fieldsText "" (L.toList fields)
|
||||
ATDEnum cs -> "\n**Enum type**:\n" <> foldMap (\m -> "- \"" <> T.pack m <> "\"\n") cs
|
||||
ATDUnion cs -> "\n**Discriminated union type**:\n" <> foldMap constrText cs
|
||||
where
|
||||
constrText (ATUnionMember tag fields) =
|
||||
("\n" <> T.pack (fstToUpper tag) <> ":\n")
|
||||
<> ("- type: \"" <> T.pack tag <> "\"\n")
|
||||
<> fieldsText "" fields
|
||||
|
||||
fieldsText :: FilePath -> [APIRecordField] -> Text
|
||||
fieldsText docPath = foldMap $ T.pack . fieldText
|
||||
where
|
||||
fieldText (APIRecordField name t) = "- " <> name <> ": " <> typeText t <> "\n"
|
||||
typeText = \case
|
||||
ATPrim (PT t) -> t
|
||||
ATDef (APITypeDef t _) -> withLink docPath t
|
||||
ATRef t -> withLink docPath t
|
||||
ATOptional t -> typeText t <> "?"
|
||||
ATArray {elemType} -> "[" <> typeText elemType <> "]"
|
||||
ATMap (PT t) valueType -> "{" <> t <> " : " <> typeText valueType <> "}"
|
||||
|
||||
autoGenerated :: Text
|
||||
autoGenerated = "This file is generated automatically."
|
||||
|
||||
withLink :: FilePath -> String -> String
|
||||
withLink docPath s = "[" <> s <> "](" <> docPath <> "#" <> headerAnchor s <> ")"
|
||||
where
|
||||
headerAnchor = map $ \c -> if isSpace c then '-' else toLower c
|
||||
@@ -0,0 +1,206 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module API.Docs.Responses where
|
||||
|
||||
import API.Docs.Types
|
||||
import API.TypeInfo
|
||||
import Data.List (find)
|
||||
import GHC.Generics
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Messaging.Parsers (dropPrefix)
|
||||
|
||||
data CRDoc = CRDoc
|
||||
{ consName :: ConsName,
|
||||
responseType :: ATUnionMember,
|
||||
responseDescr :: String
|
||||
}
|
||||
|
||||
instance ConstructorName CRDoc where consName' CRDoc {consName} = consName
|
||||
|
||||
chatResponsesDocs :: [CRDoc]
|
||||
chatResponsesDocs = map toResp chatResponsesDocsData
|
||||
where
|
||||
toResp (consName, responseDescr)
|
||||
| consName == "CRChatCmdError" =
|
||||
let field = toAPIField consName $ FieldInfo "chatError" (ti "ChatError")
|
||||
responseType = ATUnionMember (dropPrefix "CR" consName) [field]
|
||||
in CRDoc {consName, responseType, responseDescr}
|
||||
| otherwise = case find ((consName ==) . consName') chatResponsesTypeInfo of
|
||||
Just RecordTypeInfo {fieldInfos} ->
|
||||
let fields = map (toAPIField consName) fieldInfos
|
||||
responseType = ATUnionMember (dropPrefix "CR" consName) fields
|
||||
in CRDoc {consName, responseType, responseDescr}
|
||||
Nothing -> error $ "Missing response type info for " <> consName
|
||||
|
||||
deriving instance Generic ChatResponse
|
||||
|
||||
chatResponsesTypeInfo :: [RecordTypeInfo]
|
||||
chatResponsesTypeInfo = recordTypesInfo @ChatResponse
|
||||
|
||||
chatResponsesDocsData :: [(ConsName, String)]
|
||||
chatResponsesDocsData =
|
||||
[ ("CRAcceptingContactRequest", "Contact request accepted"),
|
||||
("CRActiveUser", "Active user profile"),
|
||||
("CRChatItemNotChanged", "Message not changed"),
|
||||
("CRChatItemReaction", "Message reaction"),
|
||||
("CRChatItemUpdated", "Message updated"),
|
||||
("CRChatItemsDeleted", "Messages deleted"),
|
||||
("CRCmdOk", "Ok"),
|
||||
("CRChatCmdError", "Command error"), -- only used in WebSockets API, Haskell code uses Either, with error in Left
|
||||
("CRConnectionPlan", "Connection link information"),
|
||||
("CRContactAlreadyExists", ""),
|
||||
("CRContactConnectionDeleted", "Connection deleted"),
|
||||
("CRContactDeleted", ""),
|
||||
("CRContactRequestRejected", ""),
|
||||
("CRContactsList", "Contacts"),
|
||||
("CRGroupDeletedUser", "User deleted group"),
|
||||
("CRGroupLink", ""),
|
||||
("CRGroupLinkCreated", ""),
|
||||
("CRGroupLinkDeleted", ""),
|
||||
("CRGroupsList", "Groups"),
|
||||
("CRInvitation", "One-time invitation"),
|
||||
("CRLeftMemberUser", "User left group"),
|
||||
("CRMemberAccepted", "Member accepted to group"),
|
||||
("CRMembersBlockedForAllUser", "Members blocked for all by admin"),
|
||||
("CRMembersRoleUser", "Members role changed by user"),
|
||||
("CRNewChatItems", "New messages"),
|
||||
("CRRcvFileAccepted", "File accepted to be received"),
|
||||
("CRRcvFileAcceptedSndCancelled", "File accepted, but no longer sent"),
|
||||
("CRRcvFileCancelled", "Cancelled receiving file"),
|
||||
("CRSentConfirmation", "Confirmation sent to one-time invitation"),
|
||||
("CRSentGroupInvitation", "Group invitation sent"),
|
||||
("CRSentInvitation", "Invitation sent to contact address"),
|
||||
("CRSndFileCancelled", "Cancelled sending file"),
|
||||
("CRUserAcceptedGroupSent", "User accepted group invitation"),
|
||||
("CRUserContactLink", "User contact address"),
|
||||
("CRUserContactLinkCreated", "User contact address created"),
|
||||
("CRUserContactLinkDeleted", "User contact address deleted"),
|
||||
("CRUserContactLinkUpdated", "User contact address updated"),
|
||||
("CRUserDeletedMembers", "Members deleted"),
|
||||
("CRUserProfileUpdated", "User profile updated"),
|
||||
("CRUsersList", "Users")
|
||||
-- ("CRApiChat", "Chat and messages"),
|
||||
-- ("CRApiChats", "Chats with the most recent messages"),
|
||||
-- ("CRChatCleared", ""),
|
||||
-- ("CRChatItemInfo", "Message information"),
|
||||
-- ("CRChatItems", "The most recent messages"),
|
||||
-- ("CRConnectionAliasUpdated", ""),
|
||||
-- ("CRContactAliasUpdated", ""),
|
||||
-- ("CRContactPrefsUpdated", "Contact preferences updated"),
|
||||
-- ("CRContactRatchetSyncStarted", "Contact encryption synchronization started"),
|
||||
-- ("CRGroupAliasUpdated", ""),
|
||||
-- ("CRGroupCreated", ""),
|
||||
-- ("CRGroupMemberRatchetSyncStarted", "Member encryption synchronization started"),
|
||||
-- ("CRGroupMembers", ""),
|
||||
-- ("CRGroupUpdated", ""),
|
||||
-- ("CRItemsReadForChat", "Messages marked as read"),
|
||||
-- ("CRReactionMembers", "Members who set reaction on the message"),
|
||||
]
|
||||
|
||||
undocumentedResponses :: [ConsName]
|
||||
undocumentedResponses =
|
||||
[ "CRAgentQueuesInfo",
|
||||
"CRAgentServersSummary",
|
||||
"CRAgentSubs",
|
||||
"CRAgentSubsDetails",
|
||||
"CRAgentSubsTotal",
|
||||
"CRAgentWorkersDetails",
|
||||
"CRAgentWorkersSummary",
|
||||
"CRApiChat",
|
||||
"CRApiChats",
|
||||
"CRAppSettings",
|
||||
"CRArchiveExported",
|
||||
"CRArchiveImported",
|
||||
"CRBroadcastSent",
|
||||
"CRCallInvitations",
|
||||
"CRChatCleared",
|
||||
"CRChatHelp",
|
||||
"CRChatItemId",
|
||||
"CRChatItemInfo",
|
||||
"CRChatItems",
|
||||
"CRChatItemTTL",
|
||||
"CRChatRunning",
|
||||
"CRChats",
|
||||
"CRChatStarted",
|
||||
"CRChatStopped",
|
||||
"CRChatTags",
|
||||
"CRConnectionAliasUpdated",
|
||||
"CRConnectionIncognitoUpdated",
|
||||
"CRConnectionUserChanged",
|
||||
"CRConnectionVerified",
|
||||
"CRConnNtfMessages",
|
||||
"CRContactAliasUpdated",
|
||||
"CRContactCode",
|
||||
"CRContactInfo",
|
||||
"CRContactPrefsUpdated",
|
||||
"CRContactRatchetSyncStarted",
|
||||
"CRContactSwitchAborted",
|
||||
"CRContactSwitchStarted",
|
||||
"CRContactUserChanged",
|
||||
"CRCurrentRemoteHost",
|
||||
"CRCustomChatResponse",
|
||||
"CRDebugLocks",
|
||||
"CRFileTransferStatus",
|
||||
"CRFileTransferStatusXFTP",
|
||||
"CRForwardPlan",
|
||||
"CRGroupAliasUpdated",
|
||||
"CRGroupChatItemsDeleted",
|
||||
"CRGroupCreated",
|
||||
"CRGroupDescription",
|
||||
"CRGroupInfo",
|
||||
"CRGroupMemberCode",
|
||||
"CRGroupMemberInfo",
|
||||
"CRGroupMemberRatchetSyncStarted",
|
||||
"CRGroupMembers",
|
||||
"CRGroupMemberSwitchAborted",
|
||||
"CRGroupMemberSwitchStarted",
|
||||
"CRGroupProfile",
|
||||
"CRGroupUpdated",
|
||||
"CRGroupUserChanged",
|
||||
"CRItemsReadForChat",
|
||||
"CRJoinedGroupMember",
|
||||
"CRMemberSupportChatDeleted",
|
||||
"CRMemberSupportChats",
|
||||
"CRNetworkConfig",
|
||||
"CRNetworkStatuses",
|
||||
"CRNewMemberContact",
|
||||
"CRNewMemberContactSentInv",
|
||||
"CRNewPreparedChat",
|
||||
"CRNtfConns",
|
||||
"CRNtfToken",
|
||||
"CRNtfTokenStatus",
|
||||
"CRQueueInfo",
|
||||
"CRRcvStandaloneFileCreated",
|
||||
"CRReactionMembers",
|
||||
"CRRemoteCtrlConnected",
|
||||
"CRRemoteCtrlConnecting",
|
||||
"CRRemoteCtrlList",
|
||||
"CRRemoteFileStored",
|
||||
"CRRemoteHostList",
|
||||
"CRRemoteHostStarted",
|
||||
"CRSentInvitationToContact",
|
||||
"CRServerOperatorConditions",
|
||||
"CRServerTestResult",
|
||||
"CRSlowSQLQueries",
|
||||
"CRSndStandaloneFileCreated",
|
||||
"CRSQLResult",
|
||||
"CRStandaloneFileInfo",
|
||||
"CRStartedConnectionToContact",
|
||||
"CRStartedConnectionToGroup",
|
||||
"CRTagsUpdated",
|
||||
"CRUsageConditions",
|
||||
"CRUserPrivacy",
|
||||
"CRUserProfile",
|
||||
"CRUserProfileImage",
|
||||
"CRUserProfileNoChange",
|
||||
"CRUserServers",
|
||||
"CRUserServersValidation",
|
||||
"CRVersionInfo",
|
||||
"CRWelcome"
|
||||
]
|
||||
@@ -0,0 +1,220 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module API.Docs.Syntax where
|
||||
|
||||
import API.Docs.Syntax.Types
|
||||
import API.Docs.Types
|
||||
import API.TypeInfo
|
||||
import Data.List (find, intercalate)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
||||
docSyntaxText :: TypeAndFields -> Expr -> Text
|
||||
docSyntaxText r@(tag, _) = T.pack . go Nothing
|
||||
where
|
||||
go param = \case
|
||||
Concat exs -> concatMap (go param) exs
|
||||
Const s -> s
|
||||
Param p ->
|
||||
withParamType r param p $ \case
|
||||
ATDef td -> strSyntax td
|
||||
ATOptional (ATDef td) -> strSyntax td
|
||||
_ -> defSyntax Nothing
|
||||
where
|
||||
strSyntax (APITypeDef typeName t)
|
||||
| typeHasSyntax typeName = "<str(" <> paramName param p <> ")>"
|
||||
| otherwise = defSyntax (Just t)
|
||||
defSyntax = \case
|
||||
Just (ATDEnum ms) -> intercalate "|" $ L.toList ms
|
||||
_ -> "<" <> paramName param p <> ">"
|
||||
Optional exN exJ p ->
|
||||
withParamType r param p $ \case
|
||||
ATOptional {}
|
||||
| exN == "" -> "[" <> go (Just p) exJ <> "]"
|
||||
| otherwise -> go param exN <> "|" <> go (Just p) exJ
|
||||
_ -> paramError r param p "is not optional"
|
||||
Choice p opts else' ->
|
||||
withParamType r param p $ \case
|
||||
ATDef td -> choiceSyntax td
|
||||
ATOptional (ATDef td) -> choiceSyntax td
|
||||
_ -> paramError r param p "is not union type"
|
||||
where
|
||||
choiceSyntax = \case
|
||||
APITypeDef _ (ATDUnion _) -> choices
|
||||
APITypeDef _ (ATDEnum _) -> choices
|
||||
_ -> paramError r param p "is not union or enum type"
|
||||
choices = (if null optsSyntax then "" else optsSyntax <> "|") <> go param else'
|
||||
where
|
||||
optsSyntax = intercalate "|" (mapMaybe ((\s -> if null s then Nothing else Just s) . go param . snd) (L.toList opts))
|
||||
Join c p ->
|
||||
withParamType r param p $ \case
|
||||
ATArray {} -> let n = paramName param p in "<" <> n <> "[0]>[" <> [c] <> "<" <> n <> "[1]>...]"
|
||||
_ -> paramError r param p "is not array"
|
||||
Json p ->
|
||||
withParamType r param p $ \_ -> "<json(" <> paramName param p <> ")>"
|
||||
OnOff p -> withBoolParam r param p "on|off"
|
||||
OnOffParam name p def_
|
||||
| null name -> error $ fstToUpper tag <> ": on/off parameter " <> paramName param p <> " has empty name"
|
||||
| otherwise -> case def_ of
|
||||
Just def -> withOptBoolParam r param p $ \_ -> "[ " <> name <> "=" <> onOff <> "]"
|
||||
where
|
||||
onOff = if def then "off" else "on"
|
||||
Nothing -> withOptBoolParam r param p $ \optional -> if optional then "[" <> res <> "]" else res
|
||||
where
|
||||
res = " " <> name <> "=on|off"
|
||||
|
||||
typeHasSyntax :: String -> Bool
|
||||
typeHasSyntax typeName = case find ((typeName ==) . docTypeName) chatTypesDocs of
|
||||
Just CTDoc {typeSyntax} -> typeSyntax /= ""
|
||||
_ -> False
|
||||
|
||||
paramError :: TypeAndFields -> Maybe ExprParam -> ExprParam -> String -> String
|
||||
paramError (tag, _) param p err = error $ fstToUpper tag <> ": " <> paramName param p <> " " <> err
|
||||
|
||||
withParamType :: TypeAndFields -> Maybe ExprParam -> ExprParam -> (APIType -> String) -> String
|
||||
withParamType r@(_, params) param p f = case find ((paramName param p ==) . fieldName') params of
|
||||
Just APIRecordField {typeInfo} -> f typeInfo
|
||||
Nothing -> paramError r param p "is unknown"
|
||||
|
||||
withBoolParam :: TypeAndFields -> Maybe ExprParam -> ExprParam -> String -> String
|
||||
withBoolParam r param p s =
|
||||
withParamType r param p $ \case
|
||||
ATPrim (PT TBool) -> s
|
||||
_ -> paramError r param p "is not boolean"
|
||||
|
||||
withOptBoolParam :: TypeAndFields -> Maybe ExprParam -> ExprParam -> (Bool -> String) -> String
|
||||
withOptBoolParam r param p f =
|
||||
withParamType r param p $ \case
|
||||
ATPrim (PT TBool) -> f False
|
||||
(ATOptional (ATPrim (PT TBool))) -> f True
|
||||
_ -> paramError r param p "is not [optional] boolean"
|
||||
|
||||
jsSyntaxText :: TypeAndFields -> Expr -> Text
|
||||
jsSyntaxText r = T.replace "' + '" "" . T.pack . go Nothing True
|
||||
where
|
||||
go param top = \case
|
||||
Concat exs -> intercalate " + " $ map (go param False) $ L.toList exs
|
||||
Const s -> "'" <> escapeChar '\'' s <> "'"
|
||||
Param p ->
|
||||
withParamType r param p $ \case
|
||||
ATDef td -> toStringSyntax td
|
||||
ATOptional (ATDef td) -> toStringSyntax td
|
||||
_ -> paramName param p
|
||||
where
|
||||
toStringSyntax (APITypeDef typeName _)
|
||||
| typeHasSyntax typeName = paramName param p <> ".toString()"
|
||||
| otherwise = paramName param p
|
||||
Optional exN exJ p -> open <> n <> " ? " <> go (Just p) False exJ <> " : " <> nothing <> close
|
||||
where
|
||||
n = paramName param p
|
||||
nothing = if exN == "" then "''" else go param False exN
|
||||
Choice p opts else' ->
|
||||
withParamType r param p $ \case
|
||||
ATDef td -> choiceSyntax td
|
||||
ATOptional (ATDef td) -> choiceSyntax td
|
||||
_ -> paramError r param p "is not union type"
|
||||
where
|
||||
choiceSyntax = \case
|
||||
APITypeDef _ (ATDUnion _) -> choices "type"
|
||||
APITypeDef _ (ATDEnum _) -> choices "self"
|
||||
_ -> paramError r param p "is not union type"
|
||||
choices var = open <> optsSyntax <> " : " <> go param top else' <> close
|
||||
where
|
||||
optsSyntax = intercalate " : " $ map (\(tag, ex) -> var <> " == '" <> tag <> "' ? " <> go param top ex) $ L.toList opts
|
||||
Join c p -> paramName param p <> ".join('" <> [c] <> "')"
|
||||
Json p -> "JSON.stringify(" <> paramName param p <> ")"
|
||||
OnOff p -> open <> paramName param p <> " ? 'on' : 'off'" <> close
|
||||
OnOffParam name p def_ -> case def_ of
|
||||
Nothing ->
|
||||
withOptBoolParam r param p $ \optional ->
|
||||
if optional
|
||||
then "(typeof " <> n <> " == 'boolean' ? " <> res <> " : '')"
|
||||
else res
|
||||
where
|
||||
n = paramName param p
|
||||
res = "' " <> name <> "=' + (" <> n <> " ? 'on' : 'off')"
|
||||
Just def
|
||||
| def -> open <> "!" <> n <> " ? ' " <> name <> "=off' : ''" <> close
|
||||
| otherwise -> open <> n <> " ? ' " <> name <> "=on' : ''" <> close
|
||||
where
|
||||
n = paramName param p
|
||||
where
|
||||
open = if top then "" else "("
|
||||
close = if top then "" else ")"
|
||||
|
||||
escapeChar :: Char -> String -> String
|
||||
escapeChar c s
|
||||
| c `elem` s = concatMap (\c' -> if c' == c then ['\\', c] else [c]) s
|
||||
| otherwise = s
|
||||
|
||||
pySyntaxText :: TypeAndFields -> Expr -> Text
|
||||
pySyntaxText r = T.pack . go Nothing True
|
||||
where
|
||||
go param top = \case
|
||||
Concat exs -> intercalate " + " $ map (go param False) $ L.toList exs
|
||||
Const s -> "'" <> escapeChar '\'' s <> "'"
|
||||
Param p ->
|
||||
withParamType r param p $ \case
|
||||
ATPrim (PT TString) -> paramName param p
|
||||
ATOptional (ATPrim (PT TString)) -> paramName param p
|
||||
_ -> "str(" <> paramName param p <> ")"
|
||||
Optional exN exJ p -> open <> "(" <> go (Just p) False exJ <> ") if " <> n <> " is not None else " <> nothing <> close
|
||||
where
|
||||
n = paramName param p
|
||||
nothing = if exN == "" then "''" else go param False exN
|
||||
Choice p opts else' ->
|
||||
withParamType r param p $ \case
|
||||
ATDef td -> choiceSyntax td
|
||||
ATOptional (ATDef td) -> choiceSyntax td
|
||||
_ -> paramError r param p "is not union type"
|
||||
where
|
||||
choiceSyntax = \case
|
||||
APITypeDef _ (ATDUnion _) -> choices "type"
|
||||
APITypeDef _ (ATDEnum _) -> choices "self"
|
||||
_ -> paramError r param p "is not union type"
|
||||
choices var = open <> optsSyntax <> " else " <> go param top else' <> close
|
||||
where
|
||||
optsSyntax = intercalate " else " $ map (\(tag, ex) -> go param top ex <> " if " <> var' <> " == '" <> tag <> "'") $ L.toList opts
|
||||
var' =
|
||||
withParamType r param var $ \case
|
||||
ATPrim (PT TString) -> var
|
||||
ATOptional (ATPrim (PT TString)) -> var
|
||||
_ -> "str(" <> var <> ")"
|
||||
Join c p ->
|
||||
withParamType r param p $ \case
|
||||
ATArray {elemType = ATPrim (PT TString)} -> "'" <> [c] <> "'.join(" <> paramName param p <> ")"
|
||||
_ -> "'" <> [c] <> "'.join(map(str, " <> paramName param p <> "))"
|
||||
Json p -> "json.dumps(" <> paramName param p <> ")"
|
||||
OnOff p -> open <> "'on' if " <> paramName param p <> " else 'off'" <> close
|
||||
OnOffParam name p def_ -> case def_ of
|
||||
Nothing ->
|
||||
withOptBoolParam r param p $ \optional ->
|
||||
if optional
|
||||
then "((" <> res <> ") if " <> n <> " is not None else '')"
|
||||
else res
|
||||
where
|
||||
n = paramName param p
|
||||
res = "' " <> name <> "=' + ('on' if " <> n <> " else 'off')"
|
||||
Just def
|
||||
| def -> open <> "' " <> name <> "=off' if not " <> n <> " else ''" <> close
|
||||
| otherwise -> open <> "' " <> name <> "=on' if " <> n <> " else ''" <> close
|
||||
where
|
||||
n = paramName param p
|
||||
where
|
||||
open = if top then "" else "("
|
||||
close = if top then "" else ")"
|
||||
|
||||
paramName :: Maybe ExprParam -> ExprParam -> String
|
||||
paramName param_ p = case param_ of
|
||||
Just param | p == "$0" -> param
|
||||
_ -> p
|
||||
@@ -0,0 +1,30 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module API.Docs.Syntax.Types where
|
||||
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Semigroup
|
||||
import Data.String
|
||||
|
||||
type ExprParam = String -- param name
|
||||
|
||||
data Expr
|
||||
= Concat (NonEmpty Expr)
|
||||
| Const String
|
||||
| Param ExprParam
|
||||
| Optional Expr Expr ExprParam -- Nothing expr, Just expr (using [$0] as ExprParam), optional param
|
||||
| Choice ExprParam (NonEmpty (String, Expr)) Expr -- union type param, choices for "type" tags, else
|
||||
| Join Char ExprParam
|
||||
| Json ExprParam
|
||||
| OnOff ExprParam -- does not include leading space
|
||||
| OnOffParam String ExprParam (Maybe Bool) -- name, param, default. Includes leading space in all cases. Name must not be empty
|
||||
deriving (Eq, Show)
|
||||
|
||||
isConst :: Expr -> Bool
|
||||
isConst = \case
|
||||
Const _ -> True
|
||||
_ -> False
|
||||
|
||||
instance IsString Expr where fromString = Const
|
||||
|
||||
instance Semigroup Expr where sconcat = Concat
|
||||
@@ -0,0 +1,557 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module API.Docs.Types where
|
||||
|
||||
import API.Docs.Syntax.Types
|
||||
import API.TypeInfo
|
||||
import Data.Bifunctor (second)
|
||||
import Data.Char (isUpper, toLower, toUpper)
|
||||
import Data.List (find, mapAccumL, sortOn)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Messages.CIContent.Events
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Store.Groups
|
||||
import Simplex.Chat.Store.Profiles
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Types.UITheme
|
||||
import Simplex.FileTransfer.Transport
|
||||
import Simplex.FileTransfer.Types hiding (RcvFileStatus) -- the type with the same name is used in simplex-chat.
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Client
|
||||
import Simplex.Messaging.Crypto.File
|
||||
import Simplex.Messaging.Parsers (dropPrefix, fstToLower)
|
||||
import Simplex.Messaging.Protocol (BlockingInfo (..), BlockingReason (..), CommandError (..), ErrorType (..), ProxyError (..))
|
||||
import Simplex.Messaging.Transport
|
||||
import Simplex.RemoteControl.Types
|
||||
import System.Console.ANSI.Types (Color (..))
|
||||
|
||||
data CTDoc = CTDoc
|
||||
{ typeDef :: APITypeDef,
|
||||
typeSyntax :: Expr, -- syntax for types used in commands
|
||||
typeDescr :: Text
|
||||
}
|
||||
|
||||
docTypeName :: CTDoc -> String
|
||||
docTypeName CTDoc {typeDef = APITypeDef name _} = name
|
||||
|
||||
toAPIField :: ConsName -> FieldInfo -> APIRecordField
|
||||
toAPIField typeName = snd . toAPIField_ typeName (S.empty, chatTypeDefs)
|
||||
|
||||
chatTypeDefs :: M.Map String APITypeDef
|
||||
chatTypeDefs = M.fromList $ map (\CTDoc {typeDef = td@(APITypeDef name _)} -> (name, td)) chatTypesDocs
|
||||
|
||||
chatTypesDocs :: [CTDoc]
|
||||
chatTypesDocs = sortOn docTypeName $! snd $! mapAccumL toCTDoc (S.empty, M.empty) chatTypesDocsData
|
||||
where
|
||||
toCTDoc !tds sumTypeInfo@(STI typeName _, _, _, _, typeSyntax, typeDescr) =
|
||||
let (tds', td_) = toTypeDef tds sumTypeInfo
|
||||
in case td_ of
|
||||
Just typeDef -> (tds', CTDoc {typeDef, typeSyntax, typeDescr})
|
||||
Nothing -> error $ "Recursive type: " <> typeName
|
||||
|
||||
toTypeDef :: (S.Set String, M.Map String APITypeDef) -> (SumTypeInfo, SumTypeJsonEncoding, String, [ConsName], Expr, Text) -> ((S.Set String, M.Map String APITypeDef), Maybe APITypeDef)
|
||||
toTypeDef acc@(!visited, !typeDefs) (STI typeName allConstrs, jsonEncoding, consPrefix, hideConstrs, _, _) =
|
||||
let constrs = filter ((`notElem` hideConstrs) . consName') allConstrs
|
||||
in case M.lookup typeName typeDefs of
|
||||
Just td -> (acc, Just td)
|
||||
Nothing
|
||||
| S.member typeName visited -> (acc, Nothing)
|
||||
| otherwise -> case jsonEncoding of
|
||||
STRecord -> case constrs of
|
||||
[RecordTypeInfo {fieldInfos}] ->
|
||||
let fields = fromMaybe (error $ "Record type without fields: " <> typeName) $ L.nonEmpty fieldInfos
|
||||
((visited', typeDefs'), fields') = mapAccumL (toAPIField_ typeName) (S.insert typeName visited, typeDefs) fields
|
||||
td = APITypeDef typeName $ ATDRecord fields'
|
||||
in ((S.insert typeName visited', M.insert typeName td typeDefs'), Just td)
|
||||
_ -> error $ "Record type with " <> show (length constrs) <> " constructors: " <> typeName
|
||||
STUnion -> if length constrs > 1 then toUnionType constrs else unionError constrs
|
||||
STUnion1 -> if length constrs == 1 then toUnionType constrs else unionError constrs
|
||||
STEnum -> if length constrs > 1 then toEnumType constrs else enumError constrs
|
||||
STEnum1 -> if length constrs == 1 then toEnumType constrs else enumError constrs
|
||||
STEnum' f
|
||||
| length constrs <= 1 -> enumError constrs
|
||||
| null consPrefix -> toEnumType_ f constrs
|
||||
| otherwise -> error $ "Enum type with custom encoding and prefix: " <> typeName
|
||||
where
|
||||
toUnionType constrs =
|
||||
let ((visited', typeDefs'), members) = mapAccumL toUnionMember (S.insert typeName visited, typeDefs) $ fromMaybe (unionError constrs) $ L.nonEmpty constrs
|
||||
td = APITypeDef typeName $ ATDUnion members
|
||||
in ((S.insert typeName visited', M.insert typeName td typeDefs'), Just td)
|
||||
toUnionMember tds RecordTypeInfo {consName, fieldInfos} =
|
||||
let memberTag = normalizeConsName consPrefix consName
|
||||
in second (ATUnionMember memberTag) $ mapAccumL (toAPIField_ typeName) tds fieldInfos
|
||||
unionError constrs = error $ "Union type with " <> show (length constrs) <> " constructor(s): " <> typeName
|
||||
toEnumType = toEnumType_ $ normalizeConsName consPrefix
|
||||
toEnumType_ f constrs =
|
||||
let members = L.map toEnumMember $ fromMaybe (enumError constrs) $ L.nonEmpty constrs
|
||||
td = APITypeDef typeName $ ATDEnum members
|
||||
in ((S.insert typeName visited, M.insert typeName td typeDefs), Just td)
|
||||
where
|
||||
toEnumMember RecordTypeInfo {consName, fieldInfos} = case fieldInfos of
|
||||
[] -> f consName
|
||||
_ -> error $ "Enum type with fields in constructor: " <> typeName <> ", " <> consName
|
||||
enumError constrs = error $ "Enum type with " <> show (length constrs) <> " constructor(s): " <> typeName
|
||||
|
||||
toAPIField_ :: ConsName -> (S.Set String, M.Map String APITypeDef) -> FieldInfo -> ((S.Set String, M.Map String APITypeDef), APIRecordField)
|
||||
toAPIField_ typeName tds (FieldInfo fieldName typeInfo) = second (APIRecordField fieldName) $ toAPIType typeInfo
|
||||
where
|
||||
toAPIType :: TypeInfo -> ((S.Set String, M.Map String APITypeDef), APIType)
|
||||
toAPIType = \case
|
||||
TIType (ST name _) -> apiTypeForName name
|
||||
TIOptional tInfo -> second ATOptional $ toAPIType tInfo
|
||||
TIArray {elemType, nonEmpty} -> second (`ATArray`nonEmpty) $ toAPIType elemType
|
||||
TIMap {keyType = ST name _, valueType}
|
||||
| name `elem` primitiveTypes -> second (ATMap (PT name)) $ toAPIType valueType
|
||||
| otherwise -> error $ "Non-primitive key type in " <> typeName <> ", " <> fieldName
|
||||
apiTypeForName :: String -> ((S.Set String, M.Map String APITypeDef), APIType)
|
||||
apiTypeForName name
|
||||
| name `elem` primitiveTypes = (tds, ATPrim $ PT name)
|
||||
| otherwise = case M.lookup name $ snd tds of
|
||||
Just td -> (tds, ATDef td)
|
||||
Nothing -> case find (\(STI name' _, _, _, _, _, _) -> name == name') chatTypesDocsData of
|
||||
Just sumTypeInfo ->
|
||||
let (tds', td_) = toTypeDef tds sumTypeInfo -- recursion to outer function, loops are resolved via type defs map lookup
|
||||
in case td_ of
|
||||
Just td -> (tds', ATDef td)
|
||||
Nothing -> (tds', ATRef name)
|
||||
Nothing -> error $ "Undefined type: " <> name
|
||||
|
||||
data SumTypeJsonEncoding = STRecord | STUnion | STUnion1 | STEnum | STEnum1 | STEnum' (ConsName -> String)
|
||||
|
||||
dropPfxSfx :: String -> String -> ConsName -> String
|
||||
dropPfxSfx pfx sfx = dropSuffix sfx . dropPrefix pfx
|
||||
|
||||
fstToUpper :: String -> String
|
||||
fstToUpper "" = ""
|
||||
fstToUpper (h : t) = toUpper h : t
|
||||
|
||||
consLower :: String -> ConsName -> String
|
||||
consLower pfx = map toLower . dropPrefix pfx
|
||||
|
||||
consSep :: String -> Char -> ConsName -> String
|
||||
consSep pfx sep = foldr (\c s -> if isUpper c then sep : toLower c : s else c : s) "" . dropPrefix pfx
|
||||
|
||||
dropSuffix :: String -> String -> String
|
||||
dropSuffix sfx s =
|
||||
let (s', sfx') = splitAt (length s - length sfx) s
|
||||
in fstToLower $ if sfx' == sfx then s' else s
|
||||
|
||||
normalizeConsName :: String -> ConsName -> ConsName
|
||||
normalizeConsName pfx consName
|
||||
| null pfx && uppercase = consName
|
||||
| null pfx = fstToLower consName
|
||||
| uppercase = map toUpper noPfx
|
||||
| otherwise = noPfx
|
||||
where
|
||||
uppercase = all (\c -> isUpper c || c == '_') consName
|
||||
noPfx = dropPrefix pfx consName
|
||||
|
||||
-- making chatDir optional because clients use CIDirection? instead of CIQDirection (the type is replaced in Types.hs)
|
||||
ciQuoteType :: SumTypeInfo
|
||||
ciQuoteType =
|
||||
let st@(STI _ records) = sti @(CIQuote 'CTDirect)
|
||||
optChatDir f@(FieldInfo n t) = if n == "chatDir" then FieldInfo n (TIOptional t) else f
|
||||
updateRecord (RecordTypeInfo name fields) = RecordTypeInfo name $ map optChatDir fields
|
||||
in st {recordTypes = map updateRecord records} -- need to map even though there is one constructor in this type
|
||||
|
||||
chatTypesDocsData :: [(SumTypeInfo, SumTypeJsonEncoding, String, [ConsName], Expr, Text)]
|
||||
chatTypesDocsData =
|
||||
[ ((sti @(Chat 'CTDirect)) {typeName = "AChat"}, STRecord, "", [], "", ""),
|
||||
((sti @JSONChatInfo) {typeName = "ChatInfo"}, STUnion, "JCInfo", [], "", ""),
|
||||
((sti @JSONCIContent) {typeName = "CIContent"}, STUnion, "JCI", [], "", ""),
|
||||
((sti @JSONCIDeleted) {typeName = "CIDeleted"}, STUnion, "JCID", [], "", ""),
|
||||
((sti @JSONCIDirection) {typeName = "CIDirection"}, STUnion, "JCI", [], "", ""),
|
||||
((sti @JSONCIFileStatus) {typeName = "CIFileStatus"}, STUnion, "JCIFS", [], "", ""),
|
||||
((sti @JSONCIStatus) {typeName = "CIStatus"}, STUnion, "JCIS", [], "", ""),
|
||||
(ciQuoteType, STRecord, "", [], "", ""),
|
||||
(STI "AChatItem" [RecordTypeInfo "AChatItem" [FieldInfo "chatInfo" (ti "ChatInfo"), FieldInfo "chatItem" (ti "ChatItem")]], STRecord, "", [], "", ""),
|
||||
(STI "ACIReaction" [RecordTypeInfo "ACIReaction" [FieldInfo "chatInfo" (ti "ChatInfo"), FieldInfo "chatReaction" (ti "CIReaction")]], STRecord, "", [], "", ""),
|
||||
-- (STI "JSONObject" [], STRecord, "", [], "Arbitrary JSON object."),
|
||||
-- (STI "UTCTime" [], STRecord, "", [], "Timestampe in ISO8601 format as string."),
|
||||
(STI "VersionRange" [RecordTypeInfo "VersionRange" [FieldInfo "minVersion" (ti TInt), FieldInfo "maxVersion" (ti TInt)]], STRecord, "", [], "", ""),
|
||||
(sti @(ChatItem 'CTDirect 'MDSnd), STRecord, "", [], "", ""),
|
||||
(sti @(CIFile 'MDSnd), STRecord, "", [], "", ""),
|
||||
(sti @(CIMeta 'CTDirect 'MDSnd), STRecord, "", [], "", ""),
|
||||
(sti @(CIReaction 'CTDirect 'MDSnd), STRecord, "", [], "", ""),
|
||||
(sti @(ContactUserPref SimplePreference), STUnion, "CUP", [], "", ""),
|
||||
(sti @(ContactUserPreference SimplePreference), STRecord, "", [], "", ""),
|
||||
(sti @(CreatedConnLink 'CMContact), STRecord, "", [], Param "connFullLink" <> Optional "" (" " <> Param "$0") "connShortLink", ""),
|
||||
(sti @AddressSettings, STRecord, "", [], "", ""),
|
||||
(sti @AgentCryptoError, STUnion, "", [], "", ""),
|
||||
(sti @AgentErrorType, STUnion, "", [], "", ""),
|
||||
(sti @AutoAccept, STRecord, "", [], "", ""),
|
||||
(sti @BlockingInfo, STRecord, "", [], "", ""),
|
||||
(sti @BlockingReason, STEnum, "BR", [], "", ""),
|
||||
(sti @BrokerErrorType, STUnion, "", [], "", ""),
|
||||
(sti @BusinessChatInfo, STRecord, "", [], "", ""),
|
||||
(sti @BusinessChatType, STEnum, "BC", [], "", ""),
|
||||
(sti @ChatDeleteMode, STUnion, "CDM", [], Param "type" <> Choice "self" [("messages", "")] (OnOffParam "notify" "notify" (Just True)), ""),
|
||||
(sti @ChatError, STUnion, "Chat", ["ChatErrorDatabase", "ChatErrorRemoteHost", "ChatErrorRemoteCtrl"], "", ""),
|
||||
(sti @ChatErrorType, STUnion, "CE", ["CEContactNotFound", "CEServerProtocol", "CECallState", "CEInvalidChatMessage"], "", ""),
|
||||
(sti @ChatFeature, STEnum, "CF", [], "", ""),
|
||||
(sti @ChatItemDeletion, STRecord, "", [], "", "Message deletion result."),
|
||||
(sti @ChatRef, STRecord, "", [], Param "chatType" <> Param "chatId" <> Optional "" (Param "$0") "chatScope", "Used in API commands. Chat scope can only be passed with groups."),
|
||||
(sti @ChatSettings, STRecord, "", [], "", ""),
|
||||
(sti @ChatStats, STRecord, "", [], "", ""),
|
||||
(sti @ChatType, STEnum, "CT", ["CTContactRequest", "CTContactConnection"], Choice "self" [("contact", "@"), ("group", "#"), ("local", "*")] "", ""),
|
||||
(sti @ChatWallpaper, STRecord, "", [], "", ""),
|
||||
(sti @ChatWallpaperScale, STEnum, "CWS", [], "", ""),
|
||||
(sti @CICallStatus, STEnum, "CISCall", [], "", ""),
|
||||
(sti @CIDeleteMode, STEnum, "CIDM", [], "", ""),
|
||||
(sti @CIForwardedFrom, STUnion, "CIFF", [], "", ""),
|
||||
(sti @CIGroupInvitation, STRecord, "", [], "", ""),
|
||||
(sti @CIGroupInvitationStatus, STEnum, "CIGIS", [], "", ""),
|
||||
(sti @CIMention, STRecord, "", [], "", ""),
|
||||
(sti @CIMentionMember, STRecord, "", [], "", ""),
|
||||
(sti @CIReactionCount, STRecord, "", [], "", ""),
|
||||
(sti @CITimed, STRecord, "", [], "", ""),
|
||||
(sti @Color, STEnum, "", [], "", ""),
|
||||
(sti @CommandError, STUnion, "", [], "", ""),
|
||||
(sti @CommandErrorType, STUnion, "", [], "", ""),
|
||||
(sti @ComposedMessage, STRecord, "", [], "", ""),
|
||||
(sti @Connection, STRecord, "", [], "", ""),
|
||||
(sti @ConnectionEntity, STUnion, "", [], "", ""),
|
||||
(sti @ConnectionErrorType, STUnion, "", [], "", ""),
|
||||
(sti @ConnectionMode, (STEnum' $ take 3 . consLower "CM"), "", [], "", ""),
|
||||
(sti @ConnectionPlan, STUnion, "CP", [], "", ""),
|
||||
(sti @ConnStatus, (STEnum' $ consSep "Conn" '-'), "", [], "", ""),
|
||||
(sti @ConnType, (STEnum' $ consSep "Conn" '_'), "", ["ConnSndFile", "ConnRcvFile"], "", ""),
|
||||
(sti @Contact, STRecord, "", [], "", ""),
|
||||
(sti @ContactAddressPlan, STUnion, "CAP", [], "", ""),
|
||||
(sti @ContactShortLinkData, STRecord, "", [], "", ""),
|
||||
(sti @ContactStatus, STEnum, "CS", [], "", ""),
|
||||
(sti @ContactUserPreferences, STRecord, "", [], "", ""),
|
||||
(sti @CryptoFile, STRecord, "", [], "", ""),
|
||||
(sti @CryptoFileArgs, STRecord, "", [], "", ""),
|
||||
(sti @E2EInfo, STRecord, "", [], "", ""),
|
||||
(sti @ErrorType, STUnion, "", [], "", ""),
|
||||
(sti @FeatureAllowed, STEnum, "FA", [], "", ""),
|
||||
(sti @FileDescr, STRecord, "", [], "", ""),
|
||||
(sti @FileError, STUnion, "FileErr", [], "", ""),
|
||||
(sti @FileErrorType, STUnion, "", [], "", ""),
|
||||
(sti @FileInvitation, STRecord, "", [], "", ""),
|
||||
(sti @FileProtocol, (STEnum' $ consLower "FP"), "", [], "", ""),
|
||||
(sti @FileStatus, STEnum, "FS", [], "", ""),
|
||||
(sti @FileTransferMeta, STRecord, "", [], "", ""),
|
||||
(sti @Format, STUnion, "", [], "", ""),
|
||||
(sti @FormattedText, STRecord, "", [], "", ""),
|
||||
(sti @FullGroupPreferences, STRecord, "", [], "", ""),
|
||||
(sti @FullPreferences, STRecord, "", [], "", ""),
|
||||
(sti @GroupChatScope, STUnion1, "GCS", [], "(_support" <> Optional "" (":" <> Param "$0") "groupMemberId_" <> ")", ""),
|
||||
(sti @GroupChatScopeInfo, STUnion1, "GCSI", [], "", ""),
|
||||
(sti @GroupFeature, STEnum, "GF", [], "", ""),
|
||||
(sti @GroupFeatureEnabled, STEnum, "FE", [], "", ""),
|
||||
(sti @GroupInfo, STRecord, "", [], "", ""),
|
||||
(sti @GroupInfoSummary, STRecord, "", [], "", ""),
|
||||
(sti @GroupLink, STRecord, "", [], "", ""),
|
||||
(sti @GroupLinkPlan, STUnion, "GLP", [], "", ""),
|
||||
(sti @GroupMember, STRecord, "", [], "", ""),
|
||||
(sti @GroupMemberAdmission, STRecord, "", [], "", ""),
|
||||
(sti @GroupMemberCategory, (STEnum' $ dropPfxSfx "GC" "Member"), "", [], "", ""),
|
||||
(sti @GroupMemberRef, STRecord, "", [], "", ""),
|
||||
(sti @GroupMemberRole, STEnum, "GR", [], "", ""),
|
||||
(sti @GroupMemberSettings, STRecord, "", [], "", ""),
|
||||
(sti @GroupMemberStatus, (STEnum' $ (\case "group_deleted" -> "deleted"; "intro_invited" -> "intro-inv"; s -> s) . consSep "GSMem" '_'), "", [], "", ""),
|
||||
(sti @GroupPreference, STRecord, "", [], "", ""),
|
||||
(sti @GroupPreferences, STRecord, "", [], "", ""),
|
||||
(sti @GroupProfile, STRecord, "", [], "", ""),
|
||||
(sti @GroupShortLinkData, STRecord, "", [], "", ""),
|
||||
(sti @GroupSummary, STRecord, "", [], "", ""),
|
||||
(sti @GroupSupportChat, STRecord, "", [], "", ""),
|
||||
(sti @HandshakeError, STEnum, "", [], "", ""),
|
||||
(sti @InlineFileMode, STEnum, "IFM", [], "", ""),
|
||||
(sti @InvitationLinkPlan, STUnion, "ILP", [], "", ""),
|
||||
(sti @InvitedBy, STUnion, "IB", [], "", ""),
|
||||
(sti @LinkContent, STUnion, "LC", [], "", ""),
|
||||
(sti @LinkPreview, STRecord, "", [], "", ""),
|
||||
(sti @LocalProfile, STRecord, "", [], "", ""),
|
||||
(sti @MemberCriteria, STEnum1, "MC", [], "", ""),
|
||||
(sti @MsgChatLink, STUnion, "MCL", [], "", "Connection link sent in a message - only short links are allowed."),
|
||||
(sti @MsgContent, STUnion, "MC", [], "", ""),
|
||||
(sti @MsgDecryptError, STEnum, "MDE", [], "", ""),
|
||||
(sti @MsgDirection, STEnum, "MD", [], "", ""),
|
||||
(sti @MsgErrorType, STUnion, "", [], "", ""), -- check, may be correct?
|
||||
(sti @MsgFilter, STEnum, "MF", [], "", ""),
|
||||
(sti @MsgReaction, STUnion, "MR", [], "", ""),
|
||||
(sti @MsgReceiptStatus, STEnum, "MR", [], "", ""),
|
||||
(sti @NewUser, STRecord, "", [], "", ""),
|
||||
(sti @NoteFolder, STRecord, "", [], "", ""),
|
||||
(sti @PendingContactConnection, STRecord, "", [], "", ""),
|
||||
(sti @PrefEnabled, STRecord, "", [], "", ""),
|
||||
(sti @Preferences, STRecord, "", [], "", ""),
|
||||
(sti @PreparedContact, STRecord, "", [], "", ""),
|
||||
(sti @PreparedGroup, STRecord, "", [], "", ""),
|
||||
(sti @Profile, STRecord, "", [], "", ""),
|
||||
(sti @ProxyClientError, STUnion, "Proxy", [], "", ""),
|
||||
(sti @ProxyError, STUnion, "", [], "", ""),
|
||||
(sti @RatchetSyncState, STEnum, "RS", [], "", ""),
|
||||
(sti @RCErrorType, STUnion, "RCE", [], "", ""),
|
||||
(sti @RcvConnEvent, STUnion, "RCE", [], "", ""),
|
||||
(sti @RcvDirectEvent, STUnion, "RDE", [], "", ""),
|
||||
(sti @RcvFileDescr, STRecord, "", [], "", ""),
|
||||
(sti @RcvFileInfo, STRecord, "", [], "", ""),
|
||||
(sti @RcvFileStatus, STUnion, "RFS", [], "", ""),
|
||||
(sti @RcvFileTransfer, STRecord, "", [], "", ""),
|
||||
(sti @RcvGroupEvent, STUnion, "RGE", [], "", ""),
|
||||
(sti @ReportReason, (STEnum' $ dropPfxSfx "RR" ""), "", ["RRUnknown"], "", ""),
|
||||
(sti @RoleGroupPreference, STRecord, "", [], "", ""),
|
||||
(sti @SecurityCode, STRecord, "", [], "", ""),
|
||||
(sti @SimplePreference, STRecord, "", [], "", ""),
|
||||
(sti @SimplexLinkType, STEnum, "XL", [], "", ""),
|
||||
(sti @SMPAgentError, STUnion, "", [], "", ""),
|
||||
(sti @SndCIStatusProgress, STEnum, "SSP", [], "", ""),
|
||||
(sti @SndConnEvent, STUnion, "SCE", [], "", ""),
|
||||
(sti @SndError, STUnion, "SndErr", [], "", ""),
|
||||
(sti @SndFileTransfer, STRecord, "", [], "", ""),
|
||||
(sti @SndGroupEvent, STUnion, "SGE", [], "", ""),
|
||||
(sti @SrvError, STUnion, "SrvErr", [], "", ""),
|
||||
(sti @StoreError, STUnion, "SE", [], "", ""),
|
||||
(sti @SwitchPhase, STEnum, "SP", [], "", ""),
|
||||
(sti @TimedMessagesGroupPreference, STRecord, "", [], "", ""),
|
||||
(sti @TimedMessagesPreference, STRecord, "", [], "", ""),
|
||||
(sti @TransportError, STUnion, "TE", [], "", ""),
|
||||
(sti @UIColorMode, STEnum, "UCM", [], "", ""),
|
||||
(sti @UIColors, STRecord, "", [], "", ""),
|
||||
(sti @UIThemeEntityOverride, STRecord, "", [], "", ""),
|
||||
(sti @UIThemeEntityOverrides, STRecord, "", [], "", ""),
|
||||
(sti @UpdatedMessage, STRecord, "", [], "", ""),
|
||||
(sti @User, STRecord, "", [], "", ""),
|
||||
(sti @UserContact, STRecord, "", [], "", ""),
|
||||
(sti @UserContactLink, STRecord, "", [], "", ""),
|
||||
(sti @UserContactRequest, STRecord, "", [], "", ""),
|
||||
(sti @UserInfo, STRecord, "", [], "", ""),
|
||||
(sti @UserProfileUpdateSummary, STRecord, "", [], "", ""),
|
||||
(sti @UserPwdHash, STRecord, "", [], "", ""),
|
||||
(sti @XFTPErrorType, STUnion, "", [], "", ""),
|
||||
(sti @XFTPRcvFile, STRecord, "", [], "", ""),
|
||||
(sti @XFTPSndFile, STRecord, "", [], "", "")
|
||||
|
||||
-- (sti @DatabaseError, STUnion, "DB", [], "", ""),
|
||||
-- (sti @ChatItemInfo, STRecord, "", [], "", ""),
|
||||
-- (sti @ChatItemVersion, STRecord, "", [], "", ""),
|
||||
-- (sti @ChatListQuery, STUnion, "CLQ", [], "", ""),
|
||||
-- (sti @ChatName, STRecord, "", [], "", ""),
|
||||
-- (sti @ChatPagination, STRecord, "CP", [], "", ""),
|
||||
-- (sti @ConnectionStats, STRecord, "", [], "", ""),
|
||||
-- (sti @Group, STRecord, "", [], "", ""),
|
||||
-- (sti @GroupSndStatus, STUnion, "GSS", [], "", ""),
|
||||
-- (sti @MemberDeliveryStatus, STRecord, "", [], "", ""),
|
||||
-- (sti @MemberReaction, STRecord, "", [], "", ""),
|
||||
-- (sti @MsgContentTag, (STEnum' $ dropPfxSfx "MC" '_'), "", ["MCUnknown_"], "", ""),
|
||||
-- (sti @NavigationInfo, STRecord, "", [], "", ""),
|
||||
-- (sti @PaginationByTime, STRecord, "", [], "", ""),
|
||||
-- (sti @RcvQueueInfo, STRecord, "", [], "", ""),
|
||||
-- (sti @RcvSwitchStatus, STEnum, "", [], "", ""), -- incorrect
|
||||
-- (sti @SendRef, STRecord, "", [], "", ""),
|
||||
-- (sti @SndQueueInfo, STRecord, "", [], "", ""),
|
||||
-- (sti @SndSwitchStatus, STEnum, "", [], "", ""), -- incorrect
|
||||
]
|
||||
|
||||
data SimplePreference = SimplePreference {allow :: FeatureAllowed} deriving (Generic)
|
||||
|
||||
data RoleGroupPreference = RoleGroupPreference {enable :: GroupFeatureEnabled, role :: Maybe GroupMemberRole} deriving (Generic)
|
||||
|
||||
deriving instance Generic (Chat c)
|
||||
deriving instance Generic (ChatItem c d)
|
||||
deriving instance Generic (CIFile d)
|
||||
deriving instance Generic (CIMeta c d)
|
||||
deriving instance Generic (CIQuote d)
|
||||
deriving instance Generic (CIReaction c d)
|
||||
deriving instance Generic (ContactUserPref p)
|
||||
deriving instance Generic (ContactUserPreference p)
|
||||
deriving instance Generic (CreatedConnLink m)
|
||||
deriving instance Generic AddressSettings
|
||||
deriving instance Generic AgentCryptoError
|
||||
deriving instance Generic AgentErrorType
|
||||
deriving instance Generic AutoAccept
|
||||
deriving instance Generic BlockingInfo
|
||||
deriving instance Generic BlockingReason
|
||||
deriving instance Generic BrokerErrorType
|
||||
deriving instance Generic BusinessChatInfo
|
||||
deriving instance Generic BusinessChatType
|
||||
deriving instance Generic ChatDeleteMode
|
||||
deriving instance Generic ChatError
|
||||
deriving instance Generic ChatErrorType
|
||||
deriving instance Generic ChatFeature
|
||||
deriving instance Generic ChatItemDeletion
|
||||
deriving instance Generic ChatRef
|
||||
deriving instance Generic ChatSettings
|
||||
deriving instance Generic ChatStats
|
||||
deriving instance Generic ChatType
|
||||
deriving instance Generic ChatWallpaper
|
||||
deriving instance Generic ChatWallpaperScale
|
||||
deriving instance Generic CICallStatus
|
||||
deriving instance Generic CIDeleteMode
|
||||
deriving instance Generic CIForwardedFrom
|
||||
deriving instance Generic CIGroupInvitation
|
||||
deriving instance Generic CIGroupInvitationStatus
|
||||
deriving instance Generic CIMention
|
||||
deriving instance Generic CIMentionMember
|
||||
deriving instance Generic CIReactionCount
|
||||
deriving instance Generic CITimed
|
||||
deriving instance Generic Color
|
||||
deriving instance Generic CommandError
|
||||
deriving instance Generic CommandErrorType
|
||||
deriving instance Generic ComposedMessage
|
||||
deriving instance Generic Connection
|
||||
deriving instance Generic ConnectionEntity
|
||||
deriving instance Generic ConnectionErrorType
|
||||
deriving instance Generic ConnectionMode
|
||||
deriving instance Generic ConnectionPlan
|
||||
deriving instance Generic ConnStatus
|
||||
deriving instance Generic ConnType
|
||||
deriving instance Generic Contact
|
||||
deriving instance Generic ContactAddressPlan
|
||||
deriving instance Generic ContactShortLinkData
|
||||
deriving instance Generic ContactStatus
|
||||
deriving instance Generic ContactUserPreferences
|
||||
deriving instance Generic CryptoFile
|
||||
deriving instance Generic CryptoFileArgs
|
||||
deriving instance Generic E2EInfo
|
||||
deriving instance Generic ErrorType
|
||||
deriving instance Generic FeatureAllowed
|
||||
deriving instance Generic FileDescr
|
||||
deriving instance Generic FileError
|
||||
deriving instance Generic FileErrorType
|
||||
deriving instance Generic FileInvitation
|
||||
deriving instance Generic FileProtocol
|
||||
deriving instance Generic FileStatus
|
||||
deriving instance Generic FileTransferMeta
|
||||
deriving instance Generic Format
|
||||
deriving instance Generic FormattedText
|
||||
deriving instance Generic FullGroupPreferences
|
||||
deriving instance Generic FullPreferences
|
||||
deriving instance Generic GroupChatScope
|
||||
deriving instance Generic GroupChatScopeInfo
|
||||
deriving instance Generic GroupFeature
|
||||
deriving instance Generic GroupFeatureEnabled
|
||||
deriving instance Generic GroupInfo
|
||||
deriving instance Generic GroupInfoSummary
|
||||
deriving instance Generic GroupLink
|
||||
deriving instance Generic GroupLinkPlan
|
||||
deriving instance Generic GroupMember
|
||||
deriving instance Generic GroupMemberAdmission
|
||||
deriving instance Generic GroupMemberCategory
|
||||
deriving instance Generic GroupMemberRef
|
||||
deriving instance Generic GroupMemberRole
|
||||
deriving instance Generic GroupMemberSettings
|
||||
deriving instance Generic GroupMemberStatus
|
||||
deriving instance Generic GroupPreference
|
||||
deriving instance Generic GroupPreferences
|
||||
deriving instance Generic GroupProfile
|
||||
deriving instance Generic GroupShortLinkData
|
||||
deriving instance Generic GroupSummary
|
||||
deriving instance Generic GroupSupportChat
|
||||
deriving instance Generic HandshakeError
|
||||
deriving instance Generic InlineFileMode
|
||||
deriving instance Generic InvitationLinkPlan
|
||||
deriving instance Generic InvitedBy
|
||||
deriving instance Generic JSONChatInfo
|
||||
deriving instance Generic JSONCIContent
|
||||
deriving instance Generic JSONCIDeleted
|
||||
deriving instance Generic JSONCIDirection
|
||||
deriving instance Generic JSONCIFileStatus
|
||||
deriving instance Generic JSONCIStatus
|
||||
deriving instance Generic LinkContent
|
||||
deriving instance Generic LinkPreview
|
||||
deriving instance Generic LocalProfile
|
||||
deriving instance Generic MemberCriteria
|
||||
deriving instance Generic MsgChatLink
|
||||
deriving instance Generic MsgContent
|
||||
deriving instance Generic MsgDecryptError
|
||||
deriving instance Generic MsgDirection
|
||||
deriving instance Generic MsgErrorType
|
||||
deriving instance Generic MsgFilter
|
||||
deriving instance Generic MsgReaction
|
||||
deriving instance Generic MsgReceiptStatus
|
||||
deriving instance Generic NewUser
|
||||
deriving instance Generic NoteFolder
|
||||
deriving instance Generic PendingContactConnection
|
||||
deriving instance Generic PrefEnabled
|
||||
deriving instance Generic Preferences
|
||||
deriving instance Generic PreparedContact
|
||||
deriving instance Generic PreparedGroup
|
||||
deriving instance Generic Profile
|
||||
deriving instance Generic ProxyClientError
|
||||
deriving instance Generic ProxyError
|
||||
deriving instance Generic RatchetSyncState
|
||||
deriving instance Generic RCErrorType
|
||||
deriving instance Generic RcvConnEvent
|
||||
deriving instance Generic RcvDirectEvent
|
||||
deriving instance Generic RcvFileDescr
|
||||
deriving instance Generic RcvFileInfo
|
||||
deriving instance Generic RcvFileStatus
|
||||
deriving instance Generic RcvFileTransfer
|
||||
deriving instance Generic RcvGroupEvent
|
||||
deriving instance Generic ReportReason
|
||||
deriving instance Generic SecurityCode
|
||||
deriving instance Generic SimplexLinkType
|
||||
deriving instance Generic SMPAgentError
|
||||
deriving instance Generic SndCIStatusProgress
|
||||
deriving instance Generic SndConnEvent
|
||||
deriving instance Generic SndError
|
||||
deriving instance Generic SndFileTransfer
|
||||
deriving instance Generic SndGroupEvent
|
||||
deriving instance Generic SrvError
|
||||
deriving instance Generic StoreError
|
||||
deriving instance Generic SwitchPhase
|
||||
deriving instance Generic TimedMessagesGroupPreference
|
||||
deriving instance Generic TimedMessagesPreference
|
||||
deriving instance Generic TransportError
|
||||
deriving instance Generic UIColorMode
|
||||
deriving instance Generic UIColors
|
||||
deriving instance Generic UIThemeEntityOverride
|
||||
deriving instance Generic UIThemeEntityOverrides
|
||||
deriving instance Generic UpdatedMessage
|
||||
deriving instance Generic User
|
||||
deriving instance Generic UserContact
|
||||
deriving instance Generic UserContactLink
|
||||
deriving instance Generic UserContactRequest
|
||||
deriving instance Generic UserInfo
|
||||
deriving instance Generic UserProfileUpdateSummary
|
||||
deriving instance Generic UserPwdHash
|
||||
deriving instance Generic XFTPErrorType
|
||||
deriving instance Generic XFTPRcvFile
|
||||
deriving instance Generic XFTPSndFile
|
||||
|
||||
-- deriving instance Generic DatabaseError
|
||||
-- deriving instance Generic ChatItemInfo
|
||||
-- deriving instance Generic ChatItemVersion
|
||||
-- deriving instance Generic ChatListQuery
|
||||
-- deriving instance Generic ChatName
|
||||
-- deriving instance Generic ChatPagination
|
||||
-- deriving instance Generic ConnectionStats
|
||||
-- deriving instance Generic Group
|
||||
-- deriving instance Generic GroupSndStatus
|
||||
-- deriving instance Generic MemberDeliveryStatus
|
||||
-- deriving instance Generic MemberReaction
|
||||
-- deriving instance Generic MsgContentTag
|
||||
-- deriving instance Generic NavigationInfo
|
||||
-- deriving instance Generic PaginationByTime
|
||||
-- deriving instance Generic RcvQueueInfo
|
||||
-- deriving instance Generic RcvSwitchStatus
|
||||
-- deriving instance Generic SendRef
|
||||
-- deriving instance Generic SndQueueInfo
|
||||
-- deriving instance Generic SndSwitchStatus
|
||||
@@ -0,0 +1,224 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module API.TypeInfo where
|
||||
|
||||
import Data.Kind (Type)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Typeable
|
||||
import GHC.Generics
|
||||
import Simplex.Messaging.Parsers (fstToLower)
|
||||
|
||||
data APIType
|
||||
= ATPrim PrimitiveType
|
||||
| ATDef APITypeDef
|
||||
| ATRef String -- to support recursive types
|
||||
| ATOptional APIType
|
||||
| ATArray {elemType :: APIType, nonEmpty :: Bool}
|
||||
| ATMap {keyType :: PrimitiveType, valueType :: APIType}
|
||||
|
||||
data APITypeDef = APITypeDef {typeName' :: String, typeDef :: APITypeDefinition}
|
||||
|
||||
data APITypeDefinition
|
||||
= ATDRecord (NonEmpty APIRecordField)
|
||||
| ATDUnion (NonEmpty ATUnionMember)
|
||||
| ATDEnum (NonEmpty String)
|
||||
|
||||
type TypeAndFields = (String, [APIRecordField])
|
||||
|
||||
data APIRecordField = APIRecordField {fieldName' :: String, typeInfo :: APIType}
|
||||
|
||||
data ATUnionMember = ATUnionMember {memberTag :: String, memberFields :: [APIRecordField]}
|
||||
|
||||
newtype PrimitiveType = PT String
|
||||
|
||||
-- data PrimitiveType = PTBool | PTString StringFormat | PTInt | PTInt64 | PTWord32 | PTDouble
|
||||
|
||||
data StringFormat = SFTimestamp | SFBase64 | SFSimpleXLink | SFServerAddr | SFHexColor
|
||||
|
||||
pattern TBool :: String
|
||||
pattern TBool = "bool"
|
||||
|
||||
pattern TString :: String
|
||||
pattern TString = "string"
|
||||
|
||||
pattern TInt :: String
|
||||
pattern TInt = "int"
|
||||
|
||||
pattern TInt64 :: String
|
||||
pattern TInt64 = "int64"
|
||||
|
||||
primitiveTypes :: [ConsName]
|
||||
primitiveTypes = [TBool, TString, TInt, TInt64, "word32", "double", "JSONObject", "UTCTime"]
|
||||
|
||||
data SumTypeInfo = STI {typeName :: String, recordTypes :: [RecordTypeInfo]}
|
||||
deriving (Show)
|
||||
|
||||
sti :: forall t. (GTypeInfo (Rep t), GetDatatypeName (Rep t)) => SumTypeInfo
|
||||
sti = STI {typeName = getDatatypeName @(Rep t), recordTypes = gTypeInfo @(Rep t)}
|
||||
|
||||
class GetDatatypeName (f :: Type -> Type) where getDatatypeName :: String
|
||||
|
||||
instance (Datatype d) => GetDatatypeName (D1 d g) where
|
||||
getDatatypeName = datatypeName (undefined :: D1 d g p)
|
||||
|
||||
recordTypesInfo :: forall t. (GTypeInfo (Rep t)) => [RecordTypeInfo]
|
||||
recordTypesInfo = gTypeInfo @(Rep t)
|
||||
|
||||
data RecordTypeInfo = RecordTypeInfo {consName :: ConsName, fieldInfos :: [FieldInfo]}
|
||||
deriving (Show)
|
||||
|
||||
class ConstructorName t where consName' :: t -> ConsName
|
||||
|
||||
instance ConstructorName RecordTypeInfo where consName' RecordTypeInfo {consName} = consName
|
||||
|
||||
type ConsName = String
|
||||
|
||||
data FieldInfo = FieldInfo {fieldName :: String, typeInfo :: TypeInfo}
|
||||
deriving (Show)
|
||||
|
||||
data SimpleType = ST {tcName :: ConsName, tcParams :: [String]}
|
||||
deriving (Show)
|
||||
|
||||
data TypeInfo
|
||||
= TIType SimpleType -- for simple types
|
||||
| TIOptional TypeInfo -- for Maybe
|
||||
| TIArray {elemType :: TypeInfo, nonEmpty :: Bool} -- for [] and NonEmpty
|
||||
| TIMap {keyType :: SimpleType, valueType :: TypeInfo} -- keys are only base types
|
||||
deriving (Show)
|
||||
|
||||
ti :: ConsName -> TypeInfo
|
||||
ti n = TIType $ ST n []
|
||||
|
||||
class GTypeInfo (f :: Type -> Type) where
|
||||
gTypeInfo :: [RecordTypeInfo]
|
||||
|
||||
instance GTypeInfo U1 where
|
||||
gTypeInfo = []
|
||||
|
||||
instance GTypeInfo V1 where
|
||||
gTypeInfo = []
|
||||
|
||||
instance (GTypeInfo f) => GTypeInfo (D1 d f) where
|
||||
gTypeInfo = gTypeInfo @f
|
||||
|
||||
instance (Constructor c, GFieldsInfo f) => GTypeInfo (C1 c f) where
|
||||
gTypeInfo = [RecordTypeInfo {consName = conName (undefined :: M1 C c f p), fieldInfos = gfieldsInfo @f}]
|
||||
|
||||
instance (GTypeInfo l, GTypeInfo r) => GTypeInfo (l :+: r) where
|
||||
gTypeInfo = gTypeInfo @l ++ gTypeInfo @r
|
||||
|
||||
class GFieldsInfo (f :: Type -> Type) where
|
||||
gfieldsInfo :: [FieldInfo]
|
||||
|
||||
instance GFieldsInfo U1 where
|
||||
gfieldsInfo = []
|
||||
|
||||
instance GFieldsInfo V1 where
|
||||
gfieldsInfo = []
|
||||
|
||||
instance (GFieldsInfo l, GFieldsInfo r) => GFieldsInfo (l :*: r) where
|
||||
gfieldsInfo = gfieldsInfo @l ++ gfieldsInfo @r
|
||||
|
||||
instance forall s i c. (Selector s, Typeable c) => GFieldsInfo (S1 s (K1 i c)) where
|
||||
gfieldsInfo = [FieldInfo {fieldName = selName (undefined :: S1 s (K1 i c) p), typeInfo = toTypeInfo $ typeRep (Proxy :: Proxy c)}]
|
||||
|
||||
toTypeInfo :: TypeRep -> TypeInfo
|
||||
toTypeInfo tr =
|
||||
let tc = typeRepTyCon tr
|
||||
args = typeRepArgs tr
|
||||
name = tyConName tc
|
||||
in case name of
|
||||
"List" -> case args of
|
||||
[elemTr]
|
||||
| elemTr == typeRep (Proxy @Char) -> TIType (ST TString [])
|
||||
| otherwise -> TIArray {elemType = toTypeInfo elemTr, nonEmpty = False}
|
||||
_ -> TIType (simpleType tr)
|
||||
"NonEmpty" -> case args of
|
||||
[elemTr] -> TIArray {elemType = toTypeInfo elemTr, nonEmpty = True}
|
||||
_ -> TIType (simpleType tr)
|
||||
"Maybe" -> case args of
|
||||
[innerTr] -> TIOptional (toTypeInfo innerTr)
|
||||
_ -> TIType (simpleType tr)
|
||||
"Map" -> case args of
|
||||
[keyTr, valTr] -> TIMap {keyType = simpleType keyTr, valueType = toTypeInfo valTr}
|
||||
_ -> TIType (simpleType tr)
|
||||
_ -> TIType (simpleType tr)
|
||||
where
|
||||
simpleType tr' = primitiveToLower $ case tyConName (typeRepTyCon tr') of
|
||||
"AgentUserId" -> ST TInt64 []
|
||||
"Integer" -> ST TInt64 []
|
||||
"Version" -> ST TInt []
|
||||
"PQEncryption" -> ST TBool []
|
||||
"PQSupport" -> ST TBool []
|
||||
"ACreatedConnLink" -> ST "CreatedConnLink" []
|
||||
"CChatItem" -> ST "ChatItem" []
|
||||
"FormatColor" -> ST "Color" []
|
||||
"CustomData" -> ST "JSONObject" []
|
||||
"KeyMap" -> ST "JSONObject" []
|
||||
"CIQDirection" -> ST "CIDirection" []
|
||||
"SendRef" -> ST "ChatRef" []
|
||||
t
|
||||
| t `elem` stringTypes -> ST TString []
|
||||
| t `elem` simplePrefTypes -> ST "SimplePreference" []
|
||||
| t `elem` groupPrefTypes -> ST "GroupPreference" []
|
||||
| t `elem` roleGroupPrefTypes -> ST "RoleGroupPreference" []
|
||||
| otherwise -> case words $ show tr' of
|
||||
(tcName : tcParams) -> ST {tcName, tcParams}
|
||||
_ -> ST "" []
|
||||
primitiveToLower st@(ST t ps) = let t' = fstToLower t in if t' `elem` primitiveTypes then ST t' ps else st
|
||||
stringTypes =
|
||||
[ "AConnectionLink",
|
||||
"AgentConnId",
|
||||
"AgentInvId",
|
||||
"AgentRcvFileId",
|
||||
"AgentSndFileId",
|
||||
"B64UrlByteString",
|
||||
"CbNonce",
|
||||
"ConnectionLink",
|
||||
"ConnShortLink",
|
||||
"ConnectionRequestUri",
|
||||
"FileDigest",
|
||||
"GroupLinkId",
|
||||
"ImageData",
|
||||
"MemberId",
|
||||
"Text",
|
||||
"MREmojiChar",
|
||||
"ProtocolServer",
|
||||
"SbKey",
|
||||
"SharedMsgId",
|
||||
"UIColor",
|
||||
"UserPwd",
|
||||
"XContactId"
|
||||
]
|
||||
simplePrefTypes =
|
||||
[ "CallsPreference",
|
||||
"FullDeletePreference",
|
||||
"ReactionsPreference",
|
||||
"VoicePreference"
|
||||
]
|
||||
groupPrefTypes =
|
||||
[ "FullDeleteGroupPreference",
|
||||
"ReactionsGroupPreference",
|
||||
"ReportsGroupPreference",
|
||||
"HistoryGroupPreference"
|
||||
]
|
||||
roleGroupPrefTypes =
|
||||
[ "DirectMessagesGroupPreference",
|
||||
"VoiceGroupPreference",
|
||||
"FilesGroupPreference",
|
||||
"SimplexLinksGroupPreference"
|
||||
]
|
||||
Reference in New Issue
Block a user