diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,126 @@ # Changelog for notion-client +## 0.8.0.0 (2026-09-15) + +### Breaking Changes +* `Color` gains `DefaultBackground` and an `UnknownColor Text` fallback; its JSON instances are now hand-written +* `Parent` gains `AgentParent` and an `UnknownParent Value` fallback +* `Icon` gains an `UnknownIcon Value` fallback, and `CustomEmojiIcon` now encodes as `{"type":"custom_emoji","custom_emoji":{"id":...}}` +* `MentionContent` gains an `UnknownMention Value` fallback +* `PersonUser.email` changes from `Text` to `Maybe Text` +* `UniqueIdResult.number` changes from `Natural` to `Maybe Natural` +* `MeetingNotesBlock` fields are now typed: `meetingTitle :: Maybe (Vector RichText)`, `meetingStatus :: Maybe MeetingNotesStatus`, `calendarEvent :: Maybe MeetingCalendarEvent`, `recording :: Maybe MeetingRecording`, and the `children` field is replaced by `meetingChildren :: Maybe MeetingNotesChildren`; `withChildren` leaves meeting-notes blocks unchanged +* `CodeLanguage` gains 18 languages (`Abc`, `Agda`, `AsciiArt`, `Assembly`, `Bnf`, `Coq`, `Dhall`, `Ebnf`, `Hcl`, `Idris`, `LlvmIr`, `Mathematica`, `NotionFormula`, `PureScript`, `Racket`, `Smalltalk`, `Solidity`, `Toml`) and an `OtherLanguage Text` fallback +* `UserOwner` gains an `UnknownOwner` fallback +* `NumberFormat` gains an `OtherNumberFormat Text` fallback +* `FormulaResult` gains `FormulaUnsupportedResult` and an `UnknownFormulaResult Value` fallback +* `NotionError.code` is now `APIErrorCode` (was `Text`); `NotionError` gains `requestId`, `additionalData` and `response` fields. String literals still work via `IsString`; use `apiErrorCodeText` to get `Text` +* Failure responses whose body is not a Notion error (for example Cloudflare HTML pages) now throw `UnknownHTTPResponseError` instead of servant's `ClientError` (`FailureResponse`) +* Connection and response timeouts now throw `RequestTimeoutError` instead of `ClientError` (`ConnectionError`) +* `makeMethods` now retries `rate_limited` (429) and `service_overload` (529) responses for all requests and `internal_server_error`/`service_unavailable` for GET/DELETE, up to 2 times with back-off honoring `retry-after`. Use `makeMethodsWithEnv defaultClientConfig {retryOptions = noRetries}` for the old behavior +* Requests now send a `User-Agent: notion-client-haskell/` header +* Request paths containing `..` throw `InvalidPathParameterError` before any request is sent +* `ListOf` gains a `requestStatus` field; record construction must supply it +* Minimum `servant-client` is now 0.20.2; new dependencies `base64-bytestring`, `http-client`, `http-types`, `mtl`, `random` and `servant-client-core` +* `CreatePage.position` changes from `Maybe Blocks.Position` to `Maybe PagePosition` +* The exported Servant `API` types of `Notion.V1`, `Notion.V1.DataSources` and `Notion.V1.Databases` gain a `QueryParams "filter_properties" Text` segment on the query routes (only affects code deriving its own client from them; the `Methods` record is unchanged) +* `CreateComment` is restructured: `target :: CommentTarget` (parent or discussion) and `content :: CommentContent` (rich text or Markdown) replace `parent`, `discussionId` and `richText`; `attachments` now holds `CommentAttachmentRequest` and `displayName` holds `CommentDisplayNameRequest`. Use `mkCreateComment` / `mkReplyComment` +* `createComment` returns `CommentResponse` (full or partial comment) instead of `CommentObject` +* `Methods` and the effectful `Notion` GADT gain `retrieveComment`, `updateComment`, `deleteComment`, `createPageAsync`, `updatePageMarkdownAsync`, `retrieveAsyncTask`, `createMeetingNote` and `queryMeetingNotes` +* The exported Servant `API` types of `Notion.V1` and `Notion.V1.Pages` gain the async page routes, `AsyncTasks.API` and `MeetingNotes.API` +* Remove `queryView`, `QueryView` and the `POST /v1/views/{view_id}/query` route (Notion never served it; it returned 400 `invalid_request_url`). Use `createViewQuery` / `getViewQueryResults` / `deleteViewQuery` or `Notion.V1.ViewQueries.queryAllViewPages`. The effectful `queryView` / `QueryView` are removed too +* `ViewType` gains `UnknownViewType Text` +* `ViewObject`: `parent` is now `Maybe Parent`, `filter` is `Maybe ViewFilter`, `sorts` is `Maybe (Vector ViewSort)`, `quickFilters` is `Maybe (Map Text QuickFilter)`, `configuration` is `Maybe ViewConfig` +* `CreateView`: `filter`, `sorts`, `quickFilters`, `configuration` and `position` are typed; new fields `createDatabase_` (wire `create_database`) and `placement` +* `UpdateView`: `filter`, `sorts` (now property sorts only) and `quickFilters` are `Clearable`, so they can be cleared with `null`; `configuration` is `Maybe ViewConfig` +* `queryDataSource` returns `ListOf PageOrDataSource` (was `ListOf PageObject`), and `search` returns `ListOf PageOrDataSource` (was `ListOf Value`). `SearchResult` is now a type alias for `PageOrDataSource`, and `parseSearchResults` was removed. Use `pageResults` for the old page-only behaviour +* `SearchSort` and `SearchFilter` are now sum types (`SearchByLastEditedTime` / `SearchByRelevance`, `SearchObjectFilter` / `SearchInTrashFilter`) +* `CreateDatabase.title` is `Maybe`, `CreateDatabase` gains `databaseType`, and `InitialDataSource.properties` is `Maybe` +* `QueryDataSource` gains `resultType` +* Every `PropertySchema` constructor gains `schemaDescription`, `RelationSchema` gains `relationDatabaseId`, `SelectOption` gains `description`, and `DualProperty` fields are `Maybe` +* `PropertySchema` gains `LocationSchema`, `LastVisitedTimeSchema` and `UnknownSchema` +* `UpdateDataSource.properties` is `Maybe (Map Text PropertyUpdate)` (was `Maybe (Map Text (Maybe PropertySchema))`): use `RemoveProperty` for `Nothing` and `SetPropertySchema` for `Just` +* `PropertySchema` encoding omits an empty `id`, and omits `groups` for a status schema with no groups +* `VerificationCondition` takes `VerificationState` and gains `VerificationDoesNotEqual`; `UniqueIdCondition` takes `Scientific` and gains `UniqueIdIsEmpty` / `UniqueIdIsNotEmpty` +* `Filter`, `PropertyCondition` and `Sort` gain `UnknownFilter`, `UnknownCondition` and `UnknownSort`; their decoders no longer fail on unmodelled shapes. `SelectCondition`, `StatusCondition` and `MultiSelectCondition` gain array-valued constructors +* `DatabaseObject` and `DataSourceObject` gain `databaseType` +* The effectful `queryDataSource` and `search` result types changed accordingly +* `BlockUpdate` is replaced by `BlockUpdatePayload` (optional `updateContent :: Maybe BlockUpdateContent` plus `inTrash`), with one `BlockUpdateContent` constructor per updatable block type; use `mkBlockUpdate` and `blockUpdateFromContent` to migrate. Updates no longer send `children`, `table_width` or other fields Notion rejects on `PATCH /v1/blocks/{id}` +* `MovePage` drops `position`, and its `parent` is now `MovePageParent` (`MoveToPage` / `MoveToDataSource`) +* `UpdatePage.template` is `Maybe UpdatePageTemplate` (no `none` variant), and `UpdatePage.icon` / `cover` are `Clearable` +* `CreatePage.parent` is `Maybe Parent` +* `AudioBlock` and `EmbedBlock` gain `caption`; `UnsupportedBlock` carries the `block_type` as `Maybe Text` +* `InsertContentRequest` gains `position` +* `SelectOptionValue` gains `description` +* `PeopleValue` holds `PeopleEntry` (a `UserValue` or a `GroupObject`); `PlaceValue` holds a typed `Place` +* `VerificationResult.state` is `VerificationState`, and `verifiedBy` is `Maybe UserValue` +* `RollupArrayResult` holds typed `PropertyValue`s; `RollupResult` gains `RollupUnknownResult` and `PropertyValue` gains `UnknownPropertyValue` +* `PaginatedPropertyItems` holds a `PropertyItemList` record with `nextUrl`, `propertyId` and the rollup summary +* `UserMention` holds a `UserValue` (partial or full user) instead of a bare ID; `MentionContent` gains `LinkMention` and `CustomEmojiMention` +* `CustomEmojiIcon`'s field is `customEmoji :: CustomEmojiRef` (ID, name and URL) instead of `customEmojiId :: UUID` +* `NativeIcon.iconColor` is `Maybe NoticonColor` +* `ObjectType` gains `FileUploadObjectType`, `PageMarkdownObjectType`, `AsyncTaskObjectType`, `GroupObjectType` and `UnknownObjectType`; its JSON instances are hand-written +* `PageMarkdown` gains `object` +* `FileUploadObject.createdBy` is a typed `FileUploadCreator`, and `CreateFileUpload.mode` is `Maybe FileUploadMode` +* `WebhookEvent.data_` is `Maybe WebhookEventData`, and `WebhookEvent` gains `workspaceName` and `apiVersion` +* `EventType` gains the `file_upload.*` and `page.transcription_block.transcript_deleted` events; `EntityType` gains `FileUploadEntity` and `BlockEntity` + +### New Features +* Export `UserOwner (..)` from `Notion.V1.Users` +* New meeting-notes payload types `MeetingNotesStatus`, `MeetingNotesChildren`, `MeetingCalendarEvent` and `MeetingRecording` in `Notion.V1.BlockContent` +* New `PagePosition` type (`PageAfterBlock`, `PageStart`, `PageEnd`) in `Notion.V1.Pages` +* `ClientConfig`, `defaultClientConfig`, `makeMethodsWith` and `makeMethodsWithEnv`: configurable Notion-Version, base URL, timeout (default 60s), retries, User-Agent and logging (`stderrLogger` for opt-in logging) +* `APIErrorCode` with all 14 Notion error codes plus `UnknownErrorCode` +* `RequestStatus` on list responses +* OAuth: `Notion.V1.OAuth` with `createOAuthToken`, `revokeOAuthToken` and `introspectOAuthToken` using HTTP Basic auth +* `Notion.V1.Helpers`: `extractNotionId`, `extractPageId`, `extractDatabaseId`, `extractBlockId` +* `paginateFoldM` and `paginateForM_` in `Notion.V1.Pagination` +* Runtime building blocks for non-Servant requests: `RequestContext`, `standardHeaders`, `responseTimeoutFor`, `withRetries`, `buildRequestError` and `notionErrorFromResponse` +* Retrieve, update (rich text or Markdown) and delete comments; create comments with Markdown, discussion replies, file-upload attachments and display names +* New `Notion.V1.AsyncTasks` module: `AsyncTask`, `retrieveAsyncTask`, `waitForAsyncTask`, and `allow_async` page creation / markdown update via `createPageAsync` and `updatePageMarkdownAsync` (which accept Notion's `202 Accepted` responses) +* New `Notion.V1.MeetingNotes` module: `createMeetingNote` from an uploaded recording or an existing media block, and `queryMeetingNotes` with a typed filter and sort DSL, both with a typed `MeetingNoteBlock` response +* View query endpoints: `createViewQuery` (`POST /v1/views/{view_id}/queries`), `getViewQueryResults` (`GET /v1/views/{view_id}/queries/{query_id}`) and `deleteViewQuery` (`DELETE /v1/views/{view_id}/queries/{query_id}`), plus the `queryAllViewPages` helper in `Notion.V1.ViewQueries` +* `PartialPageObject` in `Notion.V1.Pages` for results that carry only a page ID +* Typed view configuration (`Notion.V1.ViewConfig`, re-exported by `Notion.V1.Views`) for table, board, calendar, timeline, gallery, list, map, form, chart and dashboard views, including group-by, property, subtask, cover, timeline and chart settings; unknown shapes and values are preserved as raw JSON or text +* `Notion.V1.Clearable` for request fields that distinguish "leave unchanged" (`Unset`) from "clear with null" (`Clear`) +* `FromJSON` instances for `Filter`, `PropertyCondition` and its condition types, `Sort` and `SortDirection`; `ToJSON PropertyCondition` +* `CreateView` supports `position` (`ViewPositionStart` / `ViewPositionEnd` / `ViewPositionAfterView`), dashboard widget `placement`, and `create_database` +* `DatabaseType`, `CreateDatabaseType` (typed databases created without a title), `QueryResultType` and `_QueryDataSource` +* `PageOrDataSource` with `PartialDataSourceObject` and `PartialDatabaseObject`, plus `pageResults`, `dataSourceResults`, `resultId` and `resultCreatedTime` +* Search by relevance (`SearchByRelevance`) and `in_trash` search filters +* `PropertyUpdate`, `OptionUpdate` and `OptionTarget`: rename a property without resending its schema, and target select/status options by id +* Filter constructors `SelectEqualsAny`, `SelectDoesNotEqualAny`, `StatusEqualsAny`, `StatusDoesNotEqualAny`, `MultiSelectContainsAny` and `MultiSelectDoesNotContainAny`, plus `RelativeDate` / `relativeDate` for relative date filters +* `createPageFiltered` and `updatePageFiltered` send `filter_properties` query parameters, mirrored in `notion-client-effectful` +* `trashBlockUpdate`, `mkBlockUpdate` and the `tabBlock` smart constructor +* Insert markdown at the start or end of a page with `InsertAtStart` / `InsertAtEnd` +* `CustomEmojiRef` in `Notion.V1.Common`, `LinkMentionValue` in `Notion.V1.RichText`, and `UserValue`, `GroupObject` and `PeopleEntry` in `Notion.V1.Users` +* Smart constructors `placeValue`, `verifiedValue`, `unverifiedValue` and `peopleEntriesValue` +* `Eq` instances on `UserObject` and the other user types +* `FileUploadObject.uploadUrl` and `completeUrl` +* Typed webhook event data (`WebhookEventData`, `parseEventData`) for every event family, falling back to `RawEventData` for shapes it does not recognize +* Page create and update omit `properties` when the map is empty, so trash-only or markdown-only requests send just those keys +* New module `Notion.V1.DataSourceRows` with `iterateAllDataSourceRows`, `collectAllDataSourceRows` and `foldAllDataSourceRows`, which read every row of a data source past Notion's per-query result limit + +### Bug Fixes +* Decode the `default_background` color — previously any rich text or block using it failed the whole response +* Decode `agent_id` parents on pages and blocks +* Read and write custom-emoji icons in the nested `custom_emoji` object shape Notion uses; the old top-level `id` shape is still accepted when reading +* Unknown colors, parent kinds, icon kinds and mention kinds (for example `link_mention` and `custom_emoji` mentions) decode into fallback constructors instead of failing +* Decode code blocks in every language Notion supports (for example `toml`), with unknown languages kept as `OtherLanguage` +* Decode real meeting-notes blocks (rich-text `title`, object `children`) and the deprecated `transcription` block type +* Decode person users without a visible email, and bots owned by a user (Notion sends the user object, not a bare ID) +* Decode data sources with number formats newer than this library +* Decode unique-ID properties whose `number` is null, and formula properties with an `unsupported` result +* `queryDataSource` and `queryDatabase` send `filterProperties` as repeated `filter_properties` query parameters instead of a JSON body field, which Notion rejected +* `CreatePage` positions encode as `page_start`, `page_end` and `after_block`, the shapes Notion accepts for page creation +* `WebhookEvent` decodes without `accessible_by` (it is only sent to public integrations); `accessibleBy` is empty in that case +* Data source queries on wiki databases (which return child data sources and partial objects) no longer fail to decode +* Search no longer silently drops partial or undecodable results +* Unknown property types no longer fail data source decoding +* Custom-emoji icons keep the emoji's `name` and `url` when decoded +* Page property values of unknown types, and rollup array values without an `id`, no longer fail page decoding +* `verifySignature` accepts upper- or lowercase hex and rejects headers without the `sha256=` prefix, of the wrong length, or with non-hex characters + ## 0.7.0.2 (2026-06-27) ### Bug Fixes diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,6 +8,9 @@ - Comprehensive coverage of Notion API endpoints - Support for all Notion object types: Pages, Databases, Data Sources, Blocks, Users, etc. - Simple client interface with sensible defaults +- Automatic retries of rate-limited and overloaded requests, honoring `retry-after` +- Typed error codes with request IDs for support +- OAuth token exchange and URL-to-ID helpers ## Installation @@ -121,18 +124,85 @@ } ``` +### Configuration and retries + +`makeMethods` uses sensible defaults. For control over the API version, base +URL, timeout (default 60 seconds), retries and logging, build a `ClientConfig`: + +```haskell +import Network.HTTP.Client.TLS (newTlsManager) +import Notion.V1 + +main :: IO () +main = do + manager <- newTlsManager + let config = defaultClientConfig {logger = Just stderrLogger, logLevel = LogInfo} + methods = makeMethodsWith config manager token + user <- retrieveMyUser methods + print user +``` + +Requests that fail with `rate_limited` (HTTP 429) or `service_overload` (529) +are retried up to two times, as are `internal_server_error` and +`service_unavailable` for `GET` and `DELETE`. A `retry-after` header sets the +delay; otherwise the delay grows exponentially with jitter. Disable retries with +`defaultClientConfig {retryOptions = noRetries}`. + ### Error handling ```haskell import Control.Exception (catch) -import Notion.V1.Error (NotionError(..)) +import Data.Text qualified as Text +import Notion.V1.Error safeRetrieve :: Methods -> PageID -> IO () safeRetrieve Methods{retrievePage} pageId = - retrievePage pageId `catch` \(e :: NotionError) -> - putStrLn $ "Notion error: " <> code e <> " - " <> message e + (retrievePage pageId >>= print) `catch` \(e :: NotionError) -> case code e of + ObjectNotFound -> putStrLn "No such page" + other -> + putStrLn $ "Notion error: " <> Text.unpack (apiErrorCodeText other) + <> " - " <> Text.unpack (message e) + <> " (request " <> show (requestId e) <> ")" ``` +Besides `NotionError`, a request can throw `UnknownHTTPResponseError` (a +non-2xx response that is not a Notion error, such as an HTML page from Notion's +edge proxy; `displayException` explains it and includes the Cloudflare Ray ID), +`RequestTimeoutError`, or `InvalidPathParameterError` (an ID containing `..`, +rejected before sending). + +### OAuth + +```haskell +import Notion.V1 (defaultBaseUrl, defaultClientConfig) +import Notion.V1.OAuth +import Servant.Client (mkClientEnv) + +exchangeCode :: Manager -> Text -> IO OAuthTokenResponse +exchangeCode manager authCode = do + let oauth = makeOAuthMethodsWith defaultClientConfig + (mkClientEnv manager defaultBaseUrl) + OAuthCredentials {clientId = "...", clientSecret = "..."} + createOAuthToken oauth $ AuthorizationCode AuthorizationCodeGrant + { code = authCode + , redirectUri = Just "https://example.com/callback" + , externalAccount = Nothing + } +``` + +`revokeOAuthToken` and `introspectOAuthToken` take a token. + +### URL helpers + +```haskell +import Notion.V1.Helpers (extractBlockId, extractNotionId) + +extractNotionId "https://www.notion.so/team/Tasks-abc123def456789012345678901234ab?v=..." +-- Just (UUID "abc123de-f456-7890-1234-5678901234ab") +extractBlockId "https://www.notion.so/Page-0123456789abcdef0123456789abcdef#block-fedcba9876543210fedcba9876543210" +-- Just (UUID "fedcba98-7654-3210-fedc-ba9876543210") +``` + ### Auto-pagination ```haskell @@ -147,6 +217,9 @@ } ``` +`paginateFoldM` and `paginateForM_` process every item while holding only one +page in memory. + ## Usage with effectful Callers that use the [`effectful`](https://hackage.haskell.org/package/effectful) @@ -204,6 +277,7 @@ - **Comments**: Create and list comments - **Custom Emojis**: List workspace custom emojis - **Webhooks**: Event types (including view events) and signature verification +- **OAuth**: Exchange authorization codes and refresh tokens, revoke and introspect tokens ## Running the Example diff --git a/notion-client-example/DatabaseDemo.hs b/notion-client-example/DatabaseDemo.hs --- a/notion-client-example/DatabaseDemo.hs +++ b/notion-client-example/DatabaseDemo.hs @@ -14,16 +14,17 @@ import Data.Vector qualified as Vector import Notion.V1 (Methods (..)) import Notion.V1.Blocks qualified as Blocks -import Notion.V1.Comments (CommentObject (..), CreateComment (..)) +import Notion.V1.Comments (CommentContent (..), CommentObject (..), CommentResponse (..), commentResponseId, mkCreateComment, mkReplyComment) import Notion.V1.Common (Icon (..), Parent (..), UUID (..)) +import Notion.V1.DataSourceRows (collectAllDataSourceRows) import Notion.V1.DataSources qualified as DataSources import Notion.V1.Databases (DataSource (..), DatabaseObject (..)) -import Notion.V1.Error (NotionError (..)) +import Notion.V1.Error (NotionError (..), apiErrorCodeText) import Notion.V1.Filter (Sort (..), SortDirection (..)) import Notion.V1.ListOf (ListOf (..)) -import Notion.V1.Pages (CreatePage (..), PageObject (..), PropertyItemResponse (..)) +import Notion.V1.Pages (CreatePage (..), PageObject (..), PropertyItemList (..), PropertyItemResponse (..)) import Notion.V1.Pagination (paginateAll) -import Notion.V1.Properties (PropertySchema (..), SelectColor (..), SelectOption (..)) +import Notion.V1.Properties (PropertySchema (..), PropertyUpdate (..), SelectColor (..), SelectOption (..)) import Notion.V1.PropertyValue qualified as PV import Notion.V1.RichText (RichText (..), RichTextContent (..), TextContent (..), defaultAnnotations) import Prelude hiding (id) @@ -72,7 +73,8 @@ startCursor = Nothing, pageSize = Just 5, inTrash = Nothing, - filterProperties = Nothing + filterProperties = Nothing, + resultType = Nothing } dsResults <- runTest (Text.pack "Querying data source") $ @@ -85,8 +87,8 @@ let newDsProperties = Map.fromList - [ ("Name", TitleSchema {schemaId = "", schemaName = "Name"}), - ("Description", RichTextSchema {schemaId = "", schemaName = "Description"}) + [ ("Name", TitleSchema {schemaId = "", schemaName = "Name", schemaDescription = Nothing}), + ("Description", RichTextSchema {schemaId = "", schemaName = "Description", schemaDescription = Nothing}) ] createDsRequest = @@ -112,20 +114,20 @@ let statusOptions = Vector.fromList - [ SelectOption {id = Nothing, name = "Not Started", color = Just Red}, - SelectOption {id = Nothing, name = "In Progress", color = Just Yellow}, - SelectOption {id = Nothing, name = "Done", color = Just Green} + [ SelectOption {id = Nothing, name = "Not Started", color = Just Red, description = Nothing}, + SelectOption {id = Nothing, name = "In Progress", color = Just Yellow, description = Nothing}, + SelectOption {id = Nothing, name = "Done", color = Just Green, description = Nothing} ] priorityOptions = Vector.fromList - [ SelectOption {id = Nothing, name = "High", color = Just Red}, - SelectOption {id = Nothing, name = "Medium", color = Just Yellow}, - SelectOption {id = Nothing, name = "Low", color = Just Gray} + [ SelectOption {id = Nothing, name = "High", color = Just Red, description = Nothing}, + SelectOption {id = Nothing, name = "Medium", color = Just Yellow, description = Nothing}, + SelectOption {id = Nothing, name = "Low", color = Just Gray, description = Nothing} ] combinedProperties = Map.fromList - [ ("Status", Just (SelectSchema {schemaId = "", schemaName = "Status", selectOptions = statusOptions})), - ("Priority", Just (SelectSchema {schemaId = "", schemaName = "Priority", selectOptions = priorityOptions})) + [ ("Status", SetPropertySchema (SelectSchema {schemaId = "", schemaName = "Status", schemaDescription = Nothing, selectOptions = statusOptions})), + ("Priority", SetPropertySchema (SelectSchema {schemaId = "", schemaName = "Priority", schemaDescription = Nothing, selectOptions = priorityOptions})) ] updateDsRequest = @@ -175,7 +177,7 @@ -- In API version 2025-09-03, pages are created under a data source createPageRequest = CreatePage - { parent = DataSourceParent {dataSourceId = dsId, parentDatabaseId = Nothing}, -- Specify parent data source + { parent = Just (DataSourceParent {dataSourceId = dsId, parentDatabaseId = Nothing}), -- Specify parent data source properties = pageProperties, -- Required page properties children = Just initialBlocks, -- Optional initial content markdown = Nothing, -- Could use markdown instead of children @@ -207,7 +209,7 @@ -- Pattern-match on typed property values from the retrieved page putStrLn "Reading typed properties:" case Map.lookup "Status" pageProps of - Just (PV.SelectValue _pid (Just (PV.SelectOptionValue _ optName optColor))) -> + Just (PV.SelectValue _pid (Just (PV.SelectOptionValue _ optName optColor _))) -> putStrLn $ " Status: " <> Text.unpack optName <> " (color: " <> show optColor <> ")" Just (PV.SelectValue _pid Nothing) -> putStrLn " Status: (empty)" @@ -215,7 +217,7 @@ putStrLn " Status: (not found or unexpected type)" case Map.lookup "Priority" pageProps of - Just (PV.SelectValue _pid (Just (PV.SelectOptionValue _ optName _))) -> + Just (PV.SelectValue _pid (Just (PV.SelectOptionValue _ optName _ _))) -> putStrLn $ " Priority: " <> Text.unpack optName _ -> putStrLn " Priority: (not found)" @@ -238,7 +240,7 @@ case propItem of SinglePropertyItem pv -> putStrLn $ " Single property item: " <> show pv - PaginatedPropertyItems _list propType -> + PaginatedPropertyItems PropertyItemList {propertyType = propType} -> putStrLn $ " Paginated property items (type: " <> Text.unpack propType <> ")" _ -> putStrLn " Skipping (Status property not found)" @@ -256,10 +258,17 @@ startCursor = cursor, pageSize = Just 2, -- small page size to exercise pagination inTrash = Nothing, - filterProperties = Nothing + filterProperties = Nothing, + resultType = Nothing } putStrLn $ "Total pages collected via paginateAll: " <> show (Vector.length allPages) + -- Collect every row, even past the per-query result limit + allRows <- + runTest (Text.pack "Collecting all rows with collectAllDataSourceRows") $ + collectAllDataSourceRows (queryDataSource methods dsId) DataSources._QueryDataSource Nothing + putStrLn $ "collectAllDataSourceRows returned " <> show (Vector.length allRows) <> " rows" + -- Demonstrate typed error handling printHeader (Text.pack "Typed Error Handling") @@ -269,7 +278,8 @@ case result of Left notionErr -> do putStrLn "caught!" - putStrLn $ " code: " <> Text.unpack (code notionErr) + putStrLn $ " code: " <> Text.unpack (apiErrorCodeText (code notionErr)) + putStrLn $ " request id: " <> maybe "(none)" Text.unpack (requestId notionErr) putStrLn $ " message: " <> Text.unpack (message notionErr) putStrLn $ " status: " <> show (status notionErr) Right _ -> @@ -317,22 +327,15 @@ -- Create the parent reference using the typed Parent constructor commentParent = PageParent {pageId = newPageId} - -- Create the comment request - createCommentRequest = - CreateComment - { parent = commentParent, - richText = commentRichText, - discussionId = Nothing -- Creates a new discussion thread - } + -- Create the comment request (a new discussion thread on the page) + createCommentRequest = mkCreateComment commentParent (CommentRichText commentRichText) -- Create the comment newComment <- runTest (Text.pack "Creating comment on page") $ createComment methods createCommentRequest - let CommentObject {id = commentId, discussionId = discId} = newComment - putStrLn $ "Comment created with ID: " <> show commentId - putStrLn $ "Discussion ID: " <> show discId + putStrLn $ "Comment created with ID: " <> show (commentResponseId newComment) -- Add a reply to the same discussion thread let -- Create reply rich text using typed RichText @@ -346,19 +349,16 @@ content = TextContentWrapper (TextContent {content = "This is a reply in the same discussion thread.", link = Nothing}) } - -- Reply to existing discussion by providing discussion_id - replyRequest = - CreateComment - { parent = commentParent, - richText = replyRichText, - discussionId = Just discId -- Reply to the same discussion - } - - _replyComment <- - runTest (Text.pack "Adding reply to discussion") $ - createComment methods replyRequest - - putStrLn "Reply added to discussion" + -- Reply to the existing discussion by its discussion_id (no parent) + case newComment of + FullComment CommentObject {discussionId = discId} -> do + putStrLn $ "Discussion ID: " <> show discId + _replyComment <- + runTest (Text.pack "Adding reply to discussion") $ + createComment methods (mkReplyComment discId (CommentRichText replyRichText)) + putStrLn "Reply added to discussion" + PartialComment _ -> + putStrLn "Notion returned a partial comment without a discussion ID; skipping reply" -- List all comments on the page allComments <- diff --git a/notion-client-example/Main.hs b/notion-client-example/Main.hs --- a/notion-client-example/Main.hs +++ b/notion-client-example/Main.hs @@ -39,7 +39,8 @@ import FileUploadDemo (runFileUploadDemo) import MarkdownDemo (runMarkdownDemo) import Notion.V1 (Methods (..), getClientEnv, makeMethods) -import Notion.V1.Search (SearchRequest (..), SearchResult (..), SearchSort (..), SearchSortDirection (..), dataSourceFilter, pageFilter, parseSearchResults) +import Notion.V1.ListOf (ListOf (..)) +import Notion.V1.Search (PageOrDataSource (..), SearchRequest (..), SearchSort (..), SearchSortDirection (..), dataSourceFilter, pageFilter) import PageDemo (runPageDemo) import System.Environment qualified as Environment import TemplateDemo (runTemplateDemo) @@ -107,7 +108,7 @@ let searchParams = SearchRequest { query = Nothing, - sort = Just (SearchSort {direction = Descending, timestamp = Text.pack "last_edited_time"}), + sort = Just (SearchByLastEditedTime Descending), filter = Nothing, startCursor = Nothing, pageSize = Just 5 @@ -116,12 +117,15 @@ runTest (Text.pack "Searching (all objects, sorted by last_edited_time)") $ search methods searchParams - let typedResults = parseSearchResults rawResults + let typedResults = results rawResults putStrLn $ " Found " <> show (Vector.length typedResults) <> " typed results" Vector.forM_ typedResults $ \result -> case result of PageResult _ -> putStrLn " - page" + PartialPageResult _ -> putStrLn " - partial page" DataSourceResult _ -> putStrLn " - data_source" + PartialDataSourceResult _ -> putStrLn " - partial data_source" + UnknownResult _ -> putStrLn " - unknown" -- Search filtered to pages only let pageSearchParams = @@ -135,7 +139,7 @@ pageResults <- runTest (Text.pack "Searching (pages only)") $ search methods pageSearchParams - let typedPageResults = parseSearchResults pageResults + let typedPageResults = results pageResults putStrLn $ " Found " <> show (Vector.length typedPageResults) <> " pages" -- Search filtered to data sources only @@ -150,7 +154,7 @@ dsResults <- runTest (Text.pack "Searching (data sources only)") $ search methods dsSearchParams - let typedDsResults = parseSearchResults dsResults + let typedDsResults = results dsResults putStrLn $ " Found " <> show (Vector.length typedDsResults) <> " data sources" -- All done diff --git a/notion-client-example/MarkdownDemo.hs b/notion-client-example/MarkdownDemo.hs --- a/notion-client-example/MarkdownDemo.hs +++ b/notion-client-example/MarkdownDemo.hs @@ -18,6 +18,7 @@ import Data.Text qualified as Text import Data.Vector qualified as Vector import Notion.V1 (Methods (..)) +import Notion.V1.Clearable (Clearable (..)) import Notion.V1.Common (Parent (..), UUID (..)) import Notion.V1.Pages import Notion.V1.PropertyValue qualified as PV @@ -40,7 +41,7 @@ -- This is much simpler than constructing block JSON manually. createReq = CreatePage - { parent = PageParent {pageId = parentPageId}, + { parent = Just (PageParent {pageId = parentPageId}), properties = props, children = Nothing, markdown = Just markdownContent, @@ -149,7 +150,7 @@ let PageObject {id = targetId} = targetPage -- Move the demo page under the target - let moveReq = MovePage {parent = PageParent {pageId = targetId}, position = Nothing} + let moveReq = MovePage {parent = MoveToPage targetId} _movedPage <- runTest (Text.pack "Moving page to new parent") $ movePage methods newPageId moveReq @@ -166,7 +167,7 @@ putStrLn $ "Unexpected parent type: " <> show other -- Move it back to the original parent - let moveBackReq = MovePage {parent = PageParent {pageId = parentPageId}, position = Nothing} + let moveBackReq = MovePage {parent = MoveToPage parentPageId} _ <- runTest (Text.pack "Moving page back to original parent") $ movePage methods newPageId moveBackReq @@ -176,8 +177,10 @@ UpdatePage { properties = fromList [], inTrash = Just True, - icon = Nothing, - cover = Nothing, + isLocked = Nothing, + isArchived = Nothing, + icon = Unset, + cover = Unset, template = Nothing, eraseContent = Nothing } diff --git a/notion-client-example/PageDemo.hs b/notion-client-example/PageDemo.hs --- a/notion-client-example/PageDemo.hs +++ b/notion-client-example/PageDemo.hs @@ -13,7 +13,7 @@ import Notion.V1 (Methods (..)) import Notion.V1.BlockContent (BlockContent, CodeLanguage (..), calloutBlock, codeBlock, mkRichText, quoteBlock) import Notion.V1.Blocks qualified as Blocks -import Notion.V1.Comments (CommentObject (..), CreateComment (..)) +import Notion.V1.Comments (CommentContent (..), CommentObject (..), CommentResponse (..), commentResponseId, mkCreateComment) import Notion.V1.Common (Icon (..), Parent (..)) import Notion.V1.ListOf (ListOf (..)) import Notion.V1.RichText (RichText (..), RichTextContent (..), TextContent (..), defaultAnnotations) @@ -68,21 +68,19 @@ blockCommentParent = BlockParent {blockId = firstBlockId} -- Create the comment request for the block - createBlockCommentRequest = - CreateComment - { parent = blockCommentParent, - richText = blockCommentRichText, - discussionId = Nothing -- Creates a new discussion thread on the block - } + -- Creates a new discussion thread on the block + createBlockCommentRequest = mkCreateComment blockCommentParent (CommentRichText blockCommentRichText) -- Create the comment on the block blockComment <- runTest (Text.pack "Creating comment on block") $ createComment methods createBlockCommentRequest - let CommentObject {id = blockCommentId, discussionId = blockDiscId} = blockComment - putStrLn $ "Block comment created with ID: " <> show blockCommentId - putStrLn $ "Block discussion ID: " <> show blockDiscId + putStrLn $ "Block comment created with ID: " <> show (commentResponseId blockComment) + case blockComment of + FullComment CommentObject {discussionId = blockDiscId} -> + putStrLn $ "Block discussion ID: " <> show blockDiscId + PartialComment _ -> pure () -- List comments on the block blockComments <- diff --git a/notion-client-example/TemplateDemo.hs b/notion-client-example/TemplateDemo.hs --- a/notion-client-example/TemplateDemo.hs +++ b/notion-client-example/TemplateDemo.hs @@ -16,6 +16,7 @@ import Data.Text qualified as Text import Data.Vector qualified as Vector import Notion.V1 (Methods (..)) +import Notion.V1.Clearable (Clearable (..)) import Notion.V1.Common (Parent (..)) import Notion.V1.DataSources (ListTemplatesResponse (..), TemplateRef (..)) import Notion.V1.Databases (DataSource (..), DatabaseObject (..)) @@ -81,7 +82,7 @@ -- template variables resolve. createReq = CreatePage - { parent = DataSourceParent {dataSourceId = dsId, parentDatabaseId = Nothing}, + { parent = Just (DataSourceParent {dataSourceId = dsId, parentDatabaseId = Nothing}), properties = props, children = Nothing, markdown = Nothing, @@ -104,8 +105,10 @@ UpdatePage { properties = fromList [], inTrash = Just True, - icon = Nothing, - cover = Nothing, + isLocked = Nothing, + isArchived = Nothing, + icon = Unset, + cover = Unset, template = Nothing, eraseContent = Nothing } diff --git a/notion-client-example/ViewDemo.hs b/notion-client-example/ViewDemo.hs --- a/notion-client-example/ViewDemo.hs +++ b/notion-client-example/ViewDemo.hs @@ -6,6 +6,7 @@ -- - Retrieve a view -- - Update a view (rename, add sorts) -- - List all views on a database +-- - Query a view's rows -- - Delete a view module ViewDemo ( runViewDemo, @@ -13,14 +14,15 @@ where import Console (printHeader, printSuccess, runTest) -import Data.Aeson qualified as Aeson +import Control.Monad (when) import Data.String (fromString) import Data.Text qualified as Text import Data.Vector qualified as Vector import Notion.V1 (Methods (..)) -import Notion.V1.Common (UUID (..)) import Notion.V1.Databases (DataSource (..), DatabaseObject (..)) +import Notion.V1.Filter (SortDirection (..)) import Notion.V1.ListOf (ListOf (..)) +import Notion.V1.ViewQueries (queryAllViewPages) import Notion.V1.Views import Prelude hiding (id) @@ -54,8 +56,21 @@ filter = Nothing, sorts = Nothing, quickFilters = Nothing, - configuration = Nothing, - position = Nothing + createDatabase_ = Nothing, + configuration = + Just + ( TableConfig + TableViewConfig + { properties = Unset, + groupBy = Unset, + subtasks = Unset, + wrapCells = Just True, + frozenColumnIndex = Nothing, + showVerticalLines = Nothing + } + ), + position = Just ViewPositionEnd, + placement = Nothing } view <- @@ -100,15 +115,9 @@ let updateReq = UpdateView { name = Just "API Demo - Table View (Updated)", - filter = Nothing, - sorts = - Just $ - Vector.singleton $ - Aeson.object - [ ("property", Aeson.String "title"), - ("direction", Aeson.String "ascending") - ], - quickFilters = Nothing, + filter = Unset, + sorts = Set (Vector.singleton ViewPropertySort {property = "title", direction = Ascending}), + quickFilters = Unset, configuration = Nothing } @@ -139,7 +148,47 @@ putStrLn $ " - " <> show vid <> " (type: " <> show vtype <> ")" -- --------------------------------------------------------------- - -- Part 5: Delete the view + -- Part 5: Query the view's rows + -- --------------------------------------------------------------- + printHeader (Text.pack "Views: Query View Rows") + + query <- + runTest (Text.pack "Creating view query") $ + createViewQuery methods viewId CreateViewQuery {pageSize = Just 5} + + let ViewQuery + { id = queryId, + totalCount = qTotal, + expiresAt = qExpires, + results = qResults, + nextCursor = qCursor, + hasMore = qMore + } = query + putStrLn $ " query id: " <> show queryId + putStrLn $ " totalCount: " <> show qTotal + putStrLn $ " expiresAt: " <> show qExpires + putStrLn $ " first page: " <> show (Vector.length qResults) <> " results" + + when qMore $ do + nextPage <- + runTest (Text.pack "Fetching the next page of results") $ + getViewQueryResults methods viewId queryId qCursor (Just 5) + let List {results = nextResults} = nextPage + putStrLn $ " next page: " <> show (Vector.length nextResults) <> " results" + + deletedQuery <- + runTest (Text.pack "Deleting view query") $ + deleteViewQuery methods viewId queryId + let DeletedViewQuery {deleted = queryDeleted} = deletedQuery + putStrLn $ " deleted: " <> show queryDeleted + + allPages <- + runTest (Text.pack "Collecting all rows with queryAllViewPages") $ + queryAllViewPages methods viewId (Just 100) + putStrLn $ " queryAllViewPages: " <> show (Vector.length allPages) <> " page references" + + -- --------------------------------------------------------------- + -- Part 6: Delete the view -- --------------------------------------------------------------- printHeader (Text.pack "Views: Delete View") diff --git a/notion-client.cabal b/notion-client.cabal --- a/notion-client.cabal +++ b/notion-client.cabal @@ -1,7 +1,7 @@ -cabal-version: 3.4 -name: notion-client -version: 0.7.0.2 -synopsis: Type-safe Haskell client for the Notion API +cabal-version: 3.4 +name: notion-client +version: 0.8.0.0 +synopsis: Type-safe Haskell client for the Notion API description: This package provides comprehensive and type-safe bindings to the Notion API, providing both a Servant interface and @@ -12,15 +12,15 @@ Otherwise, browse the "Notion.V1" module, which is the intended package entrypoint. -license: MIT -license-file: LICENSE -category: Web -author: Nadeem Bitar -maintainer: nadeem@gmail.com -homepage: https://github.com/shinzui/notion-client -bug-reports: https://github.com/shinzui/notion-client/issues -build-type: Simple -tested-with: GHC ==9.12.2 +license: MIT +license-file: LICENSE +category: Web +author: Nadeem Bitar +maintainer: nadeem@gmail.com +homepage: https://github.com/shinzui/notion-client +bug-reports: https://github.com/shinzui/notion-client/issues +build-type: Simple +tested-with: ghc ==9.12.2 extra-doc-files: CHANGELOG.md README.md @@ -28,70 +28,103 @@ extra-source-files: LICENSE source-repository head - type: git + type: git location: https://github.com/shinzui/notion-client.git library - default-language: GHC2024 - hs-source-dirs: src + default-language: GHC2024 + hs-source-dirs: src build-depends: - , aeson >=2.2 && <2.3 - , base >=4.15.0.0 && <5 - , base16-bytestring >=1.0 && <1.1 - , bytestring >=0.11 && <0.13 - , containers >=0.6 && <0.8 - , cryptohash-sha256 >=0.11 && <0.12 - , filepath >=1.4 && <1.6 - , http-api-data >=0.6 && <0.7 - , http-client-tls >=0.3 && <0.4 - , scientific >=0.3 && <0.4 - , servant >=0.20 && <0.21 - , servant-client >=0.20 && <0.21 - , servant-multipart-api >=0.12 && <0.13 - , servant-multipart-client >=0.12 && <0.13 - , text >=2.0 && <2.2 - , time >=1.11 && <1.15 - , time-compat >=1.9 && <1.10 - , unordered-containers >=0.2 && <0.3 - , vector >=0.13 && <0.14 + aeson >=2.2 && <2.3, + base >=4.15.0.0 && <5, + base16-bytestring >=1.0 && <1.1, + base64-bytestring >=1.2 && <1.3, + bytestring >=0.11 && <0.13, + containers >=0.6 && <0.8, + cryptohash-sha256 >=0.11 && <0.12, + filepath >=1.4 && <1.6, + http-api-data >=0.6 && <0.7, + http-client >=0.7.16 && <0.8, + http-client-tls >=0.3 && <0.4, + http-types >=0.12 && <0.13, + mtl >=2.2 && <2.4, + random >=1.2 && <1.4, + scientific >=0.3 && <0.4, + servant >=0.20 && <0.21, + servant-client >=0.20.2 && <0.21, + servant-client-core >=0.20.2 && <0.21, + servant-multipart-api >=0.12 && <0.13, + servant-multipart-client >=0.12 && <0.13, + text >=2.0 && <2.2, + time >=1.11 && <1.15, + time-compat >=1.9 && <1.10, + unordered-containers >=0.2 && <0.3, + vector >=0.13 && <0.14, exposed-modules: Notion.V1 + Notion.V1.AsyncTasks Notion.V1.BlockContent Notion.V1.Blocks + Notion.V1.Clearable + Notion.V1.Client Notion.V1.Comments Notion.V1.Common Notion.V1.CustomEmojis - Notion.V1.Databases + Notion.V1.DataSourceRows Notion.V1.DataSources + Notion.V1.Databases Notion.V1.Error Notion.V1.FileUploads Notion.V1.Filter + Notion.V1.Helpers Notion.V1.ListOf + Notion.V1.MeetingNotes + Notion.V1.OAuth Notion.V1.Pages Notion.V1.Pagination Notion.V1.Properties Notion.V1.PropertyValue + Notion.V1.Retry Notion.V1.RichText Notion.V1.Search Notion.V1.Users + Notion.V1.ViewConfig + Notion.V1.ViewQueries Notion.V1.Views Notion.V1.Webhooks - other-modules: Notion.Prelude + other-modules: + Notion.Prelude + Paths_notion_client + + autogen-modules: Paths_notion_client default-extensions: DuplicateRecordFields OverloadedLabels OverloadedStrings RecordWildCards - ghc-options: -Wall + ghc-options: -Wall test-suite tasty - default-language: GHC2024 - type: exitcode-stdio-1.0 - hs-source-dirs: tasty - main-is: Main.hs + default-language: GHC2024 + type: exitcode-stdio-1.0 + hs-source-dirs: tasty + main-is: Main.hs + other-modules: + AsyncTaskTests + CommentTests + DataSourceSearchTests + FakeNotion + HelpersTests + MeetingNotesTests + OAuthTests + ObjectFieldTests + RuntimeTests + ViewTests + WireFormatTests + default-extensions: DuplicateRecordFields OverloadedLabels @@ -99,27 +132,31 @@ RecordWildCards build-depends: - , aeson - , base - , bytestring - , containers - , http-api-data - , http-client - , http-client-tls - , notion-client - , scientific - , servant-client - , tasty - , tasty-hunit - , text - , vector + aeson, + base, + bytestring, + containers, + http-api-data, + http-client, + http-client-tls, + http-types, + mtl, + notion-client, + scientific, + servant-client, + servant-client-core, + tasty, + tasty-hunit, + text, + time, + vector, - ghc-options: -Wall + ghc-options: -Wall executable notion-client-example - default-language: GHC2024 - hs-source-dirs: notion-client-example - main-is: Main.hs + default-language: GHC2024 + hs-source-dirs: notion-client-example + main-is: Main.hs other-modules: BlockDemo Blocks @@ -140,13 +177,13 @@ RecordWildCards build-depends: - , aeson - , base - , containers - , notion-client - , scientific - , text - , unordered-containers - , vector + aeson, + base, + containers, + notion-client, + scientific, + text, + unordered-containers, + vector, - ghc-options: -Wall + ghc-options: -Wall diff --git a/src/Notion/V1.hs b/src/Notion/V1.hs --- a/src/Notion/V1.hs +++ b/src/Notion/V1.hs @@ -14,9 +14,9 @@ -- main = do -- token <- Environment.getEnv "NOTION_TOKEN" -- --- clientEnv <- getClientEnv "https://api.notion.com/v1" +-- manager <- newTlsManager -- --- let methods = makeMethods clientEnv (Text.pack token) +-- let methods = makeMethodsWith defaultClientConfig manager (Text.pack token) -- -- page <- retrievePage methods "page-id-here" -- @@ -26,21 +26,66 @@ ( -- * Methods getClientEnv, makeMethods, + makeMethodsWith, + makeMethodsWithEnv, Methods (..), + -- * Configuration + ClientConfig (..), + defaultClientConfig, + legacyClientConfig, + defaultBaseUrl, + defaultNotionVersion, + RetryOptions (..), + defaultRetryOptions, + noRetries, + LogLevel (..), + Logger, + stderrLogger, + + -- * Runtime building blocks + RequestContext (..), + requestContextFor, + standardHeaders, + responseTimeoutFor, + withRetries, + -- * Servant API, ) where -import Control.Exception qualified as Exception +import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (..)) import Data.Text qualified as Text +import Network.HTTP.Client (Manager) import Network.HTTP.Client.TLS qualified as TLS import Notion.Prelude +import Notion.V1.AsyncTasks (AllowAsync (..), AsyncOr, AsyncTask, AsyncTaskID, fromAsyncUnion) +import Notion.V1.AsyncTasks qualified as AsyncTasks import Notion.V1.Blocks (BlockID, BlockObject) import Notion.V1.Blocks qualified as Blocks -import Notion.V1.Comments (CommentObject) +import Notion.V1.Client + ( ClientConfig (..), + LogLevel (..), + Logger, + RequestContext (..), + RetryOptions (..), + configureClientEnv, + defaultBaseUrl, + defaultClientConfig, + defaultNotionVersion, + defaultRetryOptions, + legacyClientConfig, + noRetries, + requestContextFor, + responseTimeoutFor, + runClientWith, + standardHeaders, + stderrLogger, + withRetries, + ) +import Notion.V1.Comments (CommentContent, CommentObject, CommentResponse) import Notion.V1.Comments qualified as Comments import Notion.V1.Common (ParentID, UUID) import Notion.V1.CustomEmojis (CustomEmoji) @@ -49,11 +94,11 @@ import Notion.V1.DataSources qualified as DataSources import Notion.V1.Databases (CreateDatabase, DatabaseID, DatabaseObject, QueryDatabase, UpdateDatabase) import Notion.V1.Databases qualified as Databases -import Notion.V1.Error (parseNotionError) import Notion.V1.FileUploads (FileUploadID, FileUploadObject, FileUploadStatus) import Notion.V1.FileUploads qualified as FileUploads import Notion.V1.ListOf (ListOf (..)) -import Notion.V1.Pages (CreatePage, MovePage, PageID, PageMarkdown, PageObject, PropertyItemResponse, UpdatePage, UpdatePageMarkdown) +import Notion.V1.MeetingNotes qualified as MeetingNotes +import Notion.V1.Pages (CreatePage, MovePage, PageID, PageMarkdown, PageObject, PartialPageObject, PropertyItemResponse, UpdatePage, UpdatePageMarkdown) import Notion.V1.Pages qualified as Pages import Notion.V1.Search (SearchRequest) import Notion.V1.Search qualified as Search @@ -75,35 +120,56 @@ manager <- TLS.newTlsManager pure (Client.mkClientEnv manager baseUrl) --- | Get a record of API methods after providing an API token +-- | Get a record of API methods after providing an API token. +-- +-- Uses 'legacyClientConfig': default API version, retries and @User-Agent@, +-- keeping the 'ClientEnv' manager's own timeout. makeMethods :: ClientEnv -> -- | API token Text -> Methods -makeMethods clientEnv token = Methods {..} +makeMethods = makeMethodsWithEnv legacyClientConfig + +-- | Build 'Methods' from a configuration, a connection manager (for example +-- from 'Network.HTTP.Client.TLS.newTlsManager') and an API token. The base URL +-- comes from 'apiBaseUrl'. +makeMethodsWith :: ClientConfig -> Manager -> Text -> Methods +makeMethodsWith config manager = + makeMethodsWithEnv config (Client.mkClientEnv manager (apiBaseUrl config)) + +-- | Build 'Methods' from a configuration, an existing 'ClientEnv' (which +-- supplies the manager and base URL) and an API token. +makeMethodsWithEnv :: + ClientConfig -> + ClientEnv -> + -- | API token + Text -> + Methods +makeMethodsWithEnv config clientEnv token = Methods {..} where - notionVersion = "2026-03-11" -- Notion API version with markdown content support - -- If you experience 400 errors, check for updated versions at - -- https://developers.notion.com/reference/versioning + context = requestContextFor config clientEnv token + configuredEnv = configureClientEnv config clientEnv ( ( createDatabase :<|> retrieveDatabase :<|> updateDatabase - :<|> queryDatabase + :<|> queryDatabase_ ) :<|> ( retrieveDataSource :<|> createDataSource :<|> updateDataSource - :<|> queryDataSource + :<|> queryDataSource_ :<|> listDataSourceTemplates_ ) :<|> ( retrievePageFiltered - :<|> createPage - :<|> updatePage + :<|> createPageFiltered + :<|> updatePageFiltered :<|> retrievePageProperty :<|> retrievePageMarkdown :<|> updatePageMarkdown :<|> movePage + :<|> createPageAsync_ + :<|> updatePageMarkdownAsync_ ) :<|> ( retrieveBlock :<|> updateBlock @@ -118,13 +184,18 @@ :<|> search_ :<|> ( createComment :<|> listComments_ + :<|> retrieveComment + :<|> updateComment + :<|> deleteComment ) :<|> ( createView :<|> retrieveView :<|> updateView :<|> deleteView :<|> listViews_ - :<|> queryView + :<|> createViewQuery + :<|> getViewQueryResults_ + :<|> deleteViewQuery ) :<|> listCustomEmojis_ :<|> ( createFileUpload @@ -133,22 +204,37 @@ :<|> completeFileUpload :<|> listFileUploads_ ) - ) = Client.hoistClient @API Proxy run (Client.client @API Proxy) authorization notionVersion - - authorization = "Bearer " <> token + :<|> retrieveAsyncTask + :<|> ( createMeetingNote + :<|> queryMeetingNotes + ) + ) = + Client.hoistClient + @API + Proxy + run + (Client.client @API Proxy) + (contextAuthorization context) + (notionVersion config) run :: Client.ClientM a -> IO a - run clientM = do - result <- Client.runClientM clientM clientEnv - case result of - Left err -> case parseNotionError err of - Just notionErr -> Exception.throwIO notionErr - Nothing -> Exception.throwIO err - Right a -> return a + run = runClientWith configuredEnv -- Wrap retrievePageFiltered to provide backward-compatible retrievePage retrievePage pid = retrievePageFiltered pid [] + createPage = createPageFiltered [] + updatePage pid = updatePageFiltered pid [] + -- The async variants always send allow_async: true + createPageAsync req = fromAsyncUnion <$> createPageAsync_ (AllowAsync req) + updatePageMarkdownAsync pid req = fromAsyncUnion <$> updatePageMarkdownAsync_ pid (AllowAsync req) + + -- filter_properties is sent as repeated query parameters (see DataSources.API) + queryDataSource dsId q@DataSources.QueryDataSource {filterProperties = props} = + queryDataSource_ dsId (fromMaybe [] props) q + queryDatabase dbId q@Databases.QueryDatabase {filterProperties = props} = + queryDatabase_ dbId (fromMaybe [] props) q + -- Keep the ListOf structure listBlockChildren = retrieveBlockChildren_ listUsers = listUsers_ @@ -156,6 +242,7 @@ search = search_ listDataSourceTemplates = listDataSourceTemplates_ listViews = listViews_ + getViewQueryResults = getViewQueryResults_ listCustomEmojis = listCustomEmojis_ listFileUploads = listFileUploads_ sendFileUploadContent fid upload = do @@ -174,7 +261,7 @@ retrieveDataSource :: DataSourceID -> IO DataSourceObject, createDataSource :: DataSources.CreateDataSource -> IO DataSourceObject, updateDataSource :: DataSourceID -> DataSources.UpdateDataSource -> IO DataSourceObject, - queryDataSource :: DataSourceID -> DataSources.QueryDataSource -> IO (ListOf PageObject), + queryDataSource :: DataSourceID -> DataSources.QueryDataSource -> IO (ListOf DataSources.PageOrDataSource), -- | List templates available for a data source listDataSourceTemplates :: DataSourceID -> @@ -187,10 +274,14 @@ IO DataSources.ListTemplatesResponse, -- \* Pages createPage :: CreatePage -> IO PageObject, + -- | Create a page, limiting which properties the response includes. + createPageFiltered :: [Text] -> CreatePage -> IO PageObject, retrievePage :: PageID -> IO PageObject, -- | Retrieve a page, optionally filtering which properties are returned. retrievePageFiltered :: PageID -> [Text] -> IO PageObject, updatePage :: PageID -> UpdatePage -> IO PageObject, + -- | Update a page, limiting which properties the response includes. + updatePageFiltered :: PageID -> [Text] -> UpdatePage -> IO PageObject, -- | Retrieve a single page property item. -- For title, rich_text, relation, and people properties, the response may be paginated. retrievePageProperty :: @@ -218,9 +309,17 @@ PageID -> MovePage -> IO PageObject, + -- | Like 'createPage' but sends @allow_async: true@, so Notion may answer + -- with an async task instead of the page. Only meaningful when the + -- request's @markdown@ is set. + createPageAsync :: CreatePage -> IO (AsyncOr PageObject), + -- | Like 'updatePageMarkdown' but sends @allow_async: true@, so Notion may + -- answer with an async task instead of the result. + updatePageMarkdownAsync :: PageID -> UpdatePageMarkdown -> IO (AsyncOr PageMarkdown), -- \* Blocks retrieveBlock :: BlockID -> IO BlockObject, - updateBlock :: BlockID -> Blocks.BlockUpdate -> IO BlockObject, + -- | Update part of a block, or trash it with 'Blocks.trashBlockUpdate'. + updateBlock :: BlockID -> Blocks.BlockUpdatePayload -> IO BlockObject, listBlockChildren :: ParentID -> Maybe Natural -> @@ -240,9 +339,11 @@ IO (ListOf UserObject), retrieveMyUser :: IO UserObject, -- \* Search - search :: SearchRequest -> IO (ListOf Value), + search :: SearchRequest -> IO (ListOf Search.PageOrDataSource), -- \* Comments - createComment :: Comments.CreateComment -> IO CommentObject, + + -- | Create a comment on a page or block, or a reply in a discussion. + createComment :: Comments.CreateComment -> IO CommentResponse, -- | List comments on a block or page. To list comments on a page, use the page ID -- as the block_id parameter (pages are blocks in Notion). listComments :: @@ -253,6 +354,10 @@ Maybe Natural -> -- \^ page_size IO (ListOf CommentObject), + retrieveComment :: Comments.CommentID -> IO CommentResponse, + -- | Replace a comment's content with rich text or Markdown. + updateComment :: Comments.CommentID -> CommentContent -> IO CommentResponse, + deleteComment :: Comments.CommentID -> IO CommentResponse, -- \* Views createView :: Views.CreateView -> IO ViewObject, retrieveView :: Views.ViewID -> IO ViewObject, @@ -268,7 +373,20 @@ Maybe Natural -> -- \^ page_size IO (ListOf ViewObject), - queryView :: Views.ViewID -> Views.QueryView -> IO (ListOf PageObject), + -- | Create a view query: a short-lived snapshot of the rows a view shows, + -- with its first page of results. + createViewQuery :: Views.ViewID -> Views.CreateViewQuery -> IO Views.ViewQuery, + -- | Page through a view query's results. + getViewQueryResults :: + Views.ViewID -> + Views.ViewQueryID -> + Maybe Text -> + -- \^ start_cursor + Maybe Natural -> + -- \^ page_size + IO (ListOf PartialPageObject), + -- | Delete a view query before it expires. + deleteViewQuery :: Views.ViewID -> Views.ViewQueryID -> IO Views.DeletedViewQuery, -- \* Custom Emojis listCustomEmojis :: Maybe Text -> @@ -290,7 +408,17 @@ -- \^ start_cursor Maybe Natural -> -- \^ page_size - IO (ListOf FileUploadObject) + IO (ListOf FileUploadObject), + -- \* Async tasks + + -- | Retrieve a background task; see 'Notion.V1.AsyncTasks.waitForAsyncTask'. + retrieveAsyncTask :: AsyncTaskID -> IO AsyncTask, + -- \* Meeting notes + + -- | Create a meeting note from an uploaded recording or an existing media block. + createMeetingNote :: MeetingNotes.CreateMeetingNote -> IO MeetingNotes.CreateMeetingNoteResponse, + -- | Query meeting notes with a filter, sort and limit. Not paginated. + queryMeetingNotes :: MeetingNotes.QueryMeetingNotes -> IO MeetingNotes.QueryMeetingNotesResponse } -- | Servant API @@ -307,4 +435,6 @@ :<|> Views.API :<|> CustomEmojis.API :<|> FileUploads.API + :<|> AsyncTasks.API + :<|> MeetingNotes.API ) diff --git a/src/Notion/V1/AsyncTasks.hs b/src/Notion/V1/AsyncTasks.hs new file mode 100644 --- /dev/null +++ b/src/Notion/V1/AsyncTasks.hs @@ -0,0 +1,288 @@ +-- | @\/v1\/async_tasks@ +-- +-- Some operations run in the background: Notion answers with an +-- 'AsyncTask' instead of the finished result. Retrieve the task with +-- 'Notion.V1.retrieveAsyncTask' and wait for it with 'waitForAsyncTask'. +module Notion.V1.AsyncTasks + ( -- * Main types + AsyncTaskID, + AsyncTask (..), + AsyncTaskOperation (..), + AsyncTaskSurface (..), + AsyncTaskStatus (..), + AsyncTaskError (..), + + -- * Optionally asynchronous responses + AsyncOr (..), + AllowAsync (..), + AsyncVerb, + AsyncStatuses, + fromAsyncUnion, + + -- * Waiting + WaitOptions (..), + defaultWaitOptions, + isTerminal, + pollAfterSeconds, + waitForAsyncTask, + + -- * Servant + API, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson ((.:), (.:?), (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (Pair) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Proxy (Proxy (..)) +import Notion.Prelude +import Notion.V1.Error (APIErrorCode) +import Servant.API (UVerb, WithStatus (..)) +import Servant.API.UVerb (Union, foldMapUnion) +import Prelude hiding (id) + +-- | Async task ID (an opaque string, not necessarily a UUID) +type AsyncTaskID = Text + +-- | A long-running server-side job. +data AsyncTask = AsyncTask + { id :: AsyncTaskID, + -- | URL of the task on the API, for example + -- @https:\/\/api.notion.com\/v1\/async_tasks\/{id}@. + statusUrl :: Text, + createdTime :: POSIXTime, + operation :: AsyncTaskOperation, + status :: AsyncTaskStatus, + -- | Always @"async_task"@. + object :: Text + } + deriving stock (Eq, Generic, Show) + +-- | What started the task. +data AsyncTaskOperation = AsyncTaskOperation + { surface :: AsyncTaskSurface, + -- | The operation name. + name :: Text + } + deriving stock (Eq, Generic, Show) + +-- | The API surface the task was started from. +data AsyncTaskSurface + = SurfaceRest + | SurfaceMcp + | -- | A surface this library does not know yet; holds the raw string. + UnknownSurface Text + deriving stock (Eq, Generic, Show) + +-- | The state of a task, with the data that state carries. +data AsyncTaskStatus + = -- | Seconds to wait before polling again. + AsyncTaskQueued Double + | AsyncTaskRunning Double + | AsyncTaskRetrying Double + | -- | The operation's result. + AsyncTaskSucceeded Aeson.Object + | AsyncTaskFailed AsyncTaskError + | -- | A status this library does not know yet; holds the raw string. + UnknownAsyncTaskStatus Text + deriving stock (Eq, Generic, Show) + +-- | Why a task failed; the same shape as a Notion error response. +data AsyncTaskError = AsyncTaskError + { -- | Always @"error"@. + object :: Text, + -- | HTTP-style status, for example 400. + status :: Natural, + code :: APIErrorCode, + message :: Text, + additionalData :: Maybe Aeson.Object + } + deriving stock (Eq, Generic, Show) + +instance FromJSON AsyncTaskSurface where + parseJSON = Aeson.withText "AsyncTaskSurface" $ \case + "rest" -> pure SurfaceRest + "mcp" -> pure SurfaceMcp + other -> pure (UnknownSurface other) + +instance ToJSON AsyncTaskSurface where + toJSON = \case + SurfaceRest -> String "rest" + SurfaceMcp -> String "mcp" + UnknownSurface t -> String t + +instance FromJSON AsyncTaskOperation where + parseJSON = Aeson.withObject "AsyncTaskOperation" $ \o -> + AsyncTaskOperation <$> o .: "surface" <*> o .: "name" + +instance ToJSON AsyncTaskOperation where + toJSON AsyncTaskOperation {..} = Aeson.object ["surface" .= surface, "name" .= name] + +instance FromJSON AsyncTaskError where + parseJSON = Aeson.withObject "AsyncTaskError" $ \o -> do + object <- o .: "object" + status <- o .: "status" + code <- o .: "code" + message <- o .: "message" + additionalData <- o .:? "additional_data" + pure AsyncTaskError {..} + +instance ToJSON AsyncTaskError where + toJSON AsyncTaskError {..} = + Aeson.object $ + [ "object" .= object, + "status" .= status, + "code" .= code, + "message" .= message + ] + <> catMaybes [("additional_data" .=) <$> additionalData] + +instance FromJSON AsyncTask where + parseJSON = Aeson.withObject "AsyncTask" $ \o -> do + id <- o .: "id" + statusUrl <- o .: "status_url" + createdTime <- parseISO8601 =<< o .: "created_time" + operation <- o .: "operation" + object <- o .: "object" + statusText <- o .: "status" + status <- case statusText :: Text of + "queued" -> AsyncTaskQueued <$> o .: "poll_after_seconds" + "running" -> AsyncTaskRunning <$> o .: "poll_after_seconds" + "retrying" -> AsyncTaskRetrying <$> o .: "poll_after_seconds" + "succeeded" -> AsyncTaskSucceeded . fromMaybe mempty <$> o .:? "result" + "failed" -> AsyncTaskFailed <$> o .: "error" + other -> pure (UnknownAsyncTaskStatus other) + pure AsyncTask {..} + +instance ToJSON AsyncTask where + toJSON AsyncTask {..} = + Aeson.object $ + [ "object" .= object, + "id" .= id, + "status_url" .= statusUrl, + "created_time" .= posixToISO8601 createdTime, + "operation" .= operation + ] + <> case status of + AsyncTaskQueued s -> pending "queued" s + AsyncTaskRunning s -> pending "running" s + AsyncTaskRetrying s -> pending "retrying" s + AsyncTaskSucceeded r -> ["status" .= ("succeeded" :: Text), "result" .= r] + AsyncTaskFailed e -> ["status" .= ("failed" :: Text), "error" .= e] + UnknownAsyncTaskStatus t -> ["status" .= t] + where + pending :: Text -> Double -> [Pair] + pending s secs = ["status" .= s, "poll_after_seconds" .= secs] + +-- | A response that is either an accepted async task or the finished result. +data AsyncOr a + = AcceptedAsync AsyncTask + | CompletedSync a + deriving stock (Eq, Generic, Show) + +-- | An object whose @object@ key is @"async_task"@ is a task; anything else +-- is decoded as the synchronous result. +instance (FromJSON a) => FromJSON (AsyncOr a) where + parseJSON v = case v of + Object o | KeyMap.lookup "object" o == Just (String "async_task") -> AcceptedAsync <$> parseJSON v + _ -> CompletedSync <$> parseJSON v + +-- | The responses of an endpoint that may run in the background: Notion +-- answers @200 OK@ with the result when it finished synchronously and +-- @202 Accepted@ with an 'AsyncTask' when it queued the work. Either body is +-- decoded by 'AsyncOr'\'s instance. +type AsyncStatuses a = '[WithStatus 200 (AsyncOr a), WithStatus 202 (AsyncOr a)] + +-- | Route verb for such an endpoint, for example @AsyncVerb 'POST PageObject@. +-- +-- A plain @Post '[JSON]@ route accepts only status 200, so servant-client +-- would reject the 202 response. +type AsyncVerb method a = UVerb method '[JSON] (AsyncStatuses a) + +-- | Collapse the response union of an 'AsyncVerb' route. +fromAsyncUnion :: forall a. Union (AsyncStatuses a) -> AsyncOr a +fromAsyncUnion = foldMapUnion (Proxy @(UnwrapStatus (AsyncOr a))) unwrapStatus + +class UnwrapStatus a x where + unwrapStatus :: x -> a + +instance (b ~ a) => UnwrapStatus a (WithStatus n b) where + unwrapStatus (WithStatus x) = x + +-- | Request wrapper that adds @"allow_async": true@ to an object body. +-- Non-object bodies are sent unchanged. +newtype AllowAsync a = AllowAsync a + deriving stock (Show) + +instance (ToJSON a) => ToJSON (AllowAsync a) where + toJSON (AllowAsync a) = case toJSON a of + Object o -> Object (KeyMap.insert "allow_async" (Bool True) o) + other -> other + +-- | Limits for 'waitForAsyncTask'. +data WaitOptions = WaitOptions + { -- | Retrieve calls before giving up. + maxAttempts :: Natural, + -- | Upper bound, in seconds, on any single wait. + maxPollSeconds :: Double + } + deriving stock (Eq, Show) + +-- | 120 attempts, waiting at most 30 seconds between them. +defaultWaitOptions :: WaitOptions +defaultWaitOptions = WaitOptions {maxAttempts = 120, maxPollSeconds = 30} + +-- | Whether the task will not change any more. An unknown status counts as +-- terminal so that callers see it instead of polling a state they cannot +-- interpret. +isTerminal :: AsyncTask -> Bool +isTerminal AsyncTask {status} = case status of + AsyncTaskQueued _ -> False + AsyncTaskRunning _ -> False + AsyncTaskRetrying _ -> False + AsyncTaskSucceeded _ -> True + AsyncTaskFailed _ -> True + UnknownAsyncTaskStatus _ -> True + +-- | The server's polling hint, for tasks that are still pending. +pollAfterSeconds :: AsyncTask -> Maybe Double +pollAfterSeconds AsyncTask {status} = case status of + AsyncTaskQueued s -> Just s + AsyncTaskRunning s -> Just s + AsyncTaskRetrying s -> Just s + _ -> Nothing + +-- | Poll a task until it is terminal or 'maxAttempts' retrieve calls have +-- been made, sleeping for the task's @poll_after_seconds@ (capped by +-- 'maxPollSeconds') before each call. Returns the last task seen; check +-- 'isTerminal' on the result to detect giving up. +-- +-- Pass the retrieve function: @waitForAsyncTask defaultWaitOptions +-- (retrieveAsyncTask methods) task@ in 'IO', or the @retrieveAsyncTask@ +-- smart constructor from @notion-client-effectful@ in @Eff@. +waitForAsyncTask :: + (MonadIO m) => + WaitOptions -> + (AsyncTaskID -> m AsyncTask) -> + AsyncTask -> + m AsyncTask +waitForAsyncTask WaitOptions {..} retrieve = go 0 + where + go attempts task + | isTerminal task || attempts >= maxAttempts = pure task + | otherwise = do + let secs = min maxPollSeconds (max 0 (fromMaybe 0 (pollAfterSeconds task))) + liftIO (threadDelay (round (secs * 1000000))) + let AsyncTask {id = taskId} = task + next <- retrieve taskId + go (attempts + 1) next + +-- | Servant API +type API = + "async_tasks" + :> Capture "task_id" AsyncTaskID + :> Get '[JSON] AsyncTask diff --git a/src/Notion/V1/BlockContent.hs b/src/Notion/V1/BlockContent.hs --- a/src/Notion/V1/BlockContent.hs +++ b/src/Notion/V1/BlockContent.hs @@ -12,11 +12,28 @@ blockContentFields, parseBlockContent, - -- * Block update wrapper - BlockUpdate (..), + -- * Block updates + BlockUpdatePayload (..), + BlockUpdateContent (..), + ParagraphUpdate (..), + HeadingUpdate (..), + TextColorUpdate (..), + ToDoUpdate (..), + CodeUpdate (..), + MediaUpdate (..), + MediaSourceUpdate (..), + UrlCaptionUpdate (..), + TableUpdate (..), + mkBlockUpdate, + trashBlockUpdate, + blockUpdateFromContent, -- * Supporting types CodeLanguage (..), + MeetingNotesStatus (..), + MeetingNotesChildren (..), + MeetingCalendarEvent (..), + MeetingRecording (..), FileSource (..), ListFormat (..), SyncedFrom (..), @@ -38,6 +55,7 @@ bookmarkBlock, dividerBlock, imageBlock, + tabBlock, -- * Combinators withChildren, @@ -51,7 +69,7 @@ import Data.Maybe (fromMaybe) import Data.Vector qualified as Vector import Notion.Prelude -import Notion.V1.Common (Color (..), ExternalFile, File, Icon, UUID) +import Notion.V1.Common (Color (..), ExternalFile (ExternalFile), File, Icon, UUID) import Notion.V1.RichText (RichText (..), RichTextContent (..), TextContent (..), defaultAnnotations) -- --------------------------------------------------------------------------- @@ -61,18 +79,26 @@ -- | Programming language for code blocks. data CodeLanguage = Abap + | Abc + | Agda | Arduino + | AsciiArt + | Assembly | Bash | Basic + | Bnf | C | Clojure | CoffeeScript + | Coq | Cpp | CSharp | Css | Dart + | Dhall | Diff | Docker + | Ebnf | Elixir | Elm | Erlang @@ -85,7 +111,9 @@ | GraphQL | Groovy | Haskell + | Hcl | Html + | Idris | Java | JavaScript | Json @@ -95,13 +123,16 @@ | Less | Lisp | LiveScript + | LlvmIr | Lua | Makefile | Markdown | Markup + | Mathematica | Matlab | Mermaid | Nix + | NotionFormula | ObjectiveC | OCaml | Pascal @@ -111,8 +142,10 @@ | PowerShell | Prolog | Protobuf + | PureScript | Python | R + | Racket | Reason | Ruby | Rust @@ -121,8 +154,11 @@ | Scheme | Scss | Shell + | Smalltalk + | Solidity | Sql | Swift + | Toml | TypeScript | VbNet | Verilog @@ -132,6 +168,8 @@ | Xml | Yaml | JavaCCppCSharp + | -- | A language this library does not know yet; holds the raw string. + OtherLanguage Text deriving stock (Eq, Show, Generic) instance FromJSON CodeLanguage where @@ -207,8 +245,26 @@ "webassembly" -> pure WebAssembly "xml" -> pure Xml "yaml" -> pure Yaml + "abc" -> pure Abc + "agda" -> pure Agda + "ascii art" -> pure AsciiArt + "assembly" -> pure Assembly + "bnf" -> pure Bnf + "coq" -> pure Coq + "dhall" -> pure Dhall + "ebnf" -> pure Ebnf + "hcl" -> pure Hcl + "idris" -> pure Idris + "llvm ir" -> pure LlvmIr + "mathematica" -> pure Mathematica + "notion formula" -> pure NotionFormula + "purescript" -> pure PureScript + "racket" -> pure Racket + "smalltalk" -> pure Smalltalk + "solidity" -> pure Solidity + "toml" -> pure Toml "java/c/c++/c#" -> pure JavaCCppCSharp - other -> fail $ "Unknown CodeLanguage: " <> unpack other + other -> pure (OtherLanguage other) instance ToJSON CodeLanguage where toJSON = \case @@ -283,8 +339,113 @@ WebAssembly -> Aeson.String "webassembly" Xml -> Aeson.String "xml" Yaml -> Aeson.String "yaml" + Abc -> Aeson.String "abc" + Agda -> Aeson.String "agda" + AsciiArt -> Aeson.String "ascii art" + Assembly -> Aeson.String "assembly" + Bnf -> Aeson.String "bnf" + Coq -> Aeson.String "coq" + Dhall -> Aeson.String "dhall" + Ebnf -> Aeson.String "ebnf" + Hcl -> Aeson.String "hcl" + Idris -> Aeson.String "idris" + LlvmIr -> Aeson.String "llvm ir" + Mathematica -> Aeson.String "mathematica" + NotionFormula -> Aeson.String "notion formula" + PureScript -> Aeson.String "purescript" + Racket -> Aeson.String "racket" + Smalltalk -> Aeson.String "smalltalk" + Solidity -> Aeson.String "solidity" + Toml -> Aeson.String "toml" JavaCCppCSharp -> Aeson.String "java/c/c++/c#" + OtherLanguage t -> Aeson.String t +-- | Processing state of a meeting-notes block. +data MeetingNotesStatus + = TranscriptionNotStarted + | TranscriptionPaused + | TranscriptionInProgress + | TranscriptionFailed + | SummaryInProgress + | NotesReady + | -- | A status this library does not know yet; holds the raw string. + UnknownMeetingNotesStatus Text + deriving stock (Eq, Show, Generic) + +instance FromJSON MeetingNotesStatus where + parseJSON = Aeson.withText "MeetingNotesStatus" $ \case + "transcription_not_started" -> pure TranscriptionNotStarted + "transcription_paused" -> pure TranscriptionPaused + "transcription_in_progress" -> pure TranscriptionInProgress + "transcription_failed" -> pure TranscriptionFailed + "summary_in_progress" -> pure SummaryInProgress + "notes_ready" -> pure NotesReady + other -> pure (UnknownMeetingNotesStatus other) + +instance ToJSON MeetingNotesStatus where + toJSON = \case + TranscriptionNotStarted -> Aeson.String "transcription_not_started" + TranscriptionPaused -> Aeson.String "transcription_paused" + TranscriptionInProgress -> Aeson.String "transcription_in_progress" + TranscriptionFailed -> Aeson.String "transcription_failed" + SummaryInProgress -> Aeson.String "summary_in_progress" + NotesReady -> Aeson.String "notes_ready" + UnknownMeetingNotesStatus t -> Aeson.String t + +-- | IDs of the child blocks Notion creates under a meeting-notes block. +data MeetingNotesChildren = MeetingNotesChildren + { summaryBlockId :: Maybe UUID, + notesBlockId :: Maybe UUID, + transcriptBlockId :: Maybe UUID + } + deriving stock (Eq, Show, Generic) + +instance FromJSON MeetingNotesChildren where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON MeetingNotesChildren where + toJSON = genericToJSON aesonOptions + +-- | Calendar event linked to a meeting; times are ISO 8601 strings as sent. +data MeetingCalendarEvent = MeetingCalendarEvent + { calendarStartTime :: Text, + calendarEndTime :: Text, + calendarAttendees :: Maybe (Vector UUID) + } + deriving stock (Eq, Show, Generic) + +instance FromJSON MeetingCalendarEvent where + parseJSON = Aeson.withObject "MeetingCalendarEvent" $ \o -> do + calendarStartTime <- o .: "start_time" + calendarEndTime <- o .: "end_time" + calendarAttendees <- o .:? "attendees" + pure MeetingCalendarEvent {..} + +instance ToJSON MeetingCalendarEvent where + toJSON MeetingCalendarEvent {..} = + object $ + ["start_time" .= calendarStartTime, "end_time" .= calendarEndTime] + <> maybe [] (\as -> ["attendees" .= as]) calendarAttendees + +-- | Recording window of a meeting; times are ISO 8601 strings as sent. +data MeetingRecording = MeetingRecording + { recordingStartTime :: Maybe Text, + recordingEndTime :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +instance FromJSON MeetingRecording where + parseJSON = Aeson.withObject "MeetingRecording" $ \o -> do + recordingStartTime <- o .:? "start_time" + recordingEndTime <- o .:? "end_time" + pure MeetingRecording {..} + +instance ToJSON MeetingRecording where + toJSON MeetingRecording {..} = + object $ + maybe [] (\t -> ["start_time" .= t]) recordingStartTime + <> maybe [] (\t -> ["end_time" .= t]) recordingEndTime + -- | File source for media blocks (image, video, audio, file, pdf). -- -- The API uses a @type@ discriminator with values @\"external\"@, @\"file\"@, @@ -487,7 +648,8 @@ } | -- | Audio block. AudioBlock - { audioSource :: FileSource + { audioSource :: FileSource, + caption :: Vector RichText } | -- | File attachment block. FileBlock @@ -507,7 +669,8 @@ } | -- | Embed block. EmbedBlock - { url :: Text + { url :: Text, + caption :: Vector RichText } | -- | Link to another page, database, or comment. LinkToPageBlock @@ -577,21 +740,23 @@ TabBlock { children :: Vector BlockContent } - | -- | Meeting notes block (read-only). + | -- | Meeting notes block (read-only). Also decoded from the deprecated + -- @transcription@ block type. MeetingNotesBlock - { meetingTitle :: Text, - meetingStatus :: Maybe Text, - calendarEvent :: Maybe Value, - recording :: Maybe Value, - children :: Vector BlockContent + { meetingTitle :: Maybe (Vector RichText), + meetingStatus :: Maybe MeetingNotesStatus, + calendarEvent :: Maybe MeetingCalendarEvent, + recording :: Maybe MeetingRecording, + meetingChildren :: Maybe MeetingNotesChildren } | -- | Template block (deprecated, but still returned by the API). TemplateBlock { richText :: Vector RichText, children :: Vector BlockContent } - | -- | Unsupported block type returned by the API. - UnsupportedBlock + | -- | Block type the API does not support; carries the underlying + -- @block_type@ when Notion reports it. + UnsupportedBlock (Maybe Text) | -- | Fallback for block types not yet modeled. UnknownBlock Text Value deriving stock (Eq, Generic, Show) @@ -612,8 +777,7 @@ -- | Decompose a 'BlockContent' into its JSON type name and inner content -- value. This is the serialization primitive used by both 'ToJSON BlockContent' --- (full format with @\"type\"@ key) and 'ToJSON BlockUpdate' (update format --- without @\"type\"@ key). +-- (full format with @\"type\"@ key) and 'blockUpdateFromContent'. blockContentFields :: BlockContent -> (Text, Value) blockContentFields = \case ParagraphBlock {..} -> @@ -689,7 +853,7 @@ VideoBlock {..} -> ("video", object $ fileSourcePairs videoSource <> ["caption" .= caption]) AudioBlock {..} -> - ("audio", object $ fileSourcePairs audioSource) + ("audio", object $ fileSourcePairs audioSource <> ["caption" .= caption]) FileBlock {..} -> ( "file", object $ @@ -702,7 +866,7 @@ BookmarkBlock {..} -> ("bookmark", object ["url" .= url, "caption" .= caption]) EmbedBlock {..} -> - ("embed", object ["url" .= url]) + ("embed", object ["url" .= url, "caption" .= caption]) LinkToPageBlock {..} -> ("link_to_page", toJSON linkTarget) LinkPreviewBlock {..} -> @@ -750,11 +914,11 @@ MeetingNotesBlock {..} -> ( "meeting_notes", object $ - ["title" .= meetingTitle] + maybe [] (\t -> ["title" .= t]) meetingTitle <> maybe [] (\s -> ["status" .= s]) meetingStatus <> maybe [] (\ce -> ["calendar_event" .= ce]) calendarEvent <> maybe [] (\r -> ["recording" .= r]) recording - <> childrenPairs children + <> maybe [] (\c -> ["children" .= c]) meetingChildren ) TemplateBlock {..} -> ( "template", @@ -762,8 +926,8 @@ ["rich_text" .= richText] <> childrenPairs children ) - UnsupportedBlock -> - ("unsupported", object []) + UnsupportedBlock blockType -> + ("unsupported", object (maybe [] (\t -> ["block_type" .= t]) blockType)) UnknownBlock typeName val -> (typeName, val) @@ -852,6 +1016,7 @@ pure VideoBlock {..} "audio" -> parseObj $ \o -> do audioSource <- parseFileSource o + caption <- fromMaybe Vector.empty <$> o .:? "caption" pure AudioBlock {..} "file" -> parseObj $ \o -> do fileSource <- parseFileSource o @@ -868,6 +1033,7 @@ pure BookmarkBlock {..} "embed" -> parseObj $ \o -> do url <- o .: "url" + caption <- fromMaybe Vector.empty <$> o .:? "caption" pure EmbedBlock {..} "link_to_page" -> do linkTarget <- Aeson.parseJSON val @@ -915,20 +1081,24 @@ "tab" -> parseObj $ \o -> do children <- fromMaybe Vector.empty <$> o .:? "children" pure TabBlock {..} - "meeting_notes" -> parseObj $ \o -> do - meetingTitle <- o .: "title" - meetingStatus <- o .:? "status" - calendarEvent <- o .:? "calendar_event" - recording <- o .:? "recording" - children <- fromMaybe Vector.empty <$> o .:? "children" - pure MeetingNotesBlock {..} + "meeting_notes" -> parseMeetingNotes + "transcription" -> parseMeetingNotes "template" -> parseObj $ \o -> do richText <- o .: "rich_text" children <- fromMaybe Vector.empty <$> o .:? "children" pure TemplateBlock {..} - "unsupported" -> pure UnsupportedBlock + "unsupported" -> case val of + Object o -> UnsupportedBlock <$> o .:? "block_type" + _ -> pure (UnsupportedBlock Nothing) _ -> pure (UnknownBlock typeName val) where + parseMeetingNotes = parseObj $ \o -> do + meetingTitle <- o .:? "title" + meetingStatus <- o .:? "status" + calendarEvent <- o .:? "calendar_event" + recording <- o .:? "recording" + meetingChildren <- o .:? "children" + pure MeetingNotesBlock {..} parseObj :: (Aeson.Object -> Parser BlockContent) -> Parser BlockContent parseObj f = case val of Object o -> f o @@ -948,35 +1118,251 @@ in object ["type" .= typeName, Key.fromText typeName .= inner] -- --------------------------------------------------------------------------- --- BlockUpdate +-- Block updates -- --------------------------------------------------------------------------- --- | Wrapper for block content used in the update (PATCH) endpoint. --- --- Serializes without the @\"type\"@ key — only the type-named key with inner --- content: +-- | Body of @PATCH \/v1\/blocks\/{block_id}@. Every field is optional: send +-- only 'inTrash' to trash or restore a block ('trashBlockUpdate'). -- --- @ --- { "paragraph": { "rich_text": [...] } } --- @ -newtype BlockUpdate = BlockUpdate BlockContent - deriving stock (Show) +-- Updates are a different shape from block creation: no update accepts +-- @children@, a table update accepts only its header flags, and some block +-- types cannot be updated at all. Build one with 'mkBlockUpdate', or convert +-- full block content with 'blockUpdateFromContent'. +data BlockUpdatePayload = BlockUpdatePayload + { -- | Named @updateContent@ so it does not clash with + -- 'Notion.V1.Blocks.BlockObject'\'s @content@. + updateContent :: Maybe BlockUpdateContent, + inTrash :: Maybe Bool + } + deriving stock (Eq, Generic, Show) -instance ToJSON BlockUpdate where - toJSON (BlockUpdate bc) = - let bc' = stripReadOnlyFields bc - (typeName, inner) = blockContentFields bc' - in object [Key.fromText typeName .= inner] +-- | Paragraph and callout update. Every field is optional. +data ParagraphUpdate = ParagraphUpdate + { richText :: Maybe (Vector RichText), + color :: Maybe Color, + icon :: Maybe Icon + } + deriving stock (Eq, Generic, Show) --- | Clear fields that the Notion API rejects on PATCH @\/blocks\/:id@. --- --- Both @list_start_index@ and @list_format@ are read-only — the API returns --- them in GET responses but rejects them on PATCH (and POST). -stripReadOnlyFields :: BlockContent -> BlockContent -stripReadOnlyFields bc = case bc of - NumberedListItemBlock {} -> bc {listStartIndex = Nothing, listFormat = Nothing} - _ -> bc +-- | Heading update. The API requires the rich text. +data HeadingUpdate = HeadingUpdate + { richText :: Vector RichText, + color :: Maybe Color, + isToggleable :: Maybe Bool + } + deriving stock (Eq, Generic, Show) +-- | List item, quote and toggle update. The API requires the rich text. +data TextColorUpdate = TextColorUpdate + { richText :: Vector RichText, + color :: Maybe Color + } + deriving stock (Eq, Generic, Show) + +-- | To-do update. Every field is optional. +data ToDoUpdate = ToDoUpdate + { richText :: Maybe (Vector RichText), + checked :: Maybe Bool, + color :: Maybe Color + } + deriving stock (Eq, Generic, Show) + +-- | Code block update. Every field is optional. +data CodeUpdate = CodeUpdate + { richText :: Maybe (Vector RichText), + language :: Maybe CodeLanguage, + caption :: Maybe (Vector RichText) + } + deriving stock (Eq, Generic, Show) + +-- | New source for a media block. Notion-hosted files cannot be set directly. +data MediaSourceUpdate + = UpdateExternalSource Text + | UpdateFileUploadSource UUID + deriving stock (Eq, Generic, Show) + +-- | Image, video, PDF, audio and file update. +data MediaUpdate = MediaUpdate + { caption :: Maybe (Vector RichText), + source :: Maybe MediaSourceUpdate + } + deriving stock (Eq, Generic, Show) + +-- | Embed and bookmark update. +data UrlCaptionUpdate = UrlCaptionUpdate + { url :: Maybe Text, + caption :: Maybe (Vector RichText) + } + deriving stock (Eq, Generic, Show) + +-- | Table update: only the header flags can change. +data TableUpdate = TableUpdate + { hasColumnHeader :: Maybe Bool, + hasRowHeader :: Maybe Bool + } + deriving stock (Eq, Generic, Show) + +-- | One constructor per block type the API allows updating. +data BlockUpdateContent + = UpdateParagraph ParagraphUpdate + | UpdateHeading1 HeadingUpdate + | UpdateHeading2 HeadingUpdate + | UpdateHeading3 HeadingUpdate + | UpdateHeading4 HeadingUpdate + | UpdateBulletedListItem TextColorUpdate + | UpdateNumberedListItem TextColorUpdate + | UpdateQuote TextColorUpdate + | UpdateToggle TextColorUpdate + | UpdateToDo ToDoUpdate + | UpdateCallout ParagraphUpdate + | UpdateTemplateBlock (Vector RichText) + | UpdateCode CodeUpdate + | UpdateEquation Text + | UpdateImage MediaUpdate + | UpdateVideo MediaUpdate + | UpdatePdf MediaUpdate + | UpdateAudio MediaUpdate + | -- | File block; the 'Maybe Text' is the new file name. + UpdateFile MediaUpdate (Maybe Text) + | UpdateEmbed UrlCaptionUpdate + | UpdateBookmark UrlCaptionUpdate + | UpdateDivider + | UpdateBreadcrumb + | UpdateTab + | UpdateTableOfContents (Maybe Color) + | UpdateLinkToPage LinkTarget + | UpdateTableRow (Vector (Vector RichText)) + | UpdateSyncedBlock SyncedFrom + | UpdateTable TableUpdate + | -- | Column width ratio between 0 and 1. + UpdateColumn (Maybe Double) + deriving stock (Eq, Generic, Show) + +instance ToJSON BlockUpdatePayload where + toJSON BlockUpdatePayload {..} = + object $ + maybe [] (\c -> let (k, v) = blockUpdateFields c in [Key.fromText k .= v]) updateContent + <> maybe [] (\t -> ["in_trash" .= t]) inTrash + +-- | The block type key and inner object of an update. +blockUpdateFields :: BlockUpdateContent -> (Text, Value) +blockUpdateFields = \case + UpdateParagraph u -> ("paragraph", paragraphUpdate u) + UpdateHeading1 u -> ("heading_1", headingUpdate u) + UpdateHeading2 u -> ("heading_2", headingUpdate u) + UpdateHeading3 u -> ("heading_3", headingUpdate u) + UpdateHeading4 u -> ("heading_4", headingUpdate u) + UpdateBulletedListItem u -> ("bulleted_list_item", textColorUpdate u) + UpdateNumberedListItem u -> ("numbered_list_item", textColorUpdate u) + UpdateQuote u -> ("quote", textColorUpdate u) + UpdateToggle u -> ("toggle", textColorUpdate u) + UpdateToDo ToDoUpdate {..} -> + ( "to_do", + object $ opt "rich_text" richText <> opt "checked" checked <> opt "color" color + ) + UpdateCallout u -> ("callout", paragraphUpdate u) + UpdateTemplateBlock rt -> ("template", object ["rich_text" .= rt]) + UpdateCode CodeUpdate {..} -> + ( "code", + object $ opt "rich_text" richText <> opt "language" language <> opt "caption" caption + ) + UpdateEquation e -> ("equation", object ["expression" .= e]) + UpdateImage u -> ("image", object (mediaUpdatePairs u)) + UpdateVideo u -> ("video", object (mediaUpdatePairs u)) + UpdatePdf u -> ("pdf", object (mediaUpdatePairs u)) + UpdateAudio u -> ("audio", object (mediaUpdatePairs u)) + UpdateFile u name -> ("file", object (mediaUpdatePairs u <> opt "name" name)) + UpdateEmbed u -> ("embed", urlCaptionUpdate u) + UpdateBookmark u -> ("bookmark", urlCaptionUpdate u) + UpdateDivider -> ("divider", object []) + UpdateBreadcrumb -> ("breadcrumb", object []) + UpdateTab -> ("tab", object []) + UpdateTableOfContents c -> ("table_of_contents", object (opt "color" c)) + UpdateLinkToPage t -> ("link_to_page", toJSON t) + UpdateTableRow cells -> ("table_row", object ["cells" .= cells]) + UpdateSyncedBlock sf -> ("synced_block", object ["synced_from" .= sf]) + UpdateTable TableUpdate {..} -> + ( "table", + object $ opt "has_column_header" hasColumnHeader <> opt "has_row_header" hasRowHeader + ) + UpdateColumn r -> ("column", object (opt "width_ratio" r)) + where + opt :: (ToJSON a) => Aeson.Key -> Maybe a -> [Pair] + opt k = maybe [] (\v -> [k .= v]) + paragraphUpdate ParagraphUpdate {..} = + object $ opt "rich_text" richText <> opt "color" color <> opt "icon" icon + headingUpdate HeadingUpdate {..} = + object $ ["rich_text" .= richText] <> opt "color" color <> opt "is_toggleable" isToggleable + textColorUpdate TextColorUpdate {..} = + object $ ["rich_text" .= richText] <> opt "color" color + urlCaptionUpdate UrlCaptionUpdate {..} = + object $ opt "url" url <> opt "caption" caption + mediaUpdatePairs MediaUpdate {..} = + opt "caption" caption + <> case source of + Nothing -> [] + Just (UpdateExternalSource u) -> ["external" .= object ["url" .= u]] + Just (UpdateFileUploadSource i) -> ["file_upload" .= object ["id" .= i]] + +-- | An update that changes the given block content. +mkBlockUpdate :: BlockUpdateContent -> BlockUpdatePayload +mkBlockUpdate c = BlockUpdatePayload {updateContent = Just c, inTrash = Nothing} + +-- | An update that moves the block to the trash: @{"in_trash": true}@. +trashBlockUpdate :: BlockUpdatePayload +trashBlockUpdate = BlockUpdatePayload {updateContent = Nothing, inTrash = Just True} + +-- | Convert full block content to the equivalent \"set every updatable +-- field\" update. Returns 'Nothing' for block types the API cannot update +-- (child_page, child_database, column_list, link_preview, meeting_notes, +-- unsupported, unknown). Read-only fields (@table_width@, @children@, +-- @list_format@, @list_start_index@, Notion-hosted file URLs) are dropped. +blockUpdateFromContent :: BlockContent -> Maybe BlockUpdateContent +blockUpdateFromContent = \case + ParagraphBlock {..} -> Just (UpdateParagraph (ParagraphUpdate (Just richText) (Just color) paragraphIcon)) + Heading1Block {..} -> Just (UpdateHeading1 (HeadingUpdate richText (Just color) (Just isToggleable))) + Heading2Block {..} -> Just (UpdateHeading2 (HeadingUpdate richText (Just color) (Just isToggleable))) + Heading3Block {..} -> Just (UpdateHeading3 (HeadingUpdate richText (Just color) (Just isToggleable))) + Heading4Block {..} -> Just (UpdateHeading4 (HeadingUpdate richText (Just color) (Just isToggleable))) + BulletedListItemBlock {..} -> Just (UpdateBulletedListItem (TextColorUpdate richText (Just color))) + NumberedListItemBlock {..} -> Just (UpdateNumberedListItem (TextColorUpdate richText (Just color))) + ToDoBlock {..} -> Just (UpdateToDo (ToDoUpdate (Just richText) (Just checked) (Just color))) + ToggleBlock {..} -> Just (UpdateToggle (TextColorUpdate richText (Just color))) + QuoteBlock {..} -> Just (UpdateQuote (TextColorUpdate richText (Just color))) + CalloutBlock {..} -> Just (UpdateCallout (ParagraphUpdate (Just richText) (Just color) calloutIcon)) + CodeBlock {..} -> Just (UpdateCode (CodeUpdate (Just richText) (Just language) (Just caption))) + EquationBlock {..} -> Just (UpdateEquation expression) + ImageBlock {..} -> Just (UpdateImage (media imageSource caption)) + VideoBlock {..} -> Just (UpdateVideo (media videoSource caption)) + AudioBlock {..} -> Just (UpdateAudio (media audioSource caption)) + PdfBlock {..} -> Just (UpdatePdf (media pdfSource caption)) + FileBlock {..} -> Just (UpdateFile (media fileSource caption) fileName) + BookmarkBlock {..} -> Just (UpdateBookmark (UrlCaptionUpdate (Just url) (Just caption))) + EmbedBlock {..} -> Just (UpdateEmbed (UrlCaptionUpdate (Just url) (Just caption))) + LinkToPageBlock {..} -> Just (UpdateLinkToPage linkTarget) + DividerBlock -> Just UpdateDivider + BreadcrumbBlock -> Just UpdateBreadcrumb + TableOfContentsBlock {..} -> Just (UpdateTableOfContents (Just color)) + ColumnBlock {..} -> Just (UpdateColumn widthRatio) + TableBlock {..} -> Just (UpdateTable (TableUpdate (Just hasColumnHeader) (Just hasRowHeader))) + TableRowBlock {..} -> Just (UpdateTableRow cells) + SyncedBlockContent {..} -> Just (UpdateSyncedBlock syncedFrom) + TabBlock {} -> Just UpdateTab + TemplateBlock {..} -> Just (UpdateTemplateBlock richText) + LinkPreviewBlock {} -> Nothing + ColumnListBlock {} -> Nothing + ChildPageBlock {} -> Nothing + ChildDatabaseBlock {} -> Nothing + MeetingNotesBlock {} -> Nothing + UnsupportedBlock _ -> Nothing + UnknownBlock _ _ -> Nothing + where + media src cap = MediaUpdate (Just cap) (sourceUpdate src) + sourceUpdate = \case + ExternalSource (ExternalFile u) -> Just (UpdateExternalSource u) + FileUploadSource i -> Just (UpdateFileUploadSource i) + NotionSource _ -> Nothing + -- --------------------------------------------------------------------------- -- Smart constructors -- --------------------------------------------------------------------------- @@ -1053,6 +1439,12 @@ imageBlock :: FileSource -> BlockContent imageBlock src = ImageBlock src Vector.empty +-- | Build a tab block. Each tab item is a paragraph (its title), an optional +-- icon, and the tab's content blocks — the only child shape the API accepts. +tabBlock :: Vector (Vector RichText, Maybe Icon, Vector BlockContent) -> BlockContent +tabBlock items = + TabBlock (fmap (\(rt, ic, cs) -> ParagraphBlock rt Default ic cs) items) + -- | Attach children to a block. For constructors that do not support -- children, the block is returned unchanged. withChildren :: BlockContent -> Vector BlockContent -> BlockContent @@ -1073,6 +1465,5 @@ SyncedBlockContent {} -> block {children = cs} Heading4Block {} -> block {children = cs} TabBlock {} -> block {children = cs} - MeetingNotesBlock {} -> block {children = cs} TemplateBlock {} -> block {children = cs} _ -> block diff --git a/src/Notion/V1/Blocks.hs b/src/Notion/V1/Blocks.hs --- a/src/Notion/V1/Blocks.hs +++ b/src/Notion/V1/Blocks.hs @@ -3,7 +3,7 @@ ( -- * Main types BlockID, BlockObject (..), - BlockUpdate (..), + BlockUpdatePayload (..), AppendBlockChildren (..), Position (..), @@ -127,7 +127,7 @@ :> ( Capture "block_id" BlockID :> Get '[JSON] BlockObject :<|> Capture "block_id" BlockID - :> ReqBody '[JSON] BlockUpdate + :> ReqBody '[JSON] BlockUpdatePayload :> Patch '[JSON] BlockObject :<|> Capture "block_id" BlockID :> "children" diff --git a/src/Notion/V1/Clearable.hs b/src/Notion/V1/Clearable.hs new file mode 100644 --- /dev/null +++ b/src/Notion/V1/Clearable.hs @@ -0,0 +1,45 @@ +-- | A request field that can be left out, explicitly cleared with JSON @null@, +-- or set to a value. +-- +-- Inside a record encoded with 'genericToJSON' 'aesonOptions', 'Unset' omits +-- the key entirely, 'Clear' writes @null@, and 'Set' writes the value. When +-- decoded with 'genericParseJSON' 'aesonOptions', a missing key becomes 'Unset' +-- and @null@ becomes 'Clear'. (Outside a record, for example as a 'Map' value, +-- 'Unset' also encodes as @null@; use 'Maybe' there instead.) +module Notion.V1.Clearable + ( Clearable (..), + clearableToMaybe, + ) +where + +import Notion.Prelude + +data Clearable a + = -- | Leave the field unchanged (the key is omitted) + Unset + | -- | Clear the field (the key is sent as @null@) + Clear + | -- | Set the field to a value + Set a + deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable) + +instance (ToJSON a) => ToJSON (Clearable a) where + toJSON = \case + Unset -> Null + Clear -> Null + Set a -> toJSON a + omitField = \case + Unset -> True + _ -> False + +instance (FromJSON a) => FromJSON (Clearable a) where + parseJSON = \case + Null -> pure Clear + v -> Set <$> parseJSON v + omittedField = Just Unset + +-- | 'Set' becomes 'Just'; 'Unset' and 'Clear' become 'Nothing'. +clearableToMaybe :: Clearable a -> Maybe a +clearableToMaybe = \case + Set a -> Just a + _ -> Nothing diff --git a/src/Notion/V1/Client.hs b/src/Notion/V1/Client.hs new file mode 100644 --- /dev/null +++ b/src/Notion/V1/Client.hs @@ -0,0 +1,308 @@ +-- | Client runtime: configuration, timeout, retries and logging. +-- +-- 'Notion.V1.makeMethodsWith' builds 'Notion.V1.Methods' from a 'ClientConfig'. +-- The building blocks below ('RequestContext', 'standardHeaders', +-- 'responseTimeoutFor', 'withRetries') are exported so requests made outside +-- Servant, such as streaming responses, behave exactly like 'Notion.V1.Methods'. +module Notion.V1.Client + ( -- * Configuration + ClientConfig (..), + defaultClientConfig, + legacyClientConfig, + defaultBaseUrl, + defaultNotionVersion, + defaultUserAgent, + RetryOptions (..), + defaultRetryOptions, + noRetries, + + -- * Logging + LogLevel (..), + Logger, + stderrLogger, + logWith, + + -- * Runtime building blocks + RequestContext (..), + requestContextFor, + standardHeaders, + configureClientEnv, + notionMiddleware, + applyTimeout, + responseTimeoutFor, + runClientWith, + withRetries, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Exception (SomeException, fromException) +import Control.Exception qualified as Exception +import Control.Monad (unless, when) +import Control.Monad.Error.Class (throwError) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ask) +import Data.Aeson qualified as Aeson +import Data.ByteString.Builder (toLazyByteString) +import Data.ByteString.Lazy qualified as LBS +import Data.Foldable (toList) +import Data.Sequence qualified as Seq +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Text.IO qualified as Text.IO +import Data.Time.Clock (NominalDiffTime, getCurrentTime) +import Data.Version (showVersion) +import Network.HTTP.Client qualified as HTTP +import Network.HTTP.Types (Header, Method) +import Notion.Prelude hiding (ByteString) +import Notion.V1.Error + ( HttpErrorResponse (..), + NotionError (..), + RequestTimeoutError, + UnknownHTTPResponseError (..), + apiErrorCodeText, + fromClientError, + lookupHeader, + unknownResponseMessage, + ) +import Notion.V1.Retry (RetryOptions (..), canRetry, defaultRetryOptions, noRetries, parseRetryAfter, retryDelay, validateRequestPath) +import Paths_notion_client qualified +import Servant.Client (BaseUrl (..), ClientEnv (..), ClientM, Scheme (..)) +import Servant.Client qualified as Client +import Servant.Client.Core (Request, RequestF (..), Response, ResponseF (..)) +import System.IO (stderr) +import System.Random (randomRIO) + +-- | Severity of a log message. +data LogLevel = LogDebug | LogInfo | LogWarn | LogError + deriving stock (Eq, Ord, Show, Enum, Bounded) + +-- | Receives a level, a message, and structured extra fields. The keys match +-- the JS SDK: @method@, @path@, @attempt@, @delayMs@, @code@, @message@, @requestId@. +type Logger = LogLevel -> Text -> [(Text, Value)] -> IO () + +-- | Configuration of the client runtime. +data ClientConfig = ClientConfig + { -- | Base URL including the @/v1@ path. Used by 'Notion.V1.makeMethodsWith'; + -- ignored by 'Notion.V1.makeMethodsWithEnv', whose 'ClientEnv' already has one. + apiBaseUrl :: BaseUrl, + -- | Value of the @Notion-Version@ header. + notionVersion :: Text, + -- | Timeout for connecting and receiving response headers. 'Nothing' keeps + -- the connection manager's own setting. + timeout :: Maybe NominalDiffTime, + retryOptions :: RetryOptions, + -- | Sent as @User-Agent@ when 'Just'. + userAgent :: Maybe Text, + logger :: Maybe Logger, + -- | Messages below this level are not passed to 'logger'. + logLevel :: LogLevel + } + +-- | @https://api.notion.com/v1@ +defaultBaseUrl :: BaseUrl +defaultBaseUrl = BaseUrl Https "api.notion.com" 443 "/v1" + +-- | The Notion API version this library is written against. +defaultNotionVersion :: Text +defaultNotionVersion = "2026-03-11" + +-- | @notion-client-haskell/@ +defaultUserAgent :: Text +defaultUserAgent = "notion-client-haskell/" <> Text.pack (showVersion Paths_notion_client.version) + +-- | Default base URL and API version, 60 second timeout, two retries, a +-- @User-Agent@ header and no logger. +defaultClientConfig :: ClientConfig +defaultClientConfig = + ClientConfig + { apiBaseUrl = defaultBaseUrl, + notionVersion = defaultNotionVersion, + timeout = Just 60, + retryOptions = defaultRetryOptions, + userAgent = Just defaultUserAgent, + logger = Nothing, + logLevel = LogWarn + } + +-- | What 'Notion.V1.makeMethods' uses: 'defaultClientConfig', but it keeps the +-- connection manager's timeout. +legacyClientConfig :: ClientConfig +legacyClientConfig = defaultClientConfig {timeout = Nothing} + +-- | Writes @notion-client : @ to stderr. +stderrLogger :: Logger +stderrLogger level msg extra = + Text.IO.hPutStrLn stderr $ + "notion-client " + <> Text.pack (show level) + <> ": " + <> msg + <> if null extra + then "" + else " " <> Text.decodeUtf8Lenient (LBS.toStrict (Aeson.encode (Aeson.object [(fromString (Text.unpack k), v) | (k, v) <- extra]))) + +-- | Pass a message to the configured logger if its level is high enough. +logWith :: ClientConfig -> LogLevel -> Text -> [(Text, Value)] -> IO () +logWith ClientConfig {logger, logLevel} level msg extra = case logger of + Just write | level >= logLevel -> write level msg extra + _ -> pure () + +-- | Everything needed to send a request the same way 'Notion.V1.Methods' does, +-- whether through Servant or a hand-written http-client request. +data RequestContext = RequestContext + { contextConfig :: ClientConfig, + contextManager :: HTTP.Manager, + -- | The effective base URL, for example @https://api.notion.com/v1@. + contextBaseUrl :: BaseUrl, + -- | Full @Authorization@ header value, for example @Bearer secret_...@. + contextAuthorization :: Text + } + +-- | Build the context from the same inputs as 'Notion.V1.makeMethodsWithEnv': +-- manager and base URL from the 'ClientEnv', and a bearer token. +requestContextFor :: ClientConfig -> ClientEnv -> Text -> RequestContext +requestContextFor config ClientEnv {manager = m, baseUrl = b} token = + RequestContext + { contextConfig = config, + contextManager = m, + contextBaseUrl = b, + contextAuthorization = "Bearer " <> token + } + +-- | The @Authorization@, @Notion-Version@ and (when configured) @User-Agent@ headers. +standardHeaders :: RequestContext -> [Header] +standardHeaders RequestContext {contextConfig = ClientConfig {notionVersion, userAgent}, contextAuthorization} = + [ ("Authorization", Text.encodeUtf8 contextAuthorization), + ("Notion-Version", Text.encodeUtf8 notionVersion) + ] + <> userAgentHeader userAgent + +userAgentHeader :: Maybe Text -> [Header] +userAgentHeader = maybe [] (\ua -> [("User-Agent", Text.encodeUtf8 ua)]) + +-- | The http-client timeout for a configuration. +responseTimeoutFor :: ClientConfig -> HTTP.ResponseTimeout +responseTimeoutFor ClientConfig {timeout} = case timeout of + Just t -> HTTP.responseTimeoutMicro (round (t * 1000000)) + Nothing -> HTTP.responseTimeoutDefault + +-- | Set the request's timeout when the configuration has one; otherwise leave +-- the request unchanged. +applyTimeout :: ClientConfig -> HTTP.Request -> HTTP.Request +applyTimeout config@ClientConfig {timeout} req = case timeout of + Just _ -> req {HTTP.responseTimeout = responseTimeoutFor config} + Nothing -> req + +-- | Install the runtime (timeout and middleware) into a 'ClientEnv', keeping the +-- caller's own request builder and middleware. The caller's middleware runs +-- inside ours. +configureClientEnv :: ClientConfig -> ClientEnv -> ClientEnv +configureClientEnv config env = + env + { makeClientRequest = \base req -> applyTimeout config <$> makeClientRequest env base req, + middleware = \app -> notionMiddleware config (middleware env app) + } + +-- | Servant middleware implementing the runtime for every request: rejects path +-- traversal, adds the @User-Agent@ header, converts failures into this +-- library's exceptions, retries per 'retryOptions', and logs. +notionMiddleware :: ClientConfig -> (Request -> ClientM Response) -> Request -> ClientM Response +notionMiddleware config@ClientConfig {userAgent} app req0 = do + let path = Text.decodeUtf8Lenient (LBS.toStrict (toLazyByteString (requestPath req0))) + method = requestMethod req0 + req = req0 {requestHeaders = requestHeaders req0 <> Seq.fromList (userAgentHeader userAgent)} + methodField = ("method", String (Text.decodeUtf8Lenient method)) + either (liftIO . Exception.throwIO) pure (validateRequestPath path) + liftIO $ logWith config LogInfo "request start" [methodField, ("path", String path)] + env <- ask + result <- liftIO $ withRetries config method path $ do + r <- Client.runClientM (app req) env + case r of + Right resp -> pure (Right resp) + Left clientErr -> do + let ex = fromClientError clientErr + case classify ex of + Nothing -> pure (Left clientErr) + Just notRetried -> do + -- NotionError is logged by withRetries; the others are never retried. + unless (isNotionError ex) $ + logWith config LogWarn "request fail" [methodField, ("path", String path), ("message", String notRetried)] + Exception.throwIO ex + case result of + Left clientErr -> throwError clientErr + Right resp -> do + liftIO $ + logWith + config + LogInfo + "request success" + [ methodField, + ("path", String path), + ("requestId", maybe Null String (lookupHeader "x-notion-request-id" (toList (responseHeaders resp)))) + ] + pure resp + where + isNotionError ex = case fromException ex of + Just (_ :: NotionError) -> True + Nothing -> False + -- A description for exceptions this library throws, Nothing for other client errors. + classify :: SomeException -> Maybe Text + classify ex + | Just NotionError {message} <- fromException ex = Just message + | Just (e :: UnknownHTTPResponseError) <- fromException ex = Just (unknownResponseMessage e) + | Just (_ :: RequestTimeoutError) <- fromException ex = Just "Request to Notion API has timed out" + | otherwise = Nothing + +-- | Run an action that signals API failures by throwing 'NotionError', retrying +-- per 'retryOptions'. @method@ and @path@ are used for the retry rule and log +-- lines. Other exceptions propagate immediately. Usable outside Servant, for +-- example before opening a streaming response. +withRetries :: ClientConfig -> Method -> Text -> IO a -> IO a +withRetries config@ClientConfig {retryOptions} method path action = go 0 + where + go attempt = do + result <- Exception.try action + case result of + Right a -> pure a + Left err@NotionError {code, message, requestId, response} -> do + logWith + config + LogWarn + "request fail" + [ ("code", String (apiErrorCodeText code)), + ("message", String message), + ("attempt", Aeson.toJSON attempt), + ("requestId", maybe Null String requestId) + ] + case response of + Just HttpErrorResponse {errorBody} -> + logWith config LogDebug "failed response body" [("body", String (Text.decodeUtf8Lenient (LBS.toStrict errorBody)))] + Nothing -> pure () + when (attempt >= maxRetries retryOptions || not (canRetry method code)) $ + Exception.throwIO err + now <- getCurrentTime + jitter <- randomRIO (0, 0.999999) + let retryAfter = parseRetryAfter now =<< (lookup "retry-after" . errorHeaders =<< response) + delay = retryDelay retryOptions attempt jitter retryAfter + delayMs = round (delay * 1000) :: Integer + logWith + config + LogInfo + "retrying request" + [ ("method", String (Text.decodeUtf8Lenient method)), + ("path", String path), + ("attempt", Aeson.toJSON (attempt + 1)), + ("delayMs", Aeson.toJSON delayMs) + ] + threadDelay (fromInteger (delayMs * 1000)) + go (attempt + 1) + +-- | Run a client action in an already configured environment, throwing failures +-- as exceptions. +runClientWith :: ClientEnv -> ClientM a -> IO a +runClientWith env clientM = do + result <- Client.runClientM clientM env + -- throwIO on a SomeException rethrows the wrapped exception, so callers can + -- catch NotionError and friends by their own types. + either (Exception.throwIO . fromClientError) pure result diff --git a/src/Notion/V1/Comments.hs b/src/Notion/V1/Comments.hs --- a/src/Notion/V1/Comments.hs +++ b/src/Notion/V1/Comments.hs @@ -5,7 +5,18 @@ CommentObject (..), CommentAttachment (..), CommentDisplayName (..), + CommentResponse (..), + commentResponseId, + commentResponseObject, + + -- * Requests CreateComment (..), + CommentTarget (..), + CommentContent (..), + CommentAttachmentRequest (..), + CommentDisplayNameRequest (..), + mkCreateComment, + mkReplyComment, -- * Servant API, @@ -14,6 +25,8 @@ import Data.Aeson ((.:), (.:?), (.=)) import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (Pair) import Data.Maybe (catMaybes) import Notion.Prelude import Notion.V1.Common (BlockID, ExternalFile, File, ObjectType (..), Parent, UUID) @@ -25,12 +38,11 @@ -- | Comment ID type CommentID = UUID --- | Comment attachment (files attached to comments) --- --- Unifies the two shapes returned/accepted by the Notion API: +-- | Comment attachment (files attached to comments), as read from responses. -- --- * Read responses (@GET \/v1\/comments@) contain @category@ + @file@. --- * Write requests (@POST \/v1\/comments@) contain @name@ + @type@ + @external@\/@file@. +-- Read responses (@GET \/v1\/comments@) contain @category@ + @file@; an +-- older @name@ + @type@ + @external@\/@file@ shape is also accepted. To attach +-- files to a new comment use 'CommentAttachmentRequest'. data CommentAttachment = CommentAttachment { name :: Maybe Text, type_ :: Maybe Text, @@ -60,10 +72,10 @@ ("file" .=) <$> file ] --- | Comment display name (custom display name for comments) +-- | Comment display name, as read from responses. -- --- Read responses may include @resolved_name@ (the rendered label for a user --- mention); write requests only use @display_name@. +-- Read responses include @resolved_name@ (the rendered author label). To +-- choose the display name of a new comment use 'CommentDisplayNameRequest'. data CommentDisplayName = CommentDisplayName { type_ :: Text, emoji :: Maybe Text, @@ -123,27 +135,135 @@ return CommentObject {..} _ -> fail "Expected object for CommentObject" +-- | A comment endpoint response: Notion may return the full comment or only +-- its id. +data CommentResponse + = FullComment CommentObject + | PartialComment CommentID + deriving stock (Generic, Show) + +-- | A response is full when it carries @parent@; a full response with other +-- required fields missing fails to decode rather than becoming partial. +instance FromJSON CommentResponse where + parseJSON = Aeson.withObject "CommentResponse" $ \o -> + if KeyMap.member "parent" o + then FullComment <$> parseJSON (Object o) + else PartialComment <$> o .: "id" + +-- | The id carried by either response shape. +commentResponseId :: CommentResponse -> CommentID +commentResponseId = \case + FullComment CommentObject {id} -> id + PartialComment cid -> cid + +-- | The full comment, if Notion returned one. +commentResponseObject :: CommentResponse -> Maybe CommentObject +commentResponseObject = \case + FullComment c -> Just c + PartialComment _ -> Nothing + +-- | Where a new comment goes. +data CommentTarget + = -- | Start a new discussion on a page ('Notion.V1.Common.PageParent') or + -- block ('Notion.V1.Common.BlockParent'). Notion rejects other parents. + CommentOnParent Parent + | -- | Reply in an existing discussion. + CommentInDiscussion UUID + deriving stock (Generic, Show) + +-- | The body of a comment: rich text or inline Markdown. +-- +-- Also the request body of @PATCH \/v1\/comments\/{comment_id}@. +data CommentContent + = CommentRichText (Vector RichText) + | -- | Inline formatting, equations and mentions only; block-level Markdown + -- does not become blocks. + CommentMarkdown Text + deriving stock (Generic, Show) + +instance ToJSON CommentContent where + toJSON c = Aeson.object [commentContentPair c] + +commentContentPair :: CommentContent -> Pair +commentContentPair = \case + CommentRichText rt -> "rich_text" .= rt + CommentMarkdown md -> "markdown" .= md + +-- | Attach a completed file upload to a new comment. Encodes as +-- @{"file_upload_id": "...", "type": "file_upload"}@. +newtype CommentAttachmentRequest = CommentAttachmentRequest {fileUploadId :: UUID} + deriving stock (Generic, Show) + +instance ToJSON CommentAttachmentRequest where + toJSON CommentAttachmentRequest {fileUploadId} = + Aeson.object ["file_upload_id" .= fileUploadId, "type" .= ("file_upload" :: Text)] + +-- | How the author of a new comment is displayed. +data CommentDisplayNameRequest + = -- | @{"type":"integration"}@ + DisplayAsIntegration + | -- | @{"type":"user"}@ + DisplayAsUser + | -- | @{"type":"custom","custom":{"name":...}}@ + DisplayAsCustom Text + deriving stock (Generic, Show) + +instance ToJSON CommentDisplayNameRequest where + toJSON = \case + DisplayAsIntegration -> Aeson.object ["type" .= ("integration" :: Text)] + DisplayAsUser -> Aeson.object ["type" .= ("user" :: Text)] + DisplayAsCustom n -> + Aeson.object + [ "type" .= ("custom" :: Text), + "custom" .= Aeson.object ["name" .= n] + ] + -- | Create comment request data CreateComment = CreateComment - { parent :: Parent, - richText :: Vector RichText, - discussionId :: Maybe UUID, - attachments :: Maybe (Vector CommentAttachment), - displayName :: Maybe CommentDisplayName + { target :: CommentTarget, + content :: CommentContent, + -- | At most three attachments. + attachments :: Maybe (Vector CommentAttachmentRequest), + displayName :: Maybe CommentDisplayNameRequest } deriving stock (Generic, Show) instance ToJSON CreateComment where - toJSON = genericToJSON aesonOptions + toJSON CreateComment {..} = + Aeson.object $ + [ case target of + CommentOnParent p -> "parent" .= p + CommentInDiscussion d -> "discussion_id" .= d, + commentContentPair content + ] + <> catMaybes + [ ("attachments" .=) <$> attachments, + ("display_name" .=) <$> displayName + ] +-- | Start a new discussion on a page or block. +mkCreateComment :: Parent -> CommentContent -> CreateComment +mkCreateComment p c = CreateComment (CommentOnParent p) c Nothing Nothing + +-- | Reply in an existing discussion. +mkReplyComment :: UUID -> CommentContent -> CreateComment +mkReplyComment d c = CreateComment (CommentInDiscussion d) c Nothing Nothing + -- | Servant API -- Note: To list comments on a page, use the page ID as block_id (pages are blocks in Notion) type API = "comments" :> ( ReqBody '[JSON] CreateComment - :> Post '[JSON] CommentObject + :> Post '[JSON] CommentResponse :<|> QueryParam "block_id" BlockID :> QueryParam "start_cursor" Text :> QueryParam "page_size" Natural :> Get '[JSON] (ListOf CommentObject) + :<|> Capture "comment_id" CommentID + :> Get '[JSON] CommentResponse + :<|> Capture "comment_id" CommentID + :> ReqBody '[JSON] CommentContent + :> Patch '[JSON] CommentResponse + :<|> Capture "comment_id" CommentID + :> Delete '[JSON] CommentResponse ) diff --git a/src/Notion/V1/Common.hs b/src/Notion/V1/Common.hs --- a/src/Notion/V1/Common.hs +++ b/src/Notion/V1/Common.hs @@ -8,15 +8,19 @@ ParentID, Color (..), Icon (..), + NoticonColor (..), Cover (..), File (..), ExternalFile (..), + CustomEmojiRef (..), ) where -import Data.Aeson (Object, object, (.:), (.:?), (.=)) +import Data.Aeson (Object, object, withText, (.:), (.:?), (.=)) import Data.Aeson.Types (Parser) import Data.Foldable (asum) +import Data.Maybe (fromMaybe) +import Data.Tuple (swap) import Notion.Prelude -- | UUID type for Notion resource IDs @@ -35,13 +39,41 @@ | User | Comment | View + | -- | @file_upload@ + FileUploadObjectType + | -- | @page_markdown@ + PageMarkdownObjectType + | -- | @async_task@ + AsyncTaskObjectType + | -- | @group@ + GroupObjectType + | -- | An object type this library does not know yet; holds the raw string. + UnknownObjectType Text deriving stock (Eq, Show, Generic) +objectTypeNames :: [(ObjectType, Text)] +objectTypeNames = + [ (Database, "database"), + (DataSource, "data_source"), + (Page, "page"), + (Block, "block"), + (User, "user"), + (Comment, "comment"), + (View, "view"), + (FileUploadObjectType, "file_upload"), + (PageMarkdownObjectType, "page_markdown"), + (AsyncTaskObjectType, "async_task"), + (GroupObjectType, "group") + ] + instance FromJSON ObjectType where - parseJSON = genericParseJSON aesonOptions + parseJSON = withText "ObjectType" $ \t -> + pure (fromMaybe (UnknownObjectType t) (lookup t (map swap objectTypeNames))) instance ToJSON ObjectType where - toJSON = genericToJSON aesonOptions + toJSON = \case + UnknownObjectType t -> String t + o -> String (fromMaybe "" (lookup o objectTypeNames)) -- | Parent object that can be a database, data source, page, block, or workspace data Parent @@ -50,6 +82,9 @@ | PageParent {pageId :: UUID} | BlockParent {blockId :: UUID} | WorkspaceParent {workspace :: Bool} + | AgentParent {agentId :: UUID} + | -- | A parent kind this library does not model yet; holds the raw JSON object. + UnknownParent Value deriving stock (Generic, Show) instance FromJSON Parent where @@ -72,7 +107,8 @@ "block" -> fmap BlockParent . (.: "block_id") "block_id" -> fmap BlockParent . (.: "block_id") "workspace" -> fmap WorkspaceParent . (.: "workspace") - other -> \_ -> fail $ "Unknown parent type: " <> unpack other + "agent_id" -> fmap AgentParent . (.: "agent_id") + _ -> pure . UnknownParent . Object parseByKey :: Object -> Parser Parent parseByKey o = @@ -81,7 +117,9 @@ DatabaseParent <$> o .: "database_id", PageParent <$> o .: "page_id", BlockParent <$> o .: "block_id", - WorkspaceParent <$> o .: "workspace" + AgentParent <$> o .: "agent_id", + WorkspaceParent <$> o .: "workspace", + pure (UnknownParent (Object o)) ] instance ToJSON Parent where @@ -93,6 +131,8 @@ toJSON (PageParent pId) = object ["type" .= ("page_id" :: Text), "page_id" .= pId] toJSON (BlockParent bId) = object ["type" .= ("block_id" :: Text), "block_id" .= bId] toJSON (WorkspaceParent ws) = object ["type" .= ("workspace" :: Text), "workspace" .= ws] + toJSON (AgentParent aId) = object ["type" .= ("agent_id" :: Text), "agent_id" .= aId] + toJSON (UnknownParent v) = v -- | Unified parent ID type type ParentID = UUID @@ -109,6 +149,7 @@ | Purple | Pink | Red + | DefaultBackground | GrayBackground | BrownBackground | OrangeBackground @@ -118,13 +159,42 @@ | PurpleBackground | PinkBackground | RedBackground + | -- | A color this library does not know yet; holds the raw string. + UnknownColor Text deriving stock (Eq, Show, Generic) +colorNames :: [(Color, Text)] +colorNames = + [ (Default, "default"), + (Gray, "gray"), + (Brown, "brown"), + (Orange, "orange"), + (Yellow, "yellow"), + (Green, "green"), + (Blue, "blue"), + (Purple, "purple"), + (Pink, "pink"), + (Red, "red"), + (DefaultBackground, "default_background"), + (GrayBackground, "gray_background"), + (BrownBackground, "brown_background"), + (OrangeBackground, "orange_background"), + (YellowBackground, "yellow_background"), + (GreenBackground, "green_background"), + (BlueBackground, "blue_background"), + (PurpleBackground, "purple_background"), + (PinkBackground, "pink_background"), + (RedBackground, "red_background") + ] + instance FromJSON Color where - parseJSON = genericParseJSON aesonOptions + parseJSON = withText "Color" $ \t -> + pure (fromMaybe (UnknownColor t) (lookup t (map swap colorNames))) instance ToJSON Color where - toJSON = genericToJSON aesonOptions + toJSON = \case + UnknownColor t -> String t + c -> String (fromMaybe "default" (lookup c colorNames)) -- | Icon object for pages/databases data Icon @@ -132,17 +202,20 @@ | FileIcon {file :: File} | ExternalIcon {external :: ExternalFile} | -- | Native icon specified by name and optional color - NativeIcon {iconName :: Text, iconColor :: Maybe Text} - | -- | Custom emoji icon specified by ID - CustomEmojiIcon {customEmojiId :: UUID} + NativeIcon {iconName :: Text, iconColor :: Maybe NoticonColor} + | -- | Custom emoji icon. Responses carry the emoji's name and URL; requests + -- need only its ID. + CustomEmojiIcon {customEmoji :: CustomEmojiRef} | -- | File upload icon referenced by upload ID FileUploadIcon {fileUploadId :: UUID} + | -- | An icon kind this library does not model yet; holds the raw icon object. + UnknownIcon Value deriving stock (Eq, Generic, Show) instance FromJSON Icon where parseJSON = \case Object o -> do - iconType <- o .: "type" + iconType :: Text <- o .: "type" case iconType of "emoji" -> EmojiIcon <$> o .: "emoji" "file" -> FileIcon <$> o .: "file" @@ -150,11 +223,16 @@ "icon" -> do inner <- o .: "icon" NativeIcon <$> inner .: "name" <*> inner .:? "color" - "custom_emoji" -> CustomEmojiIcon <$> o .: "id" + "custom_emoji" -> do + mInner <- o .:? "custom_emoji" + case mInner of + Just inner -> CustomEmojiIcon <$> parseJSON inner + -- Shape written by notion-client <= 0.7.0.2; still accepted when reading. + Nothing -> (\i -> CustomEmojiIcon (CustomEmojiRef i Nothing Nothing)) <$> o .: "id" "file_upload" -> do uploadObj <- o .: "file_upload" FileUploadIcon <$> uploadObj .: "id" - _ -> fail $ "Unknown icon type: " <> unpack iconType + _ -> pure (UnknownIcon (Object o)) _ -> fail "Expected object for Icon" instance ToJSON Icon where @@ -166,8 +244,64 @@ [ "type" .= ("icon" :: Text), "icon" .= object (["name" .= name] <> maybe [] (\c -> ["color" .= c]) color) ] - toJSON (CustomEmojiIcon eid) = object ["type" .= ("custom_emoji" :: Text), "id" .= eid] + toJSON (CustomEmojiIcon ref) = + object ["type" .= ("custom_emoji" :: Text), "custom_emoji" .= ref] toJSON (FileUploadIcon uid) = object ["type" .= ("file_upload" :: Text), "file_upload" .= object ["id" .= uid]] + toJSON (UnknownIcon v) = v + +-- | Color variant of a Notion native icon. +data NoticonColor + = NoticonGray + | NoticonLightgray + | NoticonBrown + | NoticonYellow + | NoticonOrange + | NoticonGreen + | NoticonBlue + | NoticonPurple + | NoticonPink + | NoticonRed + | -- | A color this library does not know yet; holds the raw string. + UnknownNoticonColor Text + deriving stock (Eq, Generic, Show) + +noticonColorNames :: [(NoticonColor, Text)] +noticonColorNames = + [ (NoticonGray, "gray"), + (NoticonLightgray, "lightgray"), + (NoticonBrown, "brown"), + (NoticonYellow, "yellow"), + (NoticonOrange, "orange"), + (NoticonGreen, "green"), + (NoticonBlue, "blue"), + (NoticonPurple, "purple"), + (NoticonPink, "pink"), + (NoticonRed, "red") + ] + +instance FromJSON NoticonColor where + parseJSON = withText "NoticonColor" $ \t -> + pure (fromMaybe (UnknownNoticonColor t) (lookup t (map swap noticonColorNames))) + +instance ToJSON NoticonColor where + toJSON = \case + UnknownNoticonColor t -> String t + c -> String (fromMaybe "" (lookup c noticonColorNames)) + +-- | Reference to a workspace custom emoji. Responses always include 'name' +-- and 'url'; requests may send only the ID. +data CustomEmojiRef = CustomEmojiRef + { id :: UUID, + name :: Maybe Text, + url :: Maybe Text + } + deriving stock (Eq, Generic, Show) + +instance FromJSON CustomEmojiRef where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON CustomEmojiRef where + toJSON = genericToJSON aesonOptions -- | Cover object for pages/databases data Cover diff --git a/src/Notion/V1/DataSourceRows.hs b/src/Notion/V1/DataSourceRows.hs new file mode 100644 --- /dev/null +++ b/src/Notion/V1/DataSourceRows.hs @@ -0,0 +1,137 @@ +-- | Iterate every row of a data source, including rows past Notion's per-query result limit. +-- +-- A single data source query stops paginating once it has returned a fixed number of rows +-- (10,000 by default) and marks the response @request_status: incomplete@. These helpers +-- work around that limit the same way the official JS SDK's @iterateAllDataSourceRows@ does: +-- they sort by @created_time@ ascending and, whenever a query window hits the limit, start +-- a new window filtered to @created_time on_or_after@ the last row seen, skipping rows +-- already visited. +-- +-- @ +-- rows <- collectAllDataSourceRows (queryDataSource methods dsId) _QueryDataSource Nothing +-- @ +module Notion.V1.DataSourceRows + ( AllRowsFilter (..), + DataSourceRowsError (..), + createdTimeLowerBound, + foldAllDataSourceRows, + iterateAllDataSourceRows, + collectAllDataSourceRows, + ) +where + +import Control.Exception (Exception, throwIO) +import Control.Monad (foldM) +import Data.Set qualified as Set +import Data.Vector qualified as Vector +import Notion.Prelude +import Notion.V1.DataSources (PageOrDataSource, QueryDataSource (..), resultCreatedTime, resultId) +import Notion.V1.Filter (DateCondition (..), Filter (..), PropertyCondition, Sort (..), SortDirection (..), TimestampType (..)) +import Notion.V1.ListOf (ListOf (..), RequestStatus (..), RequestStatusType (..)) +import Prelude hiding (filter) + +-- | Filters the helpers can combine with their @created_time@ bound. +-- +-- A top-level 'Or' is deliberately not representable: adding the bound would need a third +-- nesting level, and Notion allows only two. +data AllRowsFilter + = AllRowsPropertyFilter Text PropertyCondition + | AllRowsTimestampFilter TimestampType DateCondition + | AllRowsAnd [Filter] + deriving stock (Eq, Show) + +data DataSourceRowsError + = -- | The limit was reached but the window could not advance past this @created_time@: + -- more rows share one timestamp than a single query can return, or no row carried one. + CannotMakeProgress (Maybe POSIXTime) + deriving stock (Show) + +instance Exception DataSourceRowsError + +-- | Combine the caller filter with @created_time on_or_after windowStart@. +createdTimeLowerBound :: Maybe AllRowsFilter -> Maybe POSIXTime -> Maybe Filter +createdTimeLowerBound mFilter Nothing = toFilter <$> mFilter +createdTimeLowerBound mFilter (Just start) = + Just $ case mFilter of + Nothing -> bound + Just (AllRowsAnd xs) -> And (xs <> [bound]) + Just other -> And [toFilter other, bound] + where + bound = TimestampFilter FilterCreatedTime (DateOnOrAfter (posixToISO8601 start)) + +toFilter :: AllRowsFilter -> Filter +toFilter = \case + AllRowsPropertyFilter p c -> PropertyFilter p c + AllRowsTimestampFilter t c -> TimestampFilter t c + AllRowsAnd xs -> And xs + +isIncomplete :: ListOf a -> Bool +isIncomplete List {requestStatus = Just RequestStatus {type_ = RequestIncomplete}} = True +isIncomplete _ = False + +-- | Fold over every row of a data source, each row visited once. +foldAllDataSourceRows :: + -- | The query, e.g. @queryDataSource methods dsId@. + (QueryDataSource -> IO (ListOf PageOrDataSource)) -> + -- | Base request; its @filter@, @sorts@ and @startCursor@ are overwritten. + QueryDataSource -> + Maybe AllRowsFilter -> + acc -> + (acc -> PageOrDataSource -> IO acc) -> + IO acc +foldAllDataSourceRows query base mFilter acc0 step = go Set.empty Nothing acc0 + where + go seen windowStart acc = do + (seen', acc', limitReached, lastCreated) <- window seen windowStart acc + if not limitReached + then pure acc' + else + if lastCreated == Nothing || lastCreated == windowStart + then throwIO (CannotMakeProgress lastCreated) + else go seen' lastCreated acc' + + window seen windowStart acc = page seen acc False Nothing Nothing + where + page seen1 acc1 limit1 last1 cursor = do + response <- + query + base + { filter = createdTimeLowerBound mFilter windowStart, + sorts = Just [TimestampSort FilterCreatedTime Ascending], + startCursor = cursor + } + (seen2, acc2, last2) <- foldM visit (seen1, acc1, last1) (results response) + let limit2 = limit1 || isIncomplete response + case nextCursor response of + Just c -> page seen2 acc2 limit2 last2 (Just c) + Nothing -> pure (seen2, acc2, limit2, last2) + + visit (seen, acc, lastCreated) row = do + let lastCreated' = maybe lastCreated Just (resultCreatedTime row) + case resultId row of + Just rid + | Set.member rid seen -> pure (seen, acc, lastCreated') + | otherwise -> do + acc' <- step acc row + pure (Set.insert rid seen, acc', lastCreated') + Nothing -> do + acc' <- step acc row + pure (seen, acc', lastCreated') + +-- | Run an action on every row of a data source, each row visited once. +iterateAllDataSourceRows :: + (QueryDataSource -> IO (ListOf PageOrDataSource)) -> + QueryDataSource -> + Maybe AllRowsFilter -> + (PageOrDataSource -> IO ()) -> + IO () +iterateAllDataSourceRows query base mFilter visit = foldAllDataSourceRows query base mFilter () (const visit) + +-- | Collect every row into memory. Check that the data source fits in memory first. +collectAllDataSourceRows :: + (QueryDataSource -> IO (ListOf PageOrDataSource)) -> + QueryDataSource -> + Maybe AllRowsFilter -> + IO (Vector PageOrDataSource) +collectAllDataSourceRows query base mFilter = + Vector.fromList . reverse <$> foldAllDataSourceRows query base mFilter [] (\acc r -> pure (r : acc)) diff --git a/src/Notion/V1/DataSources.hs b/src/Notion/V1/DataSources.hs --- a/src/Notion/V1/DataSources.hs +++ b/src/Notion/V1/DataSources.hs @@ -9,7 +9,18 @@ CreateDataSource (..), UpdateDataSource (..), QueryDataSource (..), + _QueryDataSource, + QueryResultType (..), + -- * Query and search results + PageOrDataSource (..), + PartialPageObject (..), + PartialDataSourceObject (..), + pageResults, + dataSourceResults, + resultId, + resultCreatedTime, + -- * Templates TemplateRef (..), ListTemplatesResponse (..), @@ -20,18 +31,21 @@ where import Control.Applicative ((<|>)) -import Data.Aeson ((.:), (.:?), (.=)) +import Data.Aeson ((.!=), (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson -import Data.Aeson.Key qualified as Key -import Data.Map qualified as Map +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (Parser) +import Data.Vector qualified as Vector import Notion.Prelude -import Notion.V1.Common (Cover, Icon, ObjectType, Parent, UUID) +import Notion.V1.Common (Cover, Icon, ObjectType, Parent, UUID (..)) +import Notion.V1.Databases (DatabaseType) import Notion.V1.Filter (Filter, Sort) import Notion.V1.ListOf (ListOf) -import Notion.V1.Pages (PageObject) -import Notion.V1.Properties (PropertySchema) +import Notion.V1.Pages (PageObject (..), PartialPageObject (..)) +import Notion.V1.Properties (PropertySchema, PropertyUpdate) import Notion.V1.RichText (RichText) import Notion.V1.Users (UserReference) +import Servant.API (QueryParams) import Prelude hiding (id) -- | Data source ID @@ -51,6 +65,8 @@ parent :: Parent, databaseParent :: Maybe Parent, isInline :: Maybe Bool, + -- | The kind of typed database this data source belongs to, if any. + databaseType :: Maybe DatabaseType, inTrash :: Maybe Bool, publicUrl :: Maybe Text, icon :: Maybe Icon, @@ -76,6 +92,7 @@ parent <- o .: "parent" databaseParent <- o .:? "database_parent" isInline <- o .:? "is_inline" + databaseType <- o .:? "database_type" inTrash <- (fmap Just (o .: "in_trash")) <|> (fmap Just (o .: "is_archived")) <|> (fmap Just (o .: "archived")) <|> pure Nothing publicUrl <- o .:? "public_url" icon <- o .:? "icon" @@ -84,13 +101,85 @@ return DataSourceObject {..} _ -> fail "Expected object for DataSourceObject" +-- | @{"object":"data_source","id":...,"properties":{...}}@ +data PartialDataSourceObject = PartialDataSourceObject + { id :: DataSourceID, + properties :: Map Text PropertySchema + } + deriving stock (Generic, Show) + +instance FromJSON PartialDataSourceObject where + parseJSON = \case + Object o -> PartialDataSourceObject <$> o .: "id" <*> (o .:? "properties" .!= mempty) + _ -> fail "Expected object for PartialDataSourceObject" + +-- | One result of a data source query or a search. +-- +-- A page with a @url@ key, or a data source with a @title@ key, is full and must decode as +-- the full object; otherwise it is partial. +data PageOrDataSource + = PageResult PageObject + | PartialPageResult PartialPageObject + | DataSourceResult DataSourceObject + | PartialDataSourceResult PartialDataSourceObject + | -- | An object type this client does not know; the raw JSON is kept. + UnknownResult Value + deriving stock (Generic, Show) + +instance FromJSON PageOrDataSource where + parseJSON v = case v of + Object o -> do + objectType <- o .:? "object" :: Parser (Maybe Text) + case objectType of + Just "page" + | KeyMap.member "url" o -> PageResult <$> parseJSON v + | otherwise -> PartialPageResult <$> parseJSON v + Just "data_source" + | KeyMap.member "title" o -> DataSourceResult <$> parseJSON v + | otherwise -> PartialDataSourceResult <$> parseJSON v + _ -> pure (UnknownResult v) + _ -> pure (UnknownResult v) + +-- | Full pages only. +pageResults :: Vector PageOrDataSource -> Vector PageObject +pageResults = Vector.mapMaybe $ \case + PageResult p -> Just p + _ -> Nothing + +-- | Full data sources only. +dataSourceResults :: Vector PageOrDataSource -> Vector DataSourceObject +dataSourceResults = Vector.mapMaybe $ \case + DataSourceResult d -> Just d + _ -> Nothing + +-- | The id of a result, if it has one (unknown results are inspected for a string @id@). +resultId :: PageOrDataSource -> Maybe Text +resultId = \case + PageResult PageObject {id = UUID t} -> Just t + PartialPageResult PartialPageObject {id = UUID t} -> Just t + DataSourceResult DataSourceObject {id = UUID t} -> Just t + PartialDataSourceResult PartialDataSourceObject {id = UUID t} -> Just t + UnknownResult (Object o) -> case KeyMap.lookup "id" o of + Just (String t) -> Just t + _ -> Nothing + UnknownResult _ -> Nothing + +-- | @created_time@ of a full page or full data source; 'Nothing' for partial and unknown results. +resultCreatedTime :: PageOrDataSource -> Maybe POSIXTime +resultCreatedTime = \case + PageResult PageObject {createdTime} -> Just createdTime + DataSourceResult DataSourceObject {createdTime} -> Just createdTime + _ -> Nothing + -- | Create data source request data CreateDataSource = CreateDataSource { parent :: Parent, properties :: Map Text PropertySchema, title :: Maybe (Vector RichText), + -- | Not in Notion's published request schema; omitted when 'Nothing'. description :: Maybe (Vector RichText), icon :: Maybe Icon, + -- | Not in Notion's published request schema; omitted when 'Nothing'. cover :: Maybe Cover } deriving stock (Generic, Show) @@ -100,15 +189,12 @@ -- | Update data source request. -- --- The @properties@ field uses @Maybe (Maybe PropertySchema)@ to distinguish between: --- --- * @Nothing@ (outer): omit the properties field entirely (don't touch properties) --- * @Just (Map ...)@ with @Just schema@: add or update a property --- * @Just (Map ...)@ with @Nothing@: delete a property (emits @null@ in JSON) +-- Each entry of @properties@ is a 'PropertyUpdate': remove ('RemoveProperty', sent as @null@), +-- rename only, a full schema, or an option-list update. @Nothing@ leaves properties untouched. data UpdateDataSource = UpdateDataSource { title :: Maybe (Vector RichText), icon :: Maybe Icon, - properties :: Maybe (Map Text (Maybe PropertySchema)), + properties :: Maybe (Map Text PropertyUpdate), inTrash :: Maybe Bool, parent :: Maybe Parent } @@ -119,14 +205,9 @@ Aeson.object $ maybe [] (\t -> ["title" .= t]) title <> maybe [] (\i -> ["icon" .= i]) icon - <> maybe [] (\p -> ["properties" .= mapWithNulls p]) properties + <> maybe [] (\p -> ["properties" .= p]) properties <> maybe [] (\t -> ["in_trash" .= t]) inTrash <> maybe [] (\p -> ["parent" .= p]) parent - where - -- Emit Nothing values as JSON null (not omitted) - mapWithNulls :: Map Text (Maybe PropertySchema) -> Value - mapWithNulls m = - Aeson.object $ map (\(k, v) -> Key.fromText k .= v) (Map.toList m) -- | Query data source request data QueryDataSource = QueryDataSource @@ -137,12 +218,40 @@ inTrash :: Maybe Bool, -- | Limit which properties are returned in the response. -- Each element is a property ID (not name). - filterProperties :: Maybe [Text] + filterProperties :: Maybe [Text], + -- | Return only pages or only data sources. Regular (non-wiki) data sources only + -- contain pages. + resultType :: Maybe QueryResultType } deriving stock (Generic, Show) +-- | A query with every optional field unset. Use record update to set fields. +_QueryDataSource :: QueryDataSource +_QueryDataSource = + QueryDataSource + { filter = Nothing, + sorts = Nothing, + startCursor = Nothing, + pageSize = Nothing, + inTrash = Nothing, + filterProperties = Nothing, + resultType = Nothing + } + +-- | Restrict a query to pages or to data sources. +data QueryResultType = ResultTypePage | ResultTypeDataSource + deriving stock (Eq, Show, Generic) + +instance ToJSON QueryResultType where + toJSON ResultTypePage = Aeson.String "page" + toJSON ResultTypeDataSource = Aeson.String "data_source" + +-- | @filter_properties@ is a query parameter, not a body field; 'Notion.V1.makeMethods' +-- moves 'filterProperties' into the URL. instance ToJSON QueryDataSource where - toJSON = genericToJSON aesonOptions + toJSON q = case genericToJSON aesonOptions q of + Object o -> Object (KeyMap.delete "filter_properties" o) + other -> other -- | A reference to a data source template data TemplateRef = TemplateRef @@ -178,8 +287,9 @@ :> Patch '[JSON] DataSourceObject :<|> Capture "data_source_id" DataSourceID :> "query" + :> QueryParams "filter_properties" Text :> ReqBody '[JSON] QueryDataSource - :> Post '[JSON] (ListOf PageObject) + :> Post '[JSON] (ListOf PageOrDataSource) :<|> Capture "data_source_id" DataSourceID :> "templates" :> QueryParam "name" Text diff --git a/src/Notion/V1/Databases.hs b/src/Notion/V1/Databases.hs --- a/src/Notion/V1/Databases.hs +++ b/src/Notion/V1/Databases.hs @@ -3,6 +3,9 @@ ( -- * Main types DatabaseID, DatabaseObject (..), + PartialDatabaseObject (..), + DatabaseType (..), + CreateDatabaseType (..), DataSource (..), InitialDataSource (..), CreateDatabase (..), @@ -16,6 +19,8 @@ import Control.Applicative ((<|>)) import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap import Notion.Prelude import Notion.V1.Common (Cover, Icon, ObjectType (..), Parent, UUID) import Notion.V1.Filter (Filter, Sort) @@ -24,6 +29,7 @@ import Notion.V1.Properties (PropertySchema) import Notion.V1.RichText (RichText) import Notion.V1.Users (UserReference) +import Servant.API (QueryParams) import Prelude hiding (id) -- | Database ID @@ -58,6 +64,8 @@ url :: Text, parent :: Parent, isInline :: Maybe Bool, + -- | The kind of typed database (@tasks@, @wiki@, ...), if any. + databaseType :: Maybe DatabaseType, inTrash :: Maybe Bool, isLocked :: Maybe Bool, publicUrl :: Maybe Text, @@ -84,6 +92,7 @@ url <- o .: "url" parent <- o .: "parent" isInline <- o .:? "is_inline" + databaseType <- o .:? "database_type" inTrash <- (fmap Just (o .: "in_trash")) <|> (fmap Just (o .: "is_archived")) <|> (fmap Just (o .: "archived")) <|> pure Nothing isLocked <- o .:? "is_locked" publicUrl <- o .:? "public_url" @@ -92,10 +101,72 @@ return DatabaseObject {..} _ -> fail "Expected object for DatabaseObject" +-- | @{"object":"database","id":...}@ +-- +-- The minimal database shape Notion returns when the integration cannot see the full object. +newtype PartialDatabaseObject = PartialDatabaseObject {id :: DatabaseID} + deriving stock (Generic, Show) + +instance FromJSON PartialDatabaseObject where + parseJSON = Aeson.withObject "PartialDatabaseObject" $ \o -> PartialDatabaseObject <$> o .: "id" + +-- | The kind of typed database, or an unrecognised value. +data DatabaseType + = TasksDatabase + | ProjectsDatabase + | SprintsDatabase + | DocsDatabase + | WikiDatabase + | MeetingsDatabase + | MeetingNotesDatabase + | SkillsDatabase + | GithubPrsDatabase + | -- | A database type this library does not know yet; holds the raw string. + UnknownDatabaseType Text + deriving stock (Eq, Show, Generic) + +instance FromJSON DatabaseType where + parseJSON = Aeson.withText "DatabaseType" $ \case + "tasks" -> pure TasksDatabase + "projects" -> pure ProjectsDatabase + "sprints" -> pure SprintsDatabase + "docs" -> pure DocsDatabase + "wiki" -> pure WikiDatabase + "meetings" -> pure MeetingsDatabase + "meeting_notes" -> pure MeetingNotesDatabase + "skills" -> pure SkillsDatabase + "github_prs" -> pure GithubPrsDatabase + other -> pure (UnknownDatabaseType other) + +instance ToJSON DatabaseType where + toJSON = + Aeson.String . \case + TasksDatabase -> "tasks" + ProjectsDatabase -> "projects" + SprintsDatabase -> "sprints" + DocsDatabase -> "docs" + WikiDatabase -> "wiki" + MeetingsDatabase -> "meetings" + MeetingNotesDatabase -> "meeting_notes" + SkillsDatabase -> "skills" + GithubPrsDatabase -> "github_prs" + UnknownDatabaseType t -> t + +-- | Typed database kinds accepted by @POST \/v1\/databases@. +data CreateDatabaseType = CreateTasksDatabase | CreateProjectsDatabase | CreateSkillsDatabase + deriving stock (Eq, Show, Generic) + +instance ToJSON CreateDatabaseType where + toJSON = + Aeson.String . \case + CreateTasksDatabase -> "tasks" + CreateProjectsDatabase -> "projects" + CreateSkillsDatabase -> "skills" + -- | Initial data source configuration for database creation. -- Contains the property schema for the database's first data source. newtype InitialDataSource = InitialDataSource - { properties :: Map Text PropertySchema + { properties :: Maybe (Map Text PropertySchema) } deriving stock (Generic, Show) @@ -108,12 +179,15 @@ -- rather than a top-level @properties@ field. data CreateDatabase = CreateDatabase { parent :: Parent, - title :: Vector RichText, + -- | When omitted for a typed database, Notion names it after the type. + title :: Maybe (Vector RichText), initialDataSource :: Maybe InitialDataSource, icon :: Maybe Icon, cover :: Maybe Cover, description :: Maybe (Vector RichText), - isInline :: Maybe Bool + isInline :: Maybe Bool, + -- | Create a typed database. Cannot be combined with 'initialDataSource'. + databaseType :: Maybe CreateDatabaseType } deriving stock (Generic, Show) @@ -152,8 +226,12 @@ } deriving stock (Generic, Show) +-- | @filter_properties@ is a query parameter, not a body field; 'Notion.V1.makeMethods' +-- moves 'filterProperties' into the URL. instance ToJSON QueryDatabase where - toJSON = genericToJSON aesonOptions + toJSON q = case genericToJSON aesonOptions q of + Object o -> Object (KeyMap.delete "filter_properties" o) + other -> other -- | Servant API type API = @@ -167,6 +245,7 @@ :> Patch '[JSON] DatabaseObject :<|> Capture "database_id" DatabaseID :> "query" + :> QueryParams "filter_properties" Text :> ReqBody '[JSON] QueryDatabase :> Post '[JSON] (ListOf PageObject) ) diff --git a/src/Notion/V1/Error.hs b/src/Notion/V1/Error.hs --- a/src/Notion/V1/Error.hs +++ b/src/Notion/V1/Error.hs @@ -1,41 +1,273 @@ -- | Error handling for Notion API +-- +-- A failed request surfaces as one of these exceptions: +-- +-- * 'NotionError': Notion answered with its JSON error envelope. 'code' is a +-- typed 'APIErrorCode'. +-- * 'UnknownHTTPResponseError': a non-2xx response whose body is not a Notion +-- error, for example an HTML page from Notion's edge proxy. +-- * 'RequestTimeoutError': connecting or waiting for response headers timed out. +-- * 'InvalidPathParameterError': the request path contained @..@ and was not sent. +-- +-- Response decoding failures and other connection problems remain servant's +-- 'Client.ClientError'. module Notion.V1.Error - ( -- * Error types + ( -- * Error codes + APIErrorCode (..), + apiErrorCodeText, + parseAPIErrorCode, + + -- * Error types NotionError (..), + HttpErrorResponse (..), + UnknownHTTPResponseError (..), + unknownResponseMessage, + RequestTimeoutError (..), + InvalidPathParameterError (..), + + -- * Building errors + buildRequestError, + notionErrorFromResponse, + fromClientError, parseNotionError, + lookupHeader, ) where -import Control.Exception (Exception) +import Control.Exception (Exception (..), SomeException, toException) +import Data.Aeson ((.!=), (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson +import Data.Foldable (toList) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Network.HTTP.Client qualified as HTTP +import Network.HTTP.Types (HeaderName, ResponseHeaders, Status (..)) import Notion.Prelude import Servant.Client qualified as Client --- | Notion API error response +-- | The error codes Notion documents, plus a fallback for new ones. +data APIErrorCode + = Unauthorized + | RestrictedResource + | ObjectNotFound + | RateLimited + | InvalidJSON + | InvalidRequestURL + | InvalidRequest + | InvalidBeta + | ValidationError + | ConflictError + | InternalServerError + | ServiceOverload + | ServiceUnavailable + | GatewayTimeout + | -- | A code this library does not know yet, carried verbatim. + UnknownErrorCode Text + deriving stock (Eq, Show) + +knownErrorCodes :: [(APIErrorCode, Text)] +knownErrorCodes = + [ (Unauthorized, "unauthorized"), + (RestrictedResource, "restricted_resource"), + (ObjectNotFound, "object_not_found"), + (RateLimited, "rate_limited"), + (InvalidJSON, "invalid_json"), + (InvalidRequestURL, "invalid_request_url"), + (InvalidRequest, "invalid_request"), + (InvalidBeta, "invalid_beta"), + (ValidationError, "validation_error"), + (ConflictError, "conflict_error"), + (InternalServerError, "internal_server_error"), + (ServiceOverload, "service_overload"), + (ServiceUnavailable, "service_unavailable"), + (GatewayTimeout, "gateway_timeout") + ] + +-- | The wire string of a code, for example @"object_not_found"@. +apiErrorCodeText :: APIErrorCode -> Text +apiErrorCodeText = \case + UnknownErrorCode t -> t + c -> fromMaybe "" (lookup c knownErrorCodes) + +-- | Parse a wire string; unrecognised strings become 'UnknownErrorCode'. +parseAPIErrorCode :: Text -> APIErrorCode +parseAPIErrorCode t = + maybe (UnknownErrorCode t) fst (lookupByText t) + where + lookupByText x = case filter ((== x) . snd) knownErrorCodes of + pair : _ -> Just pair + [] -> Nothing + +-- | Lets string literals such as @"validation_error"@ stand for codes. +instance IsString APIErrorCode where + fromString = parseAPIErrorCode . Text.pack + +instance FromJSON APIErrorCode where + parseJSON = Aeson.withText "APIErrorCode" (pure . parseAPIErrorCode) + +instance ToJSON APIErrorCode where + toJSON = String . apiErrorCodeText + +-- | Metadata of the HTTP response an error came from. +data HttpErrorResponse = HttpErrorResponse + { httpStatus :: Int, + -- | Response headers; names compare case-insensitively. + errorHeaders :: ResponseHeaders, + -- | The @x-notion-request-id@ header. + notionRequestId :: Maybe Text, + -- | The @cf-ray@ header (Cloudflare Ray ID). + rayId :: Maybe Text, + -- | The raw response body. + errorBody :: ByteString + } + deriving stock (Eq, Show) + +-- | A well-formed Notion API error response. data NotionError = NotionError - { object :: Text, + { -- | Always @"error"@. + object :: Text, + -- | The body's @status@, or else the HTTP status. status :: Natural, - code :: Text, + code :: APIErrorCode, message :: Text, - details :: Maybe Value + -- | The body's @request_id@, or else the @x-notion-request-id@ header. + requestId :: Maybe Text, + -- | The body's @additional_data@. + additionalData :: Maybe Value, + -- | Legacy field, kept for compatibility. + details :: Maybe Value, + -- | 'Nothing' when decoded from bare JSON rather than an HTTP response. + response :: Maybe HttpErrorResponse } - deriving stock (Generic, Show) + deriving stock (Eq, Show) instance Exception NotionError instance FromJSON NotionError where - parseJSON = genericParseJSON aesonOptions + parseJSON = Aeson.withObject "NotionError" $ \o -> do + object <- o .:? "object" .!= "error" + status <- o .:? "status" .!= 0 + code <- o .: "code" + message <- o .: "message" + requestId <- o .:? "request_id" + additionalData <- o .:? "additional_data" + details <- o .:? "details" + pure NotionError {response = Nothing, ..} instance ToJSON NotionError where - toJSON = genericToJSON aesonOptions + toJSON NotionError {..} = + Aeson.object $ + [ "object" .= object, + "status" .= status, + "code" .= code, + "message" .= message + ] + <> catMaybes + [ ("request_id" .=) <$> requestId, + ("additional_data" .=) <$> additionalData, + ("details" .=) <$> details + ] +-- | A non-2xx response whose body is not a Notion error envelope. +newtype UnknownHTTPResponseError = UnknownHTTPResponseError {unknownResponse :: HttpErrorResponse} + deriving stock (Eq, Show) + +instance Exception UnknownHTTPResponseError where + displayException = Text.unpack . unknownResponseMessage + +-- | Human-readable description, matching the JS SDK. When the response came +-- from Notion's edge proxy (a @cf-ray@ header but no request ID), it explains +-- that and includes the Ray ID for support. +unknownResponseMessage :: UnknownHTTPResponseError -> Text +unknownResponseMessage (UnknownHTTPResponseError HttpErrorResponse {..}) = + case rayId of + Just ray + | Nothing <- notionRequestId -> + base + <> ". The response was returned by Notion's edge proxy before reaching the Notion API" + <> maybe "" (\ct -> " (content-type: " <> ct <> ")") (lookupHeader "content-type" errorHeaders) + <> "." + <> (if httpStatus == 403 then " This may mean the request was blocked by a network security rule." else "") + <> " Cloudflare Ray ID: " + <> ray + <> ". Include this ID when contacting Notion support." + _ -> base + where + base = "Request to Notion API failed with status: " <> Text.pack (show httpStatus) + +-- | Connecting to Notion or waiting for its response headers timed out. +data RequestTimeoutError = RequestTimeoutError + deriving stock (Eq, Show) + +instance Exception RequestTimeoutError where + displayException _ = "Request to Notion API has timed out" + +-- | The request path contained a path traversal sequence; nothing was sent. +newtype InvalidPathParameterError = InvalidPathParameterError {invalidPath :: Text} + deriving stock (Eq, Show) + +instance Exception InvalidPathParameterError where + displayException (InvalidPathParameterError p) = + "Request path \"" <> Text.unpack p <> "\" contains path traversal sequence \"..\"" + +-- | First value of a header, decoded leniently as UTF-8. +lookupHeader :: HeaderName -> ResponseHeaders -> Maybe Text +lookupHeader name hs = Text.decodeUtf8Lenient <$> lookup name hs + +-- | Classify a non-2xx response from its status, headers and body. +buildRequestError :: Int -> ResponseHeaders -> ByteString -> Either UnknownHTTPResponseError NotionError +buildRequestError httpStatus errorHeaders errorBody = + case Aeson.decode errorBody of + Just err@NotionError {status, requestId} -> + Right + err + { status = if status == 0 then fromIntegral httpStatus else status, + requestId = maybe notionRequestId Just requestId, + response = Just meta + } + Nothing -> Left (UnknownHTTPResponseError meta) + where + notionRequestId = lookupHeader "x-notion-request-id" errorHeaders + rayId = lookupHeader "cf-ray" errorHeaders + meta = HttpErrorResponse {..} + +-- | Typed exception for a non-2xx response: a 'NotionError' when the body is a +-- Notion error envelope, else an 'UnknownHTTPResponseError'. Throwing the result +-- with 'Control.Exception.throwIO' can be caught as either type. +notionErrorFromResponse :: Status -> ResponseHeaders -> ByteString -> SomeException +notionErrorFromResponse s hs b = either toException toException (buildRequestError (statusCode s) hs b) + +-- | Convert a servant client error into the exception this library throws. +fromClientError :: Client.ClientError -> SomeException +fromClientError = \case + Client.FailureResponse _ resp -> + notionErrorFromResponse + (Client.responseStatusCode resp) + (toList (Client.responseHeaders resp)) + (Client.responseBody resp) + err@(Client.ConnectionError e) + | Just (HTTP.HttpExceptionRequest _ content) <- fromException e, + isTimeout content -> + toException RequestTimeoutError + | otherwise -> toException err + err -> toException err + where + isTimeout = \case + HTTP.ResponseTimeout -> True + HTTP.ConnectionTimeout -> True + _ -> False + -- | Try to parse a 'NotionError' from a Servant 'Client.ClientError'. -- --- Returns 'Just' if the error is a 'Client.FailureResponse' with a JSON body --- that can be decoded as a 'NotionError'. Returns 'Nothing' for network errors, --- non-JSON responses, or responses that don't match the Notion error format. +-- Returns 'Just' if the error is a 'Client.FailureResponse' whose body is a +-- Notion error envelope, 'Nothing' otherwise. parseNotionError :: Client.ClientError -> Maybe NotionError parseNotionError = \case Client.FailureResponse _req resp -> - Aeson.decode (Client.responseBody resp) + either (const Nothing) Just $ + buildRequestError + (statusCode (Client.responseStatusCode resp)) + (toList (Client.responseHeaders resp)) + (Client.responseBody resp) _ -> Nothing diff --git a/src/Notion/V1/FileUploads.hs b/src/Notion/V1/FileUploads.hs --- a/src/Notion/V1/FileUploads.hs +++ b/src/Notion/V1/FileUploads.hs @@ -10,6 +10,9 @@ -- * Supporting types NumberOfParts (..), FileImportResult (..), + FileUploadCreator (..), + FileUploadCreatorType (..), + FileUploadMode (..), -- * Smart constructors mkSinglePartUpload, @@ -142,11 +145,15 @@ contentLength :: Maybe Natural, createdTime :: POSIXTime, lastEditedTime :: POSIXTime, - createdBy :: Value, + createdBy :: FileUploadCreator, inTrash :: Bool, expiryTime :: Maybe POSIXTime, numberOfParts :: Maybe NumberOfParts, - fileImportResult :: Maybe FileImportResult + fileImportResult :: Maybe FileImportResult, + -- | URL to send the file content to, while the upload is pending. + uploadUrl :: Maybe Text, + -- | URL that completes a multi-part upload, while the upload is pending. + completeUrl :: Maybe Text } deriving stock (Generic, Show) @@ -171,6 +178,8 @@ Just str -> Just <$> parseISO8601 str numberOfParts <- o .:? "number_of_parts" fileImportResult <- o .:? "file_import_result" + uploadUrl <- o .:? "upload_url" + completeUrl <- o .:? "complete_url" pure FileUploadObject {..} _ -> fail "Expected object for FileUploadObject" @@ -191,10 +200,64 @@ <> maybe [] (\et -> ["expiry_time" .= posixToISO8601 et]) expiryTime <> maybe [] (\np -> ["number_of_parts" .= np]) numberOfParts <> maybe [] (\fir -> ["file_import_result" .= fir]) fileImportResult + <> maybe [] (\u -> ["upload_url" .= u]) uploadUrl + <> maybe [] (\u -> ["complete_url" .= u]) completeUrl +-- | Kind of creator of a file upload. +data FileUploadCreatorType + = CreatorPerson + | CreatorBot + | CreatorAgent + | -- | A creator type this library does not know yet; holds the raw string. + UnknownCreatorType Text + deriving stock (Eq, Generic, Show) + +instance FromJSON FileUploadCreatorType where + parseJSON = Aeson.withText "FileUploadCreatorType" $ \case + "person" -> pure CreatorPerson + "bot" -> pure CreatorBot + "agent" -> pure CreatorAgent + other -> pure (UnknownCreatorType other) + +instance ToJSON FileUploadCreatorType where + toJSON = \case + CreatorPerson -> String "person" + CreatorBot -> String "bot" + CreatorAgent -> String "agent" + UnknownCreatorType t -> String t + +-- | Who created a file upload: @{"id": ..., "type": "person" | "bot" | "agent"}@. +data FileUploadCreator = FileUploadCreator + { id :: UUID, + type_ :: FileUploadCreatorType + } + deriving stock (Eq, Generic, Show) + +instance FromJSON FileUploadCreator where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON FileUploadCreator where + toJSON = genericToJSON aesonOptions + +-- | How the file content will be sent. +data FileUploadMode + = -- | One request with the whole file (the default) + SinglePart + | -- | Several parts, then a complete call + MultiPart + | -- | Notion imports the file from a public HTTPS URL + ExternalUrl + deriving stock (Eq, Generic, Show) + +instance ToJSON FileUploadMode where + toJSON = \case + SinglePart -> String "single_part" + MultiPart -> String "multi_part" + ExternalUrl -> String "external_url" + -- | Request body for creating a file upload data CreateFileUpload = CreateFileUpload - { mode :: Maybe Text, + { mode :: Maybe FileUploadMode, filename :: Maybe Text, contentType :: Maybe Text, numberOfParts :: Maybe Natural, @@ -247,7 +310,7 @@ CreateFileUpload mkMultiPartUpload fname parts ct = CreateFileUpload - { mode = Just "multi_part", + { mode = Just MultiPart, filename = Just fname, contentType = ct, numberOfParts = Just parts, @@ -263,7 +326,7 @@ CreateFileUpload mkExternalUrlUpload url fname = CreateFileUpload - { mode = Just "external_url", + { mode = Just ExternalUrl, filename = fname, contentType = Nothing, numberOfParts = Nothing, diff --git a/src/Notion/V1/Filter.hs b/src/Notion/V1/Filter.hs --- a/src/Notion/V1/Filter.hs +++ b/src/Notion/V1/Filter.hs @@ -31,18 +31,27 @@ StatusCondition (..), UniqueIdCondition (..), VerificationCondition (..), + VerificationState (..), FormulaCondition (..), RollupCondition (..), + -- * Relative dates + RelativeDate (..), + relativeDate, + -- * Sorts Sort (..), SortDirection (..), ) where -import Data.Aeson ((.=)) +import Control.Applicative ((<|>)) +import Data.Aeson ((.:), (.:?), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (Parser) +import Data.Foldable (asum) import Data.Scientific (Scientific) import Notion.Prelude @@ -56,6 +65,12 @@ timestampTypeToText FilterCreatedTime = "created_time" timestampTypeToText FilterLastEditedTime = "last_edited_time" +parseTimestampType :: Text -> Parser TimestampType +parseTimestampType = \case + "created_time" -> pure FilterCreatedTime + "last_edited_time" -> pure FilterLastEditedTime + other -> fail ("unknown timestamp: " <> unpack other) + -- | Top-level filter type for querying databases and data sources. -- -- Filters can be compound (@And@ / @Or@, nesting up to 2 levels per Notion API), @@ -65,9 +80,12 @@ | Or [Filter] | PropertyFilter Text PropertyCondition | TimestampFilter TimestampType DateCondition + | -- | A filter shape this library does not model; the raw JSON is kept and re-sent unchanged. + UnknownFilter Value deriving stock (Eq, Show, Generic) instance ToJSON Filter where + toJSON (UnknownFilter v) = v toJSON (And filters) = Aeson.object ["and" .= filters] toJSON (Or filters) = Aeson.object ["or" .= filters] toJSON (PropertyFilter propName condition) = @@ -80,6 +98,23 @@ Key.fromText tsKey .= dateConditionToValue condition ] +-- | Inverts the 'ToJSON' encoding. Shapes the DSL cannot express decode to 'UnknownFilter'. +instance FromJSON Filter where + parseJSON v = case v of + Object o -> + asum + [ And <$> o .: "and", + Or <$> o .: "or", + do + ts <- o .: "timestamp" + tsType <- parseTimestampType ts + cond <- o .: Key.fromText ts >>= parseDateCondition + pure (TimestampFilter tsType cond), + PropertyFilter <$> o .: "property" <*> parsePropertyCondition o, + pure (UnknownFilter v) + ] + _ -> pure (UnknownFilter v) + -- | Property-type-specific filter condition. -- -- Each constructor maps to the JSON key the Notion API expects @@ -107,6 +142,8 @@ | PhoneNumberCondition TextCondition | UrlCondition TextCondition | EmailCondition TextCondition + | -- | A condition this library does not model: the condition key and its raw value. + UnknownCondition Text Value deriving stock (Eq, Show, Generic) -- | Convert a PropertyCondition to key-value pairs for inclusion in a JSON object. @@ -134,7 +171,78 @@ PhoneNumberCondition c -> [("phone_number", textConditionToValue c)] UrlCondition c -> [("url", textConditionToValue c)] EmailCondition c -> [("email", textConditionToValue c)] + UnknownCondition k v -> [(Key.fromText k, v)] +-- | Encodes a condition as the object Notion uses for quick filters, +-- e.g. @{"select":{"equals":"High"}}@. +instance ToJSON PropertyCondition where + toJSON c = Aeson.object (propertyConditionToObject c) + +instance FromJSON PropertyCondition where + parseJSON = Aeson.withObject "PropertyCondition" parsePropertyCondition + +-- | Finds the property-type key (title, rich_text, number, …) and parses its condition. +-- +-- The optional @type@ discriminator wins when present. Otherwise the first known key is used, +-- and failing that, the only key other than @property@ and @type@. A known key whose condition +-- does not parse, or an unknown key, decodes to 'UnknownCondition'. An object with no candidate +-- key fails. +parsePropertyCondition :: Aeson.Object -> Parser PropertyCondition +parsePropertyCondition o = do + discriminator <- o .:? "type" + let known = filter (\k -> KeyMap.member (Key.fromText k) o) (map fst conditionParsers) + others = filter (`notElem` ["property", "type"]) (map Key.toText (KeyMap.keys o)) + chosen = case discriminator of + Just k | KeyMap.member (Key.fromText k) o -> Just k + _ -> case (known, others) of + (k : _, _) -> Just k + ([], [k]) -> Just k + _ -> Nothing + case chosen of + Nothing -> fail "no filter condition key found" + Just k -> do + raw <- o .: Key.fromText k + case lookup k conditionParsers of + Just parser -> parser raw <|> pure (UnknownCondition k raw) + Nothing -> pure (UnknownCondition k raw) + +-- | Condition key and its parser, in the order keys are tried. +conditionParsers :: [(Text, Value -> Parser PropertyCondition)] +conditionParsers = + [ ("title", fmap TitleCondition . parseTextCondition), + ("rich_text", fmap RichTextCondition . parseTextCondition), + ("number", fmap NumberCondition . parseNumberCondition), + ("checkbox", fmap CheckboxCondition . parseCheckboxCondition), + ("select", fmap SelectCondition . parseSelectCondition), + ("multi_select", fmap MultiSelectCondition . parseMultiSelectCondition), + ("status", fmap StatusCondition . parseStatusCondition), + ("date", fmap DateCondition . parseDateCondition), + ("people", fmap PeopleCondition . parsePeopleCondition), + ("files", fmap FilesCondition . parseFilesCondition), + ("url", fmap UrlCondition . parseTextCondition), + ("email", fmap EmailCondition . parseTextCondition), + ("phone_number", fmap PhoneNumberCondition . parseTextCondition), + ("relation", fmap RelationCondition . parseRelationCondition), + ("created_by", fmap CreatedByCondition . parsePeopleCondition), + ("created_time", fmap CreatedTimeCondition . parseDateCondition), + ("last_edited_by", fmap LastEditedByCondition . parsePeopleCondition), + ("last_edited_time", fmap LastEditedTimeCondition . parseDateCondition), + ("formula", fmap FormulaCondition . parseFormulaCondition), + ("unique_id", fmap UniqueIdCondition . parseUniqueIdCondition), + ("rollup", fmap RollupCondition . parseRollupCondition), + ("verification", fmap VerificationCondition . parseVerificationCondition) + ] + +-- | Requires the flag key to hold JSON @true@ (Notion encodes @is_empty@ as @{"is_empty": true}@). +flagKey :: Aeson.Object -> Aeson.Key -> Parser () +flagKey c k = do + b <- c .: k + if b then pure () else fail ("expected true for " <> show k) + +-- | Requires the key to be present (relative dates are encoded as @{"next_week": {}}@). +emptyKey :: Aeson.Object -> Aeson.Key -> Parser () +emptyKey c k = () <$ (c .: k :: Parser Value) + -- | Text filter conditions for title, rich_text, phone_number, url, and email properties. data TextCondition = TextEquals Text @@ -158,6 +266,19 @@ TextIsEmpty -> Aeson.object ["is_empty" .= True] TextIsNotEmpty -> Aeson.object ["is_not_empty" .= True] +parseTextCondition :: Value -> Parser TextCondition +parseTextCondition = Aeson.withObject "TextCondition" $ \c -> + asum + [ TextEquals <$> c .: "equals", + TextDoesNotEqual <$> c .: "does_not_equal", + TextContains <$> c .: "contains", + TextDoesNotContain <$> c .: "does_not_contain", + TextStartsWith <$> c .: "starts_with", + TextEndsWith <$> c .: "ends_with", + TextIsEmpty <$ flagKey c "is_empty", + TextIsNotEmpty <$ flagKey c "is_not_empty" + ] + -- | Number filter conditions. data NumberCondition = NumEquals Scientific @@ -181,6 +302,19 @@ NumIsEmpty -> Aeson.object ["is_empty" .= True] NumIsNotEmpty -> Aeson.object ["is_not_empty" .= True] +parseNumberCondition :: Value -> Parser NumberCondition +parseNumberCondition = Aeson.withObject "NumberCondition" $ \c -> + asum + [ NumEquals <$> c .: "equals", + NumDoesNotEqual <$> c .: "does_not_equal", + NumGreaterThan <$> c .: "greater_than", + NumGreaterThanOrEqualTo <$> c .: "greater_than_or_equal_to", + NumLessThan <$> c .: "less_than", + NumLessThanOrEqualTo <$> c .: "less_than_or_equal_to", + NumIsEmpty <$ flagKey c "is_empty", + NumIsNotEmpty <$ flagKey c "is_not_empty" + ] + -- | Checkbox filter conditions. data CheckboxCondition = CheckboxEquals Bool @@ -192,10 +326,21 @@ CheckboxEquals v -> Aeson.object ["equals" .= v] CheckboxDoesNotEqual v -> Aeson.object ["does_not_equal" .= v] +parseCheckboxCondition :: Value -> Parser CheckboxCondition +parseCheckboxCondition = Aeson.withObject "CheckboxCondition" $ \c -> + asum + [ CheckboxEquals <$> c .: "equals", + CheckboxDoesNotEqual <$> c .: "does_not_equal" + ] + -- | Select filter conditions. data SelectCondition = SelectEquals Text | SelectDoesNotEqual Text + | -- | @{"equals": [..]}@: any of the options. + SelectEqualsAny (NonEmpty Text) + | -- | @{"does_not_equal": [..]}@: none of the options. + SelectDoesNotEqualAny (NonEmpty Text) | SelectIsEmpty | SelectIsNotEmpty deriving stock (Eq, Show, Generic) @@ -204,13 +349,30 @@ selectConditionToValue = \case SelectEquals v -> Aeson.object ["equals" .= v] SelectDoesNotEqual v -> Aeson.object ["does_not_equal" .= v] + SelectEqualsAny vs -> Aeson.object ["equals" .= vs] + SelectDoesNotEqualAny vs -> Aeson.object ["does_not_equal" .= vs] SelectIsEmpty -> Aeson.object ["is_empty" .= True] SelectIsNotEmpty -> Aeson.object ["is_not_empty" .= True] +parseSelectCondition :: Value -> Parser SelectCondition +parseSelectCondition = Aeson.withObject "SelectCondition" $ \c -> + asum + [ SelectEquals <$> c .: "equals", + SelectDoesNotEqual <$> c .: "does_not_equal", + SelectEqualsAny <$> c .: "equals", + SelectDoesNotEqualAny <$> c .: "does_not_equal", + SelectIsEmpty <$ flagKey c "is_empty", + SelectIsNotEmpty <$ flagKey c "is_not_empty" + ] + -- | Multi-select filter conditions. data MultiSelectCondition = MultiSelectContains Text | MultiSelectDoesNotContain Text + | -- | @{"contains": [..]}@ + MultiSelectContainsAny (NonEmpty Text) + | -- | @{"does_not_contain": [..]}@ + MultiSelectDoesNotContainAny (NonEmpty Text) | MultiSelectIsEmpty | MultiSelectIsNotEmpty deriving stock (Eq, Show, Generic) @@ -219,12 +381,26 @@ multiSelectConditionToValue = \case MultiSelectContains v -> Aeson.object ["contains" .= v] MultiSelectDoesNotContain v -> Aeson.object ["does_not_contain" .= v] + MultiSelectContainsAny vs -> Aeson.object ["contains" .= vs] + MultiSelectDoesNotContainAny vs -> Aeson.object ["does_not_contain" .= vs] MultiSelectIsEmpty -> Aeson.object ["is_empty" .= True] MultiSelectIsNotEmpty -> Aeson.object ["is_not_empty" .= True] +parseMultiSelectCondition :: Value -> Parser MultiSelectCondition +parseMultiSelectCondition = Aeson.withObject "MultiSelectCondition" $ \c -> + asum + [ MultiSelectContains <$> c .: "contains", + MultiSelectDoesNotContain <$> c .: "does_not_contain", + MultiSelectContainsAny <$> c .: "contains", + MultiSelectDoesNotContainAny <$> c .: "does_not_contain", + MultiSelectIsEmpty <$ flagKey c "is_empty", + MultiSelectIsNotEmpty <$ flagKey c "is_not_empty" + ] + -- | Date filter conditions. Also used for timestamp filters and created_time/last_edited_time. -- --- Text values are ISO 8601 date strings (e.g., @\"2024-01-15\"@ or @\"2024-01-15T00:00:00Z\"@). +-- Text values are ISO 8601 date strings (e.g., @\"2024-01-15\"@ or @\"2024-01-15T00:00:00Z\"@) +-- or relative date keywords rendered with 'relativeDate'. data DateCondition = DateAfter Text | DateBefore Text @@ -263,6 +439,27 @@ DatePastMonth -> Aeson.object ["past_month" .= Aeson.object []] DatePastYear -> Aeson.object ["past_year" .= Aeson.object []] +parseDateCondition :: Value -> Parser DateCondition +parseDateCondition = Aeson.withObject "DateCondition" $ \c -> + asum + [ DateAfter <$> c .: "after", + DateBefore <$> c .: "before", + DateEquals <$> c .: "equals", + DateOnOrAfter <$> c .: "on_or_after", + DateOnOrBefore <$> c .: "on_or_before", + DateIsEmpty <$ flagKey c "is_empty", + DateIsNotEmpty <$ flagKey c "is_not_empty", + DateNextWeek <$ emptyKey c "next_week", + DateNextMonth <$ emptyKey c "next_month", + DateNextYear <$ emptyKey c "next_year", + DateThisWeek <$ emptyKey c "this_week", + DateThisMonth <$ emptyKey c "this_month", + DateThisYear <$ emptyKey c "this_year", + DatePastWeek <$ emptyKey c "past_week", + DatePastMonth <$ emptyKey c "past_month", + DatePastYear <$ emptyKey c "past_year" + ] + -- | People filter conditions. The Text value is a user UUID. data PeopleCondition = PeopleContains Text @@ -278,6 +475,15 @@ PeopleIsEmpty -> Aeson.object ["is_empty" .= True] PeopleIsNotEmpty -> Aeson.object ["is_not_empty" .= True] +parsePeopleCondition :: Value -> Parser PeopleCondition +parsePeopleCondition = Aeson.withObject "PeopleCondition" $ \c -> + asum + [ PeopleContains <$> c .: "contains", + PeopleDoesNotContain <$> c .: "does_not_contain", + PeopleIsEmpty <$ flagKey c "is_empty", + PeopleIsNotEmpty <$ flagKey c "is_not_empty" + ] + -- | Files filter conditions. data FilesCondition = FilesIsEmpty @@ -289,6 +495,13 @@ FilesIsEmpty -> Aeson.object ["is_empty" .= True] FilesIsNotEmpty -> Aeson.object ["is_not_empty" .= True] +parseFilesCondition :: Value -> Parser FilesCondition +parseFilesCondition = Aeson.withObject "FilesCondition" $ \c -> + asum + [ FilesIsEmpty <$ flagKey c "is_empty", + FilesIsNotEmpty <$ flagKey c "is_not_empty" + ] + -- | Relation filter conditions. The Text value is a page UUID. data RelationCondition = RelationContains Text @@ -304,10 +517,23 @@ RelationIsEmpty -> Aeson.object ["is_empty" .= True] RelationIsNotEmpty -> Aeson.object ["is_not_empty" .= True] +parseRelationCondition :: Value -> Parser RelationCondition +parseRelationCondition = Aeson.withObject "RelationCondition" $ \c -> + asum + [ RelationContains <$> c .: "contains", + RelationDoesNotContain <$> c .: "does_not_contain", + RelationIsEmpty <$ flagKey c "is_empty", + RelationIsNotEmpty <$ flagKey c "is_not_empty" + ] + -- | Status filter conditions. data StatusCondition = StatusEquals Text | StatusDoesNotEqual Text + | -- | @{"equals": [..]}@ + StatusEqualsAny (NonEmpty Text) + | -- | @{"does_not_equal": [..]}@ + StatusDoesNotEqualAny (NonEmpty Text) | StatusIsEmpty | StatusIsNotEmpty deriving stock (Eq, Show, Generic) @@ -316,17 +542,32 @@ statusConditionToValue = \case StatusEquals v -> Aeson.object ["equals" .= v] StatusDoesNotEqual v -> Aeson.object ["does_not_equal" .= v] + StatusEqualsAny vs -> Aeson.object ["equals" .= vs] + StatusDoesNotEqualAny vs -> Aeson.object ["does_not_equal" .= vs] StatusIsEmpty -> Aeson.object ["is_empty" .= True] StatusIsNotEmpty -> Aeson.object ["is_not_empty" .= True] +parseStatusCondition :: Value -> Parser StatusCondition +parseStatusCondition = Aeson.withObject "StatusCondition" $ \c -> + asum + [ StatusEquals <$> c .: "equals", + StatusDoesNotEqual <$> c .: "does_not_equal", + StatusEqualsAny <$> c .: "equals", + StatusDoesNotEqualAny <$> c .: "does_not_equal", + StatusIsEmpty <$ flagKey c "is_empty", + StatusIsNotEmpty <$ flagKey c "is_not_empty" + ] + -- | Unique ID filter conditions. data UniqueIdCondition - = UniqueIdEquals Natural - | UniqueIdDoesNotEqual Natural - | UniqueIdGreaterThan Natural - | UniqueIdGreaterThanOrEqualTo Natural - | UniqueIdLessThan Natural - | UniqueIdLessThanOrEqualTo Natural + = UniqueIdEquals Scientific + | UniqueIdDoesNotEqual Scientific + | UniqueIdGreaterThan Scientific + | UniqueIdGreaterThanOrEqualTo Scientific + | UniqueIdLessThan Scientific + | UniqueIdLessThanOrEqualTo Scientific + | UniqueIdIsEmpty + | UniqueIdIsNotEmpty deriving stock (Eq, Show, Generic) uniqueIdConditionToValue :: UniqueIdCondition -> Aeson.Value @@ -337,17 +578,79 @@ UniqueIdGreaterThanOrEqualTo v -> Aeson.object ["greater_than_or_equal_to" .= v] UniqueIdLessThan v -> Aeson.object ["less_than" .= v] UniqueIdLessThanOrEqualTo v -> Aeson.object ["less_than_or_equal_to" .= v] + UniqueIdIsEmpty -> Aeson.object ["is_empty" .= True] + UniqueIdIsNotEmpty -> Aeson.object ["is_not_empty" .= True] +parseUniqueIdCondition :: Value -> Parser UniqueIdCondition +parseUniqueIdCondition = Aeson.withObject "UniqueIdCondition" $ \c -> + asum + [ UniqueIdEquals <$> c .: "equals", + UniqueIdDoesNotEqual <$> c .: "does_not_equal", + UniqueIdGreaterThan <$> c .: "greater_than", + UniqueIdGreaterThanOrEqualTo <$> c .: "greater_than_or_equal_to", + UniqueIdLessThan <$> c .: "less_than", + UniqueIdLessThanOrEqualTo <$> c .: "less_than_or_equal_to", + UniqueIdIsEmpty <$ flagKey c "is_empty", + UniqueIdIsNotEmpty <$ flagKey c "is_not_empty" + ] + -- | Verification filter condition. --- The Text is one of @\"verified\"@, @\"expired\"@, or @\"none\"@. data VerificationCondition - = VerificationStatus Text + = VerificationStatus VerificationState + | VerificationDoesNotEqual VerificationState deriving stock (Eq, Show, Generic) +-- | Verification states used by verification filters. +data VerificationState + = VerificationVerified + | VerificationExpired + | VerificationNone + | -- | A state this library does not know yet; holds the raw string. + UnknownVerificationState Text + deriving stock (Eq, Show, Generic) + +instance ToJSON VerificationState where + toJSON = + Aeson.String . \case + VerificationVerified -> "verified" + VerificationExpired -> "expired" + VerificationNone -> "none" + UnknownVerificationState t -> t + +instance FromJSON VerificationState where + parseJSON = Aeson.withText "VerificationState" $ \case + "verified" -> pure VerificationVerified + "expired" -> pure VerificationExpired + "none" -> pure VerificationNone + other -> pure (UnknownVerificationState other) + verificationConditionToValue :: VerificationCondition -> Aeson.Value -verificationConditionToValue (VerificationStatus v) = - Aeson.object ["status" .= v] +verificationConditionToValue = \case + VerificationStatus v -> Aeson.object ["status" .= v] + VerificationDoesNotEqual v -> Aeson.object ["does_not_equal" .= v] +parseVerificationCondition :: Value -> Parser VerificationCondition +parseVerificationCondition = Aeson.withObject "VerificationCondition" $ \c -> + asum + [ VerificationStatus <$> c .: "status", + VerificationDoesNotEqual <$> c .: "does_not_equal" + ] + +-- | Relative date keywords accepted wherever a date filter takes a date string. +data RelativeDate = Today | Tomorrow | Yesterday | OneWeekAgo | OneWeekFromNow | OneMonthAgo | OneMonthFromNow + deriving stock (Eq, Show, Generic, Enum, Bounded) + +-- | Render for use with 'DateAfter', 'DateBefore', 'DateEquals', 'DateOnOrAfter' and 'DateOnOrBefore'. +relativeDate :: RelativeDate -> Text +relativeDate = \case + Today -> "today" + Tomorrow -> "tomorrow" + Yesterday -> "yesterday" + OneWeekAgo -> "one_week_ago" + OneWeekFromNow -> "one_week_from_now" + OneMonthAgo -> "one_month_ago" + OneMonthFromNow -> "one_month_from_now" + -- | Formula filter condition, wrapping a condition by the formula's return type. data FormulaCondition = FormulaString TextCondition @@ -363,6 +666,15 @@ FormulaDate c -> Aeson.object ["date" .= dateConditionToValue c] FormulaCheckbox c -> Aeson.object ["checkbox" .= checkboxConditionToValue c] +parseFormulaCondition :: Value -> Parser FormulaCondition +parseFormulaCondition = Aeson.withObject "FormulaCondition" $ \c -> + asum + [ FormulaString <$> (c .: "string" >>= parseTextCondition), + FormulaNumber <$> (c .: "number" >>= parseNumberCondition), + FormulaDate <$> (c .: "date" >>= parseDateCondition), + FormulaCheckbox <$> (c .: "checkbox" >>= parseCheckboxCondition) + ] + -- | Rollup filter condition. data RollupCondition = RollupAny PropertyCondition @@ -383,6 +695,16 @@ conditionInnerValue :: PropertyCondition -> Aeson.Value conditionInnerValue cond = Aeson.object (propertyConditionToObject cond) +parseRollupCondition :: Value -> Parser RollupCondition +parseRollupCondition = Aeson.withObject "RollupCondition" $ \c -> + asum + [ RollupAny <$> (c .: "any" >>= Aeson.withObject "RollupAny" parsePropertyCondition), + RollupEvery <$> (c .: "every" >>= Aeson.withObject "RollupEvery" parsePropertyCondition), + RollupNone <$> (c .: "none" >>= Aeson.withObject "RollupNone" parsePropertyCondition), + RollupNumber <$> (c .: "number" >>= parseNumberCondition), + RollupDate <$> (c .: "date" >>= parseDateCondition) + ] + -- ===================================================================== -- Sorts -- ===================================================================== @@ -397,13 +719,22 @@ toJSON Ascending = Aeson.String "ascending" toJSON Descending = Aeson.String "descending" +instance FromJSON SortDirection where + parseJSON = Aeson.withText "SortDirection" $ \case + "ascending" -> pure Ascending + "descending" -> pure Descending + other -> fail ("unknown sort direction: " <> unpack other) + -- | Sort specification for querying databases and data sources. data Sort = PropertySort Text SortDirection | TimestampSort TimestampType SortDirection + | -- | A sort this library does not model (including unknown directions); the raw JSON is kept. + UnknownSort Value deriving stock (Eq, Show, Generic) instance ToJSON Sort where + toJSON (UnknownSort v) = v toJSON (PropertySort propName dir) = Aeson.object [ "property" .= propName, @@ -414,3 +745,13 @@ [ "timestamp" .= timestampTypeToText tsType, "direction" .= dir ] + +instance FromJSON Sort where + parseJSON v = case v of + Object o -> + asum + [ PropertySort <$> o .: "property" <*> o .: "direction", + TimestampSort <$> (o .: "timestamp" >>= parseTimestampType) <*> o .: "direction", + pure (UnknownSort v) + ] + _ -> pure (UnknownSort v) diff --git a/src/Notion/V1/Helpers.hs b/src/Notion/V1/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Notion/V1/Helpers.hs @@ -0,0 +1,108 @@ +-- | Helpers for turning Notion URLs into IDs, ported from the official JS SDK. +module Notion.V1.Helpers + ( extractNotionId, + extractPageId, + extractDatabaseId, + extractBlockId, + ) +where + +import Data.Char (isHexDigit) +import Data.List (find) +import Data.Maybe (catMaybes, listToMaybe, mapMaybe) +import Data.Text qualified as Text +import Notion.Prelude +import Notion.V1.Common (UUID (..)) + +-- | Extract a Notion ID from a URL or an ID in either format. Returns the +-- lowercase, hyphenated form. +-- +-- Tried in order: a hyphenated UUID; 32 hex digits; a path segment ending in +-- @-\<32 hex digits\>@ (for example @.../Meeting-Notes-\@); a @p@, +-- @page_id@ or @database_id@ query parameter; the first run of 32 hex digits. +-- +-- @ +-- extractNotionId "https://www.notion.so/team/Tasks-abc123def456789012345678901234ab?v=..." +-- == Just (UUID "abc123de-f456-7890-1234-5678901234ab") +-- @ +extractNotionId :: Text -> Maybe UUID +extractNotionId input + | isHyphenatedUuid t = Just (UUID (Text.toLower t)) + | isHex32 t = Just (formatUuid t) + | otherwise = formatUuid <$> firstJust [pathRule, queryRule, anyRule] + where + t = Text.strip input + + pathRule = + listToMaybe + [ Text.takeEnd 32 segment + | rest <- afterEach (== '/') t, + let segment = Text.takeWhile (`notElem` ("/?#" :: String)) rest, + Text.length segment >= 33, + Text.take 1 (Text.takeEnd 33 segment) == "-", + isHex32 (Text.takeEnd 32 segment) + ] + + queryRule = + listToMaybe + [ candidate + | rest <- afterEach (`elem` ("?&" :: String)) t, + prefix <- ["p=", "page_id=", "database_id="], + Text.toLower (Text.take (Text.length prefix) rest) == prefix, + let candidate = Text.take 32 (Text.drop (Text.length prefix) rest), + isHex32 candidate + ] + + anyRule = find isHex32 (map (Text.take 32) (Text.tails t)) + +-- | Alias of 'extractNotionId' for page URLs. +extractPageId :: Text -> Maybe UUID +extractPageId = extractNotionId + +-- | Alias of 'extractNotionId' for database URLs. +extractDatabaseId :: Text -> Maybe UUID +extractDatabaseId = extractNotionId + +-- | Extract a block ID from a URL fragment: @#block-\@ or @#\@. +extractBlockId :: Text -> Maybe UUID +extractBlockId input = + formatUuid + <$> listToMaybe + [ candidate + | rest <- afterEach (== '#') input, + let afterPrefix = + if Text.toLower (Text.take 6 rest) == "block-" then Text.drop 6 rest else rest + candidate = Text.take 32 afterPrefix, + isHex32 candidate + ] + +-- | The remainder of the text after each character matching the predicate, left to right. +afterEach :: (Char -> Bool) -> Text -> [Text] +afterEach p = mapMaybe after . Text.tails + where + after s = case Text.uncons s of + Just (c, rest) | p c -> Just rest + _ -> Nothing + +firstJust :: [Maybe a] -> Maybe a +firstJust = listToMaybe . catMaybes + +isHex32 :: Text -> Bool +isHex32 s = Text.length s == 32 && Text.all isHexDigit s + +isHyphenatedUuid :: Text -> Bool +isHyphenatedUuid s = + Text.length s == 36 + && and (zipWith valid [0 :: Int ..] (Text.unpack s)) + where + valid i c + | i `elem` [8, 13, 18, 23] = c == '-' + | otherwise = isHexDigit c + +-- | Lowercase 32 hex digits with hyphens in the 8-4-4-4-12 pattern. +formatUuid :: Text -> UUID +formatUuid hex = + UUID . Text.intercalate "-" $ + [Text.take 8 l, Text.take 4 (Text.drop 8 l), Text.take 4 (Text.drop 12 l), Text.take 4 (Text.drop 16 l), Text.drop 20 l] + where + l = Text.toLower hex diff --git a/src/Notion/V1/ListOf.hs b/src/Notion/V1/ListOf.hs --- a/src/Notion/V1/ListOf.hs +++ b/src/Notion/V1/ListOf.hs @@ -2,10 +2,14 @@ module Notion.V1.ListOf ( -- * Types ListOf (..), + RequestStatus (..), + RequestStatusType (..), + IncompleteReason (..), ) where -import Data.Aeson ((.!=), (.:), (.:?)) +import Data.Aeson ((.!=), (.:), (.:?), (.=)) +import Data.Aeson qualified as Aeson import Notion.Prelude -- | Notion API typically returns paginated results with this structure @@ -14,7 +18,9 @@ nextCursor :: Maybe Text, hasMore :: Bool, type_ :: Maybe Text, - object :: Maybe Text + object :: Maybe Text, + -- | Present on query and list responses that may be truncated server-side. + requestStatus :: Maybe RequestStatus } deriving stock (Generic, Show) @@ -26,5 +32,59 @@ hasMore <- o .:? "has_more" .!= False type_ <- o .:? "type" object <- o .:? "object" + requestStatus <- o .:? "request_status" return $ List {..} _ -> fail "Expected object for ListOf" + +-- | Whether a list response contains every matching result. +data RequestStatus = RequestStatus + { type_ :: RequestStatusType, + incompleteReason :: Maybe IncompleteReason + } + deriving stock (Eq, Generic, Show) + +data RequestStatusType + = RequestComplete + | RequestIncomplete + | -- | A status this library does not know yet; holds the raw string. + UnknownRequestStatusType Text + deriving stock (Eq, Show) + +data IncompleteReason + = QueryResultLimitReached + | -- | A reason this library does not know yet; holds the raw string. + UnknownIncompleteReason Text + deriving stock (Eq, Show) + +instance FromJSON RequestStatus where + parseJSON = Aeson.withObject "RequestStatus" $ \o -> do + type_ <- o .: "type" + incompleteReason <- o .:? "incomplete_reason" + pure RequestStatus {..} + +instance ToJSON RequestStatus where + toJSON RequestStatus {..} = + Aeson.object $ + ["type" .= type_] <> maybe [] (\r -> ["incomplete_reason" .= r]) incompleteReason + +instance FromJSON RequestStatusType where + parseJSON = Aeson.withText "RequestStatusType" $ \case + "complete" -> pure RequestComplete + "incomplete" -> pure RequestIncomplete + other -> pure (UnknownRequestStatusType other) + +instance ToJSON RequestStatusType where + toJSON = \case + RequestComplete -> String "complete" + RequestIncomplete -> String "incomplete" + UnknownRequestStatusType t -> String t + +instance FromJSON IncompleteReason where + parseJSON = Aeson.withText "IncompleteReason" $ \case + "query_result_limit_reached" -> pure QueryResultLimitReached + other -> pure (UnknownIncompleteReason other) + +instance ToJSON IncompleteReason where + toJSON = \case + QueryResultLimitReached -> String "query_result_limit_reached" + UnknownIncompleteReason t -> String t diff --git a/src/Notion/V1/MeetingNotes.hs b/src/Notion/V1/MeetingNotes.hs new file mode 100644 --- /dev/null +++ b/src/Notion/V1/MeetingNotes.hs @@ -0,0 +1,606 @@ +-- | @\/v1\/blocks\/meeting_notes@ +-- +-- A meeting note is a @meeting_notes@ block produced by Notion AI from a +-- recording: a title, a processing status and three child tabs (summary, +-- notes and transcript). The payload sub-types are shared with +-- 'Notion.V1.BlockContent'. +module Notion.V1.MeetingNotes + ( -- * Responses + MeetingNotesContent (..), + MeetingNoteBlock (..), + CreateMeetingNoteResponse (..), + + -- * Payload types (re-exported from "Notion.V1.BlockContent") + MeetingNotesStatus (..), + MeetingNotesChildren (..), + MeetingCalendarEvent (..), + MeetingRecording (..), + + -- * Creating + CreateMeetingNote (..), + MeetingNoteSource (..), + MeetingNoteLanguage (..), + mkCreateMeetingNote, + + -- * Querying + QueryMeetingNotes (..), + emptyQueryMeetingNotes, + QueryMeetingNotesResponse (..), + MeetingNotesSort (..), + MeetingNotesProperty (..), + + -- * Filters + MeetingNotesFilter (..), + MeetingNotesCombinator (..), + MeetingNotesFilterNode (..), + MeetingNotesPropertyFilter (..), + MeetingNotesTextCondition (..), + MeetingNotesDateCondition (..), + MeetingNotesPersonCondition (..), + MeetingNotesDateValueType (..), + MeetingNotesDatePoint (..), + MeetingNotesDatePointValue (..), + MeetingNotesDateSpec (..), + MeetingNotesDateRange (..), + MeetingNotesDateRangeValue (..), + MeetingNotesDirection (..), + MeetingNotesDateUnit (..), + + -- * Filter helpers + mnAnd, + mnOr, + mnTitleContains, + mnAttendeesInclude, + mnCreatedOnOrAfter, + mnCreatedWithinPast, + + -- * Servant + API, + ) +where + +import Control.Applicative ((<|>)) +import Data.Aeson ((.:), (.:?), (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.List.NonEmpty qualified as NonEmpty +import Data.Maybe (catMaybes) +import Notion.Prelude +import Notion.V1.BlockContent (MeetingCalendarEvent (..), MeetingNotesChildren (..), MeetingNotesStatus (..), MeetingRecording (..)) +import Notion.V1.Common (BlockID, ObjectType (..), UUID) +import Notion.V1.Filter (SortDirection (..)) +import Notion.V1.RichText (RichText) +import Notion.V1.Users (UserID, UserReference) +import Prelude hiding (id) + +-- | The @meeting_notes@ payload returned by the create and query endpoints. +-- +-- Field names are prefixed so they do not clash with the fields of the +-- 'Notion.V1.BlockContent.MeetingNotesBlock' constructor. +data MeetingNotesContent = MeetingNotesContent + { contentTitle :: Maybe (Vector RichText), + contentStatus :: Maybe MeetingNotesStatus, + contentChildren :: Maybe MeetingNotesChildren, + contentCalendarEvent :: Maybe MeetingCalendarEvent, + contentRecording :: Maybe MeetingRecording + } + deriving stock (Eq, Generic, Show) + +instance FromJSON MeetingNotesContent where + parseJSON = Aeson.withObject "MeetingNotesContent" $ \o -> do + contentTitle <- o .:? "title" + contentStatus <- o .:? "status" + contentChildren <- o .:? "children" + contentCalendarEvent <- o .:? "calendar_event" + contentRecording <- o .:? "recording" + pure MeetingNotesContent {..} + +instance ToJSON MeetingNotesContent where + toJSON MeetingNotesContent {..} = + Aeson.object $ + catMaybes + [ ("title" .=) <$> contentTitle, + ("status" .=) <$> contentStatus, + ("children" .=) <$> contentChildren, + ("calendar_event" .=) <$> contentCalendarEvent, + ("recording" .=) <$> contentRecording + ] + +-- | A meeting-notes block as returned by the create and query endpoints. +-- Unlike 'Notion.V1.Blocks.BlockObject' it carries no @parent@. +data MeetingNoteBlock = MeetingNoteBlock + { id :: BlockID, + meetingNotes :: MeetingNotesContent, + createdTime :: POSIXTime, + lastEditedTime :: POSIXTime, + createdBy :: UserReference, + lastEditedBy :: UserReference, + hasChildren :: Bool, + inTrash :: Bool, + object :: ObjectType + } + deriving stock (Generic, Show) + +instance FromJSON MeetingNoteBlock where + parseJSON = Aeson.withObject "MeetingNoteBlock" $ \o -> do + id <- o .: "id" + meetingNotes <- o .: "meeting_notes" + createdTime <- parseISO8601 =<< o .: "created_time" + lastEditedTime <- parseISO8601 =<< o .: "last_edited_time" + createdBy <- o .: "created_by" + lastEditedBy <- o .: "last_edited_by" + hasChildren <- o .: "has_children" + inTrash <- (o .: "in_trash") <|> (o .: "archived") <|> pure False + object <- o .: "object" + pure MeetingNoteBlock {..} + +instance ToJSON MeetingNoteBlock where + toJSON MeetingNoteBlock {..} = + Aeson.object + [ "object" .= object, + "id" .= id, + "type" .= ("meeting_notes" :: Text), + "meeting_notes" .= meetingNotes, + "created_time" .= posixToISO8601 createdTime, + "last_edited_time" .= posixToISO8601 lastEditedTime, + "created_by" .= createdBy, + "last_edited_by" .= lastEditedBy, + "has_children" .= hasChildren, + "in_trash" .= inTrash + ] + +-- | Response of 'Notion.V1.createMeetingNote': the full block or only its id. +data CreateMeetingNoteResponse + = FullMeetingNote MeetingNoteBlock + | PartialMeetingNote BlockID + deriving stock (Generic, Show) + +-- | Full when the @meeting_notes@ key is present. +instance FromJSON CreateMeetingNoteResponse where + parseJSON = Aeson.withObject "CreateMeetingNoteResponse" $ \o -> + if KeyMap.member "meeting_notes" o + then FullMeetingNote <$> parseJSON (Object o) + else PartialMeetingNote <$> o .: "id" + +instance ToJSON CreateMeetingNoteResponse where + toJSON = \case + FullMeetingNote b -> toJSON b + PartialMeetingNote bid -> Aeson.object ["object" .= ("block" :: Text), "id" .= bid] + +-- | Transcription language hint. +data MeetingNoteLanguage + = LanguageAuto + | LanguageEn + | LanguageZhCN + | LanguageZhTW + | LanguageEs + | LanguageFr + | LanguageDe + | LanguageJa + | LanguageKo + | LanguagePt + | LanguageRu + | LanguageTh + | LanguageVi + | LanguageId + | LanguageDa + | LanguageFi + | LanguageNo + | LanguageNl + | LanguageIt + | LanguageSv + | LanguageAr + | LanguageHe + | LanguagePl + | -- | A language code this library does not list; sent verbatim. + LanguageOther Text + deriving stock (Eq, Generic, Show) + +instance ToJSON MeetingNoteLanguage where + toJSON = + String . \case + LanguageAuto -> "auto" + LanguageEn -> "en" + LanguageZhCN -> "zh-CN" + LanguageZhTW -> "zh-TW" + LanguageEs -> "es" + LanguageFr -> "fr" + LanguageDe -> "de" + LanguageJa -> "ja" + LanguageKo -> "ko" + LanguagePt -> "pt" + LanguageRu -> "ru" + LanguageTh -> "th" + LanguageVi -> "vi" + LanguageId -> "id" + LanguageDa -> "da" + LanguageFi -> "fi" + LanguageNo -> "no" + LanguageNl -> "nl" + LanguageIt -> "it" + LanguageSv -> "sv" + LanguageAr -> "ar" + LanguageHe -> "he" + LanguagePl -> "pl" + LanguageOther t -> t + +-- | The recording a meeting note is made from. +data MeetingNoteSource + = -- | A completed audio or video file upload, and the page to create the + -- note in. + FromFileUpload {fileUploadId :: UUID, parentPageId :: UUID} + | -- | An existing audio, video or file block. No parent is sent. + FromBlock {sourceBlockId :: BlockID} + deriving stock (Eq, Generic, Show) + +-- | Request body of 'Notion.V1.createMeetingNote'. +data CreateMeetingNote = CreateMeetingNote + { source :: MeetingNoteSource, + title :: Maybe Text, + language :: Maybe MeetingNoteLanguage, + -- | Sent as @options.kickoff_summary@: start summary generation after + -- transcription. + kickoffSummary :: Maybe Bool + } + deriving stock (Eq, Generic, Show) + +instance ToJSON CreateMeetingNote where + toJSON CreateMeetingNote {..} = + Aeson.object $ + sourcePairs + <> catMaybes + [ ("title" .=) <$> title, + ("language" .=) <$> language, + (\b -> "options" .= Aeson.object ["kickoff_summary" .= b]) <$> kickoffSummary + ] + where + sourcePairs = case source of + FromFileUpload {fileUploadId, parentPageId} -> + [ "source" .= Aeson.object ["type" .= ("file_upload" :: Text), "file_upload_id" .= fileUploadId], + "parent" .= Aeson.object ["type" .= ("page_id" :: Text), "page_id" .= parentPageId] + ] + FromBlock {sourceBlockId} -> + ["source" .= Aeson.object ["type" .= ("block" :: Text), "block_id" .= sourceBlockId]] + +-- | A request with only a source. +mkCreateMeetingNote :: MeetingNoteSource -> CreateMeetingNote +mkCreateMeetingNote source = + CreateMeetingNote {source, title = Nothing, language = Nothing, kickoffSummary = Nothing} + +-- | A combinator filter: all ('MNAnd') or any ('MNOr') of its nodes match. +-- Nodes nest to any depth; the server decides the maximum. +data MeetingNotesFilter = MeetingNotesFilter + { operator :: MeetingNotesCombinator, + filters :: [MeetingNotesFilterNode] + } + deriving stock (Eq, Generic, Show) + +data MeetingNotesCombinator = MNAnd | MNOr + deriving stock (Eq, Generic, Show) + +-- | One entry of a combinator's @filters@. +data MeetingNotesFilterNode + = MNNested MeetingNotesFilter + | MNProperty MeetingNotesPropertyFilter + | -- | Escape hatch for filter shapes this library does not model; sent verbatim. + MNRawNode Value + deriving stock (Eq, Generic, Show) + +-- | A condition on one of the filterable properties. +data MeetingNotesPropertyFilter + = MNTitle MeetingNotesTextCondition + | MNCreatedTime MeetingNotesDateCondition + | MNLastEditedTime MeetingNotesDateCondition + | MNCreatedBy MeetingNotesPersonCondition + | MNLastEditedBy MeetingNotesPersonCondition + | MNAttendees MeetingNotesPersonCondition + deriving stock (Eq, Generic, Show) + +data MeetingNotesTextCondition + = MNStringIs Text + | MNStringIsNot Text + | MNStringContains Text + | MNStringDoesNotContain Text + | MNStringStartsWith Text + | MNStringEndsWith Text + | MNTextIsEmpty + | MNTextIsNotEmpty + deriving stock (Eq, Generic, Show) + +data MeetingNotesDateCondition + = MNDateIs MeetingNotesDatePoint + | MNDateIsBefore MeetingNotesDatePoint + | MNDateIsAfter MeetingNotesDatePoint + | MNDateIsOnOrBefore MeetingNotesDatePoint + | MNDateIsOnOrAfter MeetingNotesDatePoint + | MNDateIsWithin MeetingNotesDateRange + | MNDateIsRelativeTo MeetingNotesDateRange + | MNDateIsEmpty + | MNDateIsNotEmpty + deriving stock (Eq, Generic, Show) + +-- | Person conditions always encode their users as a JSON array. +data MeetingNotesPersonCondition + = MNPersonContains (NonEmpty UserID) + | MNPersonDoesNotContain (NonEmpty UserID) + | MNPersonIsEmpty + | MNPersonIsNotEmpty + deriving stock (Eq, Generic, Show) + +data MeetingNotesDateValueType = MNRelative | MNExact + deriving stock (Eq, Generic, Show) + +-- | Value of a point date condition (@date_is@, @date_is_before@, ...). +data MeetingNotesDatePoint = MeetingNotesDatePoint + { valueType :: MeetingNotesDateValueType, + value :: MeetingNotesDatePointValue + } + deriving stock (Eq, Generic, Show) + +data MeetingNotesDatePointValue + = -- | @"value": ""@. With 'MNRelative', Notion accepts @today@, + -- @tomorrow@, @yesterday@, @one_week_ago@, @one_week_from_now@, + -- @one_month_ago@ and @one_month_from_now@. + MNDatePointText Text + | -- | @"value": {"type": "date" | "datetime", ...}@ + MNDatePointSpec MeetingNotesDateSpec + deriving stock (Eq, Generic, Show) + +data MeetingNotesDateSpec = MeetingNotesDateSpec + { -- | 'False' sends @"date"@, 'True' sends @"datetime"@. + withTime :: Bool, + -- | For example @"2026-09-01"@. + startDate :: Text, + -- | For example @"09:30"@. + startTime :: Maybe Text, + -- | IANA name, for example @"Asia/Tokyo"@. + timeZone :: Maybe Text + } + deriving stock (Eq, Generic, Show) + +-- | Value of a range date condition (@date_is_within@, @date_is_relative_to@). +data MeetingNotesDateRange = MeetingNotesDateRange + { valueType :: MeetingNotesDateValueType, + value :: MeetingNotesDateRangeValue, + direction :: Maybe MeetingNotesDirection, + unit :: Maybe MeetingNotesDateUnit, + count :: Maybe Natural + } + deriving stock (Eq, Generic, Show) + +data MeetingNotesDateRangeValue + = -- | @"value": ""@. With 'MNRelative', Notion accepts + -- @the_past_week@, @the_past_month@, @the_past_year@, @the_next_week@, + -- @the_next_month@, @the_next_year@ and @this_week@, or @custom@ (and + -- @surrounding@) together with 'unit' and 'count'. + MNDateRangeText Text + | -- | @{"type": "daterange", "start_date": ..., "end_date"?: ...}@ + MNDateRangeSpec Text (Maybe Text) + deriving stock (Eq, Generic, Show) + +data MeetingNotesDirection = MNPast | MNFuture + deriving stock (Eq, Generic, Show) + +data MeetingNotesDateUnit = MNDay | MNWeek | MNMonth | MNYear + deriving stock (Eq, Generic, Show) + +-- | Properties meeting notes can be filtered and sorted by. +data MeetingNotesProperty + = MNPropTitle + | MNPropCreatedTime + | MNPropLastEditedTime + | MNPropCreatedBy + | MNPropLastEditedBy + | MNPropAttendees + deriving stock (Eq, Generic, Show) + +data MeetingNotesSort = MeetingNotesSort + { property :: MeetingNotesProperty, + direction :: SortDirection + } + deriving stock (Eq, Generic, Show) + +-- | Request body of 'Notion.V1.queryMeetingNotes'. +data QueryMeetingNotes = QueryMeetingNotes + { filter :: Maybe MeetingNotesFilter, + sort :: Maybe [MeetingNotesSort], + -- | The server default is 50. + limit :: Maybe Natural + } + deriving stock (Eq, Generic, Show) + +-- | A query with no filter, sort or limit; encodes as @{}@. +emptyQueryMeetingNotes :: QueryMeetingNotes +emptyQueryMeetingNotes = QueryMeetingNotes Nothing Nothing Nothing + +-- | Response of 'Notion.V1.queryMeetingNotes'. There is no cursor. +data QueryMeetingNotesResponse = QueryMeetingNotesResponse + { results :: Vector MeetingNoteBlock, + hasMore :: Bool + } + deriving stock (Generic, Show) + +instance FromJSON QueryMeetingNotesResponse where + parseJSON = Aeson.withObject "QueryMeetingNotesResponse" $ \o -> + QueryMeetingNotesResponse <$> o .: "results" <*> o .: "has_more" + +instance ToJSON QueryMeetingNotesResponse where + toJSON (QueryMeetingNotesResponse rs more) = Aeson.object ["results" .= rs, "has_more" .= more] + +instance ToJSON MeetingNotesCombinator where + toJSON MNAnd = String "and" + toJSON MNOr = String "or" + +instance ToJSON MeetingNotesFilter where + toJSON (MeetingNotesFilter op nodes) = Aeson.object ["operator" .= op, "filters" .= nodes] + +instance ToJSON MeetingNotesFilterNode where + toJSON = \case + MNNested f -> toJSON f + MNProperty p -> toJSON p + MNRawNode v -> v + +instance ToJSON MeetingNotesPropertyFilter where + toJSON pf = Aeson.object ["property" .= prop, "filter" .= condition] + where + (prop, condition) = case pf of + MNTitle c -> (MNPropTitle, toJSON c) + MNCreatedTime c -> (MNPropCreatedTime, toJSON c) + MNLastEditedTime c -> (MNPropLastEditedTime, toJSON c) + MNCreatedBy c -> (MNPropCreatedBy, toJSON c) + MNLastEditedBy c -> (MNPropLastEditedBy, toJSON c) + MNAttendees c -> (MNPropAttendees, toJSON c) + +instance ToJSON MeetingNotesProperty where + toJSON = + String . \case + MNPropTitle -> "title" + MNPropCreatedTime -> "created_time" + MNPropLastEditedTime -> "last_edited_time" + MNPropCreatedBy -> "created_by" + MNPropLastEditedBy -> "last_edited_by" + MNPropAttendees -> "attendees" + +-- | @{"operator": op}@ +noValue :: Text -> Value +noValue op = Aeson.object ["operator" .= op] + +-- | @{"operator": op, "value": v}@ +withValue :: (ToJSON v) => Text -> v -> Value +withValue op v = Aeson.object ["operator" .= op, "value" .= v] + +instance ToJSON MeetingNotesTextCondition where + toJSON = \case + MNStringIs t -> exact "string_is" t + MNStringIsNot t -> exact "string_is_not" t + MNStringContains t -> exact "string_contains" t + MNStringDoesNotContain t -> exact "string_does_not_contain" t + MNStringStartsWith t -> exact "string_starts_with" t + MNStringEndsWith t -> exact "string_ends_with" t + MNTextIsEmpty -> noValue "is_empty" + MNTextIsNotEmpty -> noValue "is_not_empty" + where + exact op t = withValue op (Aeson.object ["type" .= ("exact" :: Text), "value" .= t]) + +instance ToJSON MeetingNotesDateCondition where + toJSON = \case + MNDateIs p -> withValue "date_is" p + MNDateIsBefore p -> withValue "date_is_before" p + MNDateIsAfter p -> withValue "date_is_after" p + MNDateIsOnOrBefore p -> withValue "date_is_on_or_before" p + MNDateIsOnOrAfter p -> withValue "date_is_on_or_after" p + MNDateIsWithin r -> withValue "date_is_within" r + MNDateIsRelativeTo r -> withValue "date_is_relative_to" r + MNDateIsEmpty -> noValue "is_empty" + MNDateIsNotEmpty -> noValue "is_not_empty" + +instance ToJSON MeetingNotesPersonCondition where + toJSON = \case + MNPersonContains users -> withValue "person_contains" (personValues users) + MNPersonDoesNotContain users -> withValue "person_does_not_contain" (personValues users) + MNPersonIsEmpty -> noValue "is_empty" + MNPersonIsNotEmpty -> noValue "is_not_empty" + where + personValues = map personValue . NonEmpty.toList + personValue uid = + Aeson.object + [ "type" .= ("exact" :: Text), + "value" .= Aeson.object ["table" .= ("notion_user" :: Text), "id" .= uid] + ] + +instance ToJSON MeetingNotesDateValueType where + toJSON MNRelative = String "relative" + toJSON MNExact = String "exact" + +instance ToJSON MeetingNotesDatePoint where + toJSON (MeetingNotesDatePoint vt v) = Aeson.object ["type" .= vt, "value" .= v] + +instance ToJSON MeetingNotesDatePointValue where + toJSON = \case + MNDatePointText t -> String t + MNDatePointSpec spec -> toJSON spec + +instance ToJSON MeetingNotesDateSpec where + toJSON MeetingNotesDateSpec {..} = + Aeson.object $ + [ "type" .= (if withTime then "datetime" else "date" :: Text), + "start_date" .= startDate + ] + <> catMaybes [("start_time" .=) <$> startTime, ("time_zone" .=) <$> timeZone] + +instance ToJSON MeetingNotesDateRange where + toJSON (MeetingNotesDateRange vt v dir u n) = + Aeson.object $ + ["type" .= vt, "value" .= v] + <> catMaybes [("direction" .=) <$> dir, ("unit" .=) <$> u, ("count" .=) <$> n] + +instance ToJSON MeetingNotesDateRangeValue where + toJSON = \case + MNDateRangeText t -> String t + MNDateRangeSpec start end -> + Aeson.object $ + ["type" .= ("daterange" :: Text), "start_date" .= start] + <> catMaybes [("end_date" .=) <$> end] + +instance ToJSON MeetingNotesDirection where + toJSON MNPast = String "past" + toJSON MNFuture = String "future" + +instance ToJSON MeetingNotesDateUnit where + toJSON = + String . \case + MNDay -> "day" + MNWeek -> "week" + MNMonth -> "month" + MNYear -> "year" + +instance ToJSON MeetingNotesSort where + toJSON (MeetingNotesSort prop dir) = Aeson.object ["property" .= prop, "direction" .= dir] + +instance ToJSON QueryMeetingNotes where + toJSON (QueryMeetingNotes f s l) = + Aeson.object $ + catMaybes + [ ("filter" .=) <$> f, + ("sort" .=) <$> s, + ("limit" .=) <$> l + ] + +-- | All of the nodes match. +mnAnd :: [MeetingNotesFilterNode] -> MeetingNotesFilter +mnAnd = MeetingNotesFilter MNAnd + +-- | Any of the nodes matches. +mnOr :: [MeetingNotesFilterNode] -> MeetingNotesFilter +mnOr = MeetingNotesFilter MNOr + +-- | The title contains the text. +mnTitleContains :: Text -> MeetingNotesFilterNode +mnTitleContains = MNProperty . MNTitle . MNStringContains + +-- | The attendees include the user. +mnAttendeesInclude :: UserID -> MeetingNotesFilterNode +mnAttendeesInclude uid = MNProperty (MNAttendees (MNPersonContains (uid :| []))) + +-- | Created on or after a @YYYY-MM-DD@ date. +mnCreatedOnOrAfter :: Text -> MeetingNotesFilterNode +mnCreatedOnOrAfter day = + MNProperty . MNCreatedTime . MNDateIsOnOrAfter $ + MeetingNotesDatePoint MNExact (MNDatePointSpec (MeetingNotesDateSpec False day Nothing Nothing)) + +-- | Created within the past @count@ units, relative to now. +mnCreatedWithinPast :: Natural -> MeetingNotesDateUnit -> MeetingNotesFilterNode +mnCreatedWithinPast n u = + MNProperty . MNCreatedTime . MNDateIsWithin $ + MeetingNotesDateRange MNRelative (MNDateRangeText "custom") (Just MNPast) (Just u) (Just n) + +-- | Servant API +type API = + "blocks" + :> "meeting_notes" + :> ( ReqBody '[JSON] CreateMeetingNote + :> Post '[JSON] CreateMeetingNoteResponse + :<|> "query" + :> ReqBody '[JSON] QueryMeetingNotes + :> Post '[JSON] QueryMeetingNotesResponse + ) diff --git a/src/Notion/V1/OAuth.hs b/src/Notion/V1/OAuth.hs new file mode 100644 --- /dev/null +++ b/src/Notion/V1/OAuth.hs @@ -0,0 +1,234 @@ +-- | @\/v1\/oauth@: exchange, revoke and introspect OAuth tokens. +-- +-- These endpoints authenticate with HTTP Basic auth using the integration's +-- client ID and secret instead of a bearer token, so they have their own API +-- type and methods record. +-- +-- @ +-- manager <- newTlsManager +-- let oauth = makeOAuthMethodsWith defaultClientConfig +-- (mkClientEnv manager defaultBaseUrl) +-- OAuthCredentials {clientId = "...", clientSecret = "..."} +-- token <- createOAuthToken oauth (AuthorizationCode AuthorizationCodeGrant +-- {code = codeFromRedirect, redirectUri = Just callbackUrl, externalAccount = Nothing}) +-- @ +module Notion.V1.OAuth + ( -- * Credentials + OAuthCredentials (..), + basicAuthorization, + + -- * Requests + OAuthTokenRequest (..), + AuthorizationCodeGrant (..), + ExternalAccount (..), + TokenBody (..), + + -- * Responses + OAuthTokenResponse (..), + OAuthOwner (..), + OAuthOwnerUser (..), + OAuthRevokeResponse (..), + OAuthIntrospectResponse (..), + + -- * Methods + OAuthMethods (..), + makeOAuthMethods, + makeOAuthMethodsWith, + + -- * Servant + API, + ) +where + +import Data.Aeson ((.:), (.:?), (.=)) +import Data.Aeson qualified as Aeson +import Data.ByteString.Base64 qualified as Base64 +import Data.Maybe (catMaybes) +import Data.Proxy (Proxy (..)) +import Data.Text.Encoding qualified as Text +import Notion.Prelude +import Notion.V1.Client (ClientConfig (..), configureClientEnv, legacyClientConfig, runClientWith) +import Notion.V1.Common (UUID) +import Servant.Client (ClientEnv) +import Servant.Client qualified as Client +import Prelude hiding (id) + +-- | An integration's OAuth client ID and secret. +data OAuthCredentials = OAuthCredentials + { clientId :: Text, + clientSecret :: Text + } + +-- | @Basic base64(client_id:client_secret)@ +basicAuthorization :: OAuthCredentials -> Text +basicAuthorization OAuthCredentials {clientId, clientSecret} = + "Basic " <> Text.decodeUtf8 (Base64.encode (Text.encodeUtf8 (clientId <> ":" <> clientSecret))) + +-- | Body of @POST /v1/oauth/token@. +data OAuthTokenRequest + = -- | Exchange the code from the OAuth redirect. + AuthorizationCode AuthorizationCodeGrant + | -- | Exchange a refresh token. + RefreshToken Text + deriving stock (Eq, Show) + +data AuthorizationCodeGrant = AuthorizationCodeGrant + { code :: Text, + redirectUri :: Maybe Text, + externalAccount :: Maybe ExternalAccount + } + deriving stock (Eq, Show) + +data ExternalAccount = ExternalAccount + { key :: Text, + name :: Text + } + deriving stock (Eq, Show) + +instance ToJSON ExternalAccount where + toJSON ExternalAccount {key, name} = Aeson.object ["key" .= key, "name" .= name] + +instance ToJSON OAuthTokenRequest where + toJSON = \case + AuthorizationCode AuthorizationCodeGrant {code, redirectUri, externalAccount} -> + Aeson.object $ + ["grant_type" .= ("authorization_code" :: Text), "code" .= code] + <> catMaybes + [ ("redirect_uri" .=) <$> redirectUri, + ("external_account" .=) <$> externalAccount + ] + RefreshToken token -> + Aeson.object ["grant_type" .= ("refresh_token" :: Text), "refresh_token" .= token] + +-- | Body of the revoke and introspect endpoints. +newtype TokenBody = TokenBody {token :: Text} + deriving stock (Eq, Show) + +instance ToJSON TokenBody where + toJSON TokenBody {token} = Aeson.object ["token" .= token] + +-- | Response of @POST /v1/oauth/token@. +data OAuthTokenResponse = OAuthTokenResponse + { accessToken :: Text, + -- | Always @"bearer"@. + tokenType :: Text, + refreshToken :: Maybe Text, + botId :: Text, + workspaceIcon :: Maybe Text, + workspaceName :: Maybe Text, + workspaceId :: Text, + owner :: OAuthOwner, + duplicatedTemplateId :: Maybe Text, + requestId :: Maybe Text + } + deriving stock (Eq, Generic, Show) + +instance FromJSON OAuthTokenResponse where + parseJSON = genericParseJSON aesonOptions + +-- | Who owns the integration's access. +data OAuthOwner + = OAuthUserOwner OAuthOwnerUser + | OAuthWorkspaceOwner + | -- | An owner kind this library does not model yet; holds the raw object. + UnknownOAuthOwner Value + deriving stock (Eq, Show) + +instance FromJSON OAuthOwner where + parseJSON = Aeson.withObject "OAuthOwner" $ \o -> do + ownerType :: Text <- o .: "type" + case ownerType of + "user" -> OAuthUserOwner <$> o .: "user" + "workspace" -> pure OAuthWorkspaceOwner + _ -> pure (UnknownOAuthOwner (Object o)) + +-- | A full person user or a partial user (only @id@ and @object@); the +-- person-only fields are 'Nothing' for a partial user. +data OAuthOwnerUser = OAuthOwnerUser + { id :: UUID, + object :: Text, + type_ :: Maybe Text, + name :: Maybe Text, + avatarUrl :: Maybe Text, + -- | From @person.email@. + email :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON OAuthOwnerUser where + parseJSON = Aeson.withObject "OAuthOwnerUser" $ \o -> do + id <- o .: "id" + object <- o .: "object" + type_ <- o .:? "type" + name <- o .:? "name" + avatarUrl <- o .:? "avatar_url" + person <- o .:? "person" + email <- maybe (pure Nothing) (.:? "email") person + pure OAuthOwnerUser {..} + +-- | Response of @POST /v1/oauth/revoke@. +newtype OAuthRevokeResponse = OAuthRevokeResponse {requestId :: Maybe Text} + deriving stock (Eq, Show) + +instance FromJSON OAuthRevokeResponse where + parseJSON = Aeson.withObject "OAuthRevokeResponse" $ \o -> OAuthRevokeResponse <$> o .:? "request_id" + +-- | Response of @POST /v1/oauth/introspect@. +data OAuthIntrospectResponse = OAuthIntrospectResponse + { active :: Bool, + scope :: Maybe Text, + -- | Issued-at time, in seconds since the Unix epoch. + iat :: Maybe Integer, + requestId :: Maybe Text + } + deriving stock (Eq, Generic, Show) + +instance FromJSON OAuthIntrospectResponse where + parseJSON = genericParseJSON aesonOptions + +-- | Servant API +type API = + Header' [Required, Strict] "Authorization" Text + :> Header' [Required, Strict] "Notion-Version" Text + :> "oauth" + :> ( "token" + :> ReqBody '[JSON] OAuthTokenRequest + :> Post '[JSON] OAuthTokenResponse + :<|> "revoke" + :> ReqBody '[JSON] TokenBody + :> Post '[JSON] OAuthRevokeResponse + :<|> "introspect" + :> ReqBody '[JSON] TokenBody + :> Post '[JSON] OAuthIntrospectResponse + ) + +-- | OAuth endpoints, authenticated with the integration's credentials. +data OAuthMethods = OAuthMethods + { createOAuthToken :: OAuthTokenRequest -> IO OAuthTokenResponse, + revokeOAuthToken :: Text -> IO OAuthRevokeResponse, + introspectOAuthToken :: Text -> IO OAuthIntrospectResponse + } + +-- | OAuth methods with 'legacyClientConfig', like 'Notion.V1.makeMethods'. +makeOAuthMethods :: ClientEnv -> OAuthCredentials -> OAuthMethods +makeOAuthMethods = makeOAuthMethodsWith legacyClientConfig + +-- | OAuth methods with a configuration. The routes are relative to the +-- 'ClientEnv' base URL (normally @https://api.notion.com/v1@) and use the same +-- runtime (retries, timeout, logging) as 'Notion.V1.Methods'. +makeOAuthMethodsWith :: ClientConfig -> ClientEnv -> OAuthCredentials -> OAuthMethods +makeOAuthMethodsWith config env creds = + OAuthMethods + { createOAuthToken, + revokeOAuthToken = revoke_ . TokenBody, + introspectOAuthToken = introspect_ . TokenBody + } + where + createOAuthToken :<|> revoke_ :<|> introspect_ = + Client.hoistClient + @API + Proxy + (runClientWith (configureClientEnv config env)) + (Client.client @API Proxy) + (basicAuthorization creds) + (notionVersion config) diff --git a/src/Notion/V1/Pages.hs b/src/Notion/V1/Pages.hs --- a/src/Notion/V1/Pages.hs +++ b/src/Notion/V1/Pages.hs @@ -3,14 +3,18 @@ ( -- * Main types PageID, PageObject (..), + PartialPageObject (..), CreatePage (..), + PagePosition (..), UpdatePage (..), + UpdatePageTemplate (..), PageProperties, mkCreatePage, mkUpdatePage, -- * Property item PropertyItemResponse (..), + PropertyItemList (..), -- * Markdown PageMarkdown (..), @@ -19,10 +23,12 @@ ContentUpdate (..), ReplaceContentRequest (..), InsertContentRequest (..), + InsertPosition (..), ReplaceContentRangeRequest (..), -- * Move MovePage (..), + MovePageParent (..), -- * Templates Template (..), @@ -35,15 +41,20 @@ import Control.Applicative ((<|>)) import Data.Aeson ((.:), (.:?), (.=)) import Data.Aeson qualified as Aeson +import Data.Aeson.Key (Key) import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (Pair) +import Data.Map qualified as Map +import Data.Maybe (fromMaybe) import Notion.Prelude +import Notion.V1.AsyncTasks (AllowAsync, AsyncVerb) import Notion.V1.BlockContent (BlockContent) -import Notion.V1.Blocks (Position) +import Notion.V1.Clearable (Clearable (..)) import Notion.V1.Common (Cover, Icon, ObjectType (..), Parent, UUID) import Notion.V1.ListOf (ListOf) -import Notion.V1.PropertyValue (PropertyValue) +import Notion.V1.PropertyValue (PropertyValue, RollupResult) import Notion.V1.Users (UserReference) -import Servant.API (QueryParams) +import Servant.API (QueryParams, StdMethod (PATCH, POST)) -- | Page ID type PageID = UUID @@ -111,6 +122,18 @@ <> maybe [] (\v -> ["is_archived" .= v]) isArchived <> maybe [] (\pu -> ["public_url" .= pu]) publicUrl +-- | @{"object":"page","id":...}@ +-- +-- A reference to a page returned where Notion sends only the ID, for example +-- view query results. +newtype PartialPageObject = PartialPageObject {id :: PageID} + deriving stock (Generic, Show) + +instance FromJSON PartialPageObject where + parseJSON = \case + Object o -> PartialPageObject <$> o .: "id" + _ -> fail "Expected object for PartialPageObject" + -- | Template configuration for page creation and updates. -- -- When applying a template, the @children@ parameter is prohibited as @@ -140,27 +163,71 @@ ] <> maybe [] (\tz -> ["timezone" .= tz]) mTz --- | Create a page request +-- | Where to place a new page among its parent's content (@POST /v1/pages@). +-- Distinct from 'InsertPosition' and 'Notion.V1.Blocks.Position', which use @start@/@end@. +data PagePosition + = PageAfterBlock UUID + | PageStart + | PageEnd + deriving stock (Eq, Generic, Show) + +instance ToJSON PagePosition where + toJSON (PageAfterBlock blockId) = + Aeson.object ["type" .= ("after_block" :: Text), "after_block" .= Aeson.object ["id" .= blockId]] + toJSON PageStart = Aeson.object ["type" .= ("page_start" :: Text)] + toJSON PageEnd = Aeson.object ["type" .= ("page_end" :: Text)] + +-- | Template choice when updating a page. Unlike 'Template', there is no +-- "none" option: the API rejects @{"type":"none"}@ on update. +data UpdatePageTemplate + = -- | Apply the data source's default template; optional IANA timezone. + UpdateDefaultTemplate (Maybe Text) + | -- | Apply a specific template page; optional IANA timezone. + UpdateTemplateById UUID (Maybe Text) + deriving stock (Eq, Generic, Show) + +instance ToJSON UpdatePageTemplate where + toJSON (UpdateDefaultTemplate mTz) = + Aeson.object (["type" .= ("default" :: Text)] <> maybe [] (\tz -> ["timezone" .= tz]) mTz) + toJSON (UpdateTemplateById tid mTz) = + Aeson.object + ( ["type" .= ("template_id" :: Text), "template_id" .= tid] + <> maybe [] (\tz -> ["timezone" .= tz]) mTz + ) + +-- | Create a page request. +-- +-- Every field is optional on the wire. Without a 'parent' the page is created +-- as a private workspace page. 'properties' is omitted when the map is empty. data CreatePage = CreatePage - { parent :: Parent, + { parent :: Maybe Parent, properties :: PageProperties, children :: Maybe (Vector BlockContent), markdown :: Maybe Text, icon :: Maybe Icon, cover :: Maybe Cover, template :: Maybe Template, - position :: Maybe Position + position :: Maybe PagePosition } deriving stock (Generic, Show) instance ToJSON CreatePage where - toJSON = genericToJSON aesonOptions + toJSON CreatePage {..} = + Aeson.object $ + optionalPair "parent" parent + <> propertiesPair properties + <> optionalPair "children" children + <> optionalPair "markdown" markdown + <> optionalPair "icon" icon + <> optionalPair "cover" cover + <> optionalPair "template" template + <> optionalPair "position" position -- | Smart constructor for 'CreatePage' with required fields mkCreatePage :: Parent -> PageProperties -> CreatePage mkCreatePage parent properties = CreatePage - { parent, + { parent = Just parent, properties, children = Nothing, markdown = Nothing, @@ -170,21 +237,33 @@ position = Nothing } --- | Update a page request +-- | Update a page request. +-- +-- 'properties' is omitted when the map is empty. 'icon' and 'cover' can be +-- removed from the page with 'Clear'. data UpdatePage = UpdatePage { properties :: PageProperties, inTrash :: Maybe Bool, isLocked :: Maybe Bool, isArchived :: Maybe Bool, - icon :: Maybe Icon, - cover :: Maybe Cover, - template :: Maybe Template, + icon :: Clearable Icon, + cover :: Clearable Cover, + template :: Maybe UpdatePageTemplate, eraseContent :: Maybe Bool } deriving stock (Generic, Show) instance ToJSON UpdatePage where - toJSON = genericToJSON aesonOptions + toJSON UpdatePage {..} = + Aeson.object $ + propertiesPair properties + <> optionalPair "in_trash" inTrash + <> optionalPair "is_locked" isLocked + <> optionalPair "is_archived" isArchived + <> clearablePair "icon" icon + <> clearablePair "cover" cover + <> optionalPair "template" template + <> optionalPair "erase_content" eraseContent -- | Smart constructor for 'UpdatePage' with required fields mkUpdatePage :: PageProperties -> UpdatePage @@ -194,12 +273,26 @@ inTrash = Nothing, isLocked = Nothing, isArchived = Nothing, - icon = Nothing, - cover = Nothing, + icon = Unset, + cover = Unset, template = Nothing, eraseContent = Nothing } +optionalPair :: (ToJSON a) => Key -> Maybe a -> [Pair] +optionalPair k = maybe [] (\v -> [k .= v]) + +clearablePair :: (ToJSON a) => Key -> Clearable a -> [Pair] +clearablePair k = \case + Unset -> [] + Clear -> [k .= Aeson.Null] + Set v -> [k .= v] + +propertiesPair :: PageProperties -> [Pair] +propertiesPair ps + | Map.null ps = [] + | otherwise = ["properties" .= ps] + -- | Page properties map type PageProperties = Map Text PropertyValue @@ -207,7 +300,8 @@ -- -- Contains the page content rendered as Notion-flavored enhanced markdown. data PageMarkdown = PageMarkdown - { id :: PageID, + { object :: ObjectType, + id :: PageID, markdown :: Text, truncated :: Bool, unknownBlockIds :: Vector UUID @@ -215,20 +309,34 @@ deriving stock (Generic, Show) instance FromJSON PageMarkdown where - parseJSON = genericParseJSON aesonOptions + parseJSON = Aeson.withObject "PageMarkdown" $ \o -> do + object <- fromMaybe PageMarkdownObjectType <$> o .:? "object" + id <- o .: "id" + markdown <- o .: "markdown" + truncated <- o .: "truncated" + unknownBlockIds <- o .: "unknown_block_ids" + pure PageMarkdown {..} instance ToJSON PageMarkdown where toJSON = genericToJSON aesonOptions +-- | Destination of a page move. Only pages and data sources are valid targets. +data MovePageParent + = MoveToPage UUID + | MoveToDataSource UUID + deriving stock (Eq, Generic, Show) + +instance ToJSON MovePageParent where + toJSON (MoveToPage pid) = Aeson.object ["type" .= ("page_id" :: Text), "page_id" .= pid] + toJSON (MoveToDataSource dsid) = + Aeson.object ["type" .= ("data_source_id" :: Text), "data_source_id" .= dsid] + -- | Move a page to a new parent -data MovePage = MovePage - { parent :: Parent, - position :: Maybe Position - } +newtype MovePage = MovePage {parent :: MovePageParent} deriving stock (Generic, Show) instance ToJSON MovePage where - toJSON = genericToJSON aesonOptions + toJSON (MovePage p) = Aeson.object ["parent" .= p] -- | Update page markdown request -- @@ -304,13 +412,23 @@ -- Inserts markdown content at a position specified by an ellipsis-based selector. data InsertContentRequest = InsertContentRequest { content :: Text, - after :: Maybe Text + after :: Maybe Text, + -- | Insert at the start or end of the page. Cannot be combined with 'after'. + position :: Maybe InsertPosition } deriving stock (Generic, Show) instance ToJSON InsertContentRequest where toJSON = genericToJSON aesonOptions +-- | Where @insert_content@ places new markdown. +data InsertPosition = InsertAtStart | InsertAtEnd + deriving stock (Eq, Generic, Show) + +instance ToJSON InsertPosition where + toJSON InsertAtStart = Aeson.object ["type" .= ("start" :: Text)] + toJSON InsertAtEnd = Aeson.object ["type" .= ("end" :: Text)] + -- | Request body for the @replace_content_range@ command (legacy). -- Replaces content in a range specified by an ellipsis-based selector. data ReplaceContentRangeRequest = ReplaceContentRangeRequest @@ -331,19 +449,35 @@ data PropertyItemResponse = -- | A single property value SinglePropertyItem PropertyValue - | -- | A paginated list of property items. The 'Text' is the property type name. - PaginatedPropertyItems (ListOf PropertyValue) Text + | -- | A paginated list of property items + PaginatedPropertyItems PropertyItemList deriving stock (Show) +-- | A paginated property item response (title, rich_text, people, relation, +-- rollup). 'nextUrl' is the URL of the next page of items, if any; 'rollup' +-- is the rollup summary Notion attaches to paginated rollup properties. +data PropertyItemList = PropertyItemList + { items :: ListOf PropertyValue, + propertyType :: Text, + propertyId :: Text, + nextUrl :: Maybe Text, + rollup :: Maybe RollupResult + } + deriving stock (Show) + instance FromJSON PropertyItemResponse where parseJSON = \case Object o -> do -- Check if this is a paginated response (has "results" key) or single item if KeyMap.member "results" o then do - listOf <- Aeson.parseJSON (Object o) - propType <- o .: "property_item" >>= (.: "type") - pure $ PaginatedPropertyItems listOf propType + items <- Aeson.parseJSON (Object o) + propertyItem <- o .: "property_item" + propertyType <- propertyItem .: "type" + propertyId <- fromMaybe "" <$> propertyItem .:? "id" + nextUrl <- propertyItem .:? "next_url" + rollup <- propertyItem .:? "rollup" + pure $ PaginatedPropertyItems PropertyItemList {..} else SinglePropertyItem <$> Aeson.parseJSON (Object o) _ -> fail "Expected object for PropertyItemResponse" @@ -353,9 +487,11 @@ :> ( Capture "page_id" PageID :> QueryParams "filter_properties" Text :> Get '[JSON] PageObject - :<|> ReqBody '[JSON] CreatePage + :<|> QueryParams "filter_properties" Text + :> ReqBody '[JSON] CreatePage :> Post '[JSON] PageObject :<|> Capture "page_id" PageID + :> QueryParams "filter_properties" Text :> ReqBody '[JSON] UpdatePage :> Patch '[JSON] PageObject :<|> Capture "page_id" PageID @@ -376,4 +512,10 @@ :> "move" :> ReqBody '[JSON] MovePage :> Post '[JSON] PageObject + :<|> ReqBody '[JSON] (AllowAsync CreatePage) + :> AsyncVerb 'POST PageObject + :<|> Capture "page_id" PageID + :> "markdown" + :> ReqBody '[JSON] (AllowAsync UpdatePageMarkdown) + :> AsyncVerb 'PATCH PageMarkdown ) diff --git a/src/Notion/V1/Pagination.hs b/src/Notion/V1/Pagination.hs --- a/src/Notion/V1/Pagination.hs +++ b/src/Notion/V1/Pagination.hs @@ -7,10 +7,13 @@ -- * Auto-pagination paginateAll, paginateCollect, + paginateFoldM, + paginateForM_, PaginationResult (..), ) where +import Control.Monad (foldM) import Data.Vector qualified as Vector import Notion.Prelude import Notion.V1.ListOf (ListOf (..)) @@ -62,6 +65,22 @@ -- @ paginateAll :: (Maybe Text -> IO (ListOf a)) -> IO (Vector a) paginateAll fetch = allResults <$> paginateCollect fetch + +-- | Fold over every item of a paginated endpoint, holding one page in memory at +-- a time. Follows cursors like 'paginateAll'. +paginateFoldM :: (b -> a -> IO b) -> b -> (Maybe Text -> IO (ListOf a)) -> IO b +paginateFoldM step initial fetch = go Nothing initial + where + go cursor acc = do + List {results, nextCursor, hasMore} <- fetch cursor + acc' <- foldM step acc results + case nextCursor of + Just nc | hasMore -> go (Just nc) acc' + _ -> pure acc' + +-- | Run an action for every item of a paginated endpoint. +paginateForM_ :: (Maybe Text -> IO (ListOf a)) -> (a -> IO ()) -> IO () +paginateForM_ fetch action = paginateFoldM (\() a -> action a) () fetch -- | Like 'paginateAll' but also returns the number of pages fetched. paginateCollect :: (Maybe Text -> IO (ListOf a)) -> IO (PaginationResult a) diff --git a/src/Notion/V1/Properties.hs b/src/Notion/V1/Properties.hs --- a/src/Notion/V1/Properties.hs +++ b/src/Notion/V1/Properties.hs @@ -17,12 +17,21 @@ NumberFormat (..), RollupFunction (..), RelationType (..), + + -- * Data source property updates + PropertyUpdate (..), + OptionUpdate (..), + OptionTarget (..), ) where -import Data.Aeson (object, (.:), (.:?), (.=)) +import Data.Aeson (object, (.!=), (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap import Data.Aeson.Types (Parser) +import Data.Text qualified as Text +import Data.Vector qualified as Vector import Notion.Prelude import Notion.V1.Common (UUID) import Prelude hiding (id) @@ -74,7 +83,8 @@ data SelectOption = SelectOption { id :: Maybe Text, name :: Text, - color :: Maybe SelectColor + color :: Maybe SelectColor, + description :: Maybe Text } deriving stock (Eq, Show, Generic) @@ -140,6 +150,8 @@ | ArgentinePeso | UruguayanPeso | SingaporeDollar + | -- | A format this library does not know yet; Notion treats the set as open. + OtherNumberFormat Text deriving stock (Eq, Show, Generic) instance FromJSON NumberFormat where @@ -183,7 +195,7 @@ "argentine_peso" -> pure ArgentinePeso "uruguayan_peso" -> pure UruguayanPeso "singapore_dollar" -> pure SingaporeDollar - other -> fail $ "Unknown NumberFormat: " <> unpack other + other -> pure (OtherNumberFormat other) instance ToJSON NumberFormat where toJSON NumberPlain = Aeson.String "number" @@ -225,6 +237,7 @@ toJSON ArgentinePeso = Aeson.String "argentine_peso" toJSON UruguayanPeso = Aeson.String "uruguayan_peso" toJSON SingaporeDollar = Aeson.String "singapore_dollar" + toJSON (OtherNumberFormat t) = Aeson.String t -- | Rollup aggregation function. data RollupFunction @@ -323,9 +336,10 @@ -- | Relation property type configuration. data RelationType = SingleProperty - | DualProperty - { syncedPropertyId :: Text, - syncedPropertyName :: Text + | -- | Both synced fields are optional in requests; Notion fills them in responses. + DualProperty + { syncedPropertyId :: Maybe Text, + syncedPropertyName :: Maybe Text } deriving stock (Eq, Show, Generic) @@ -336,107 +350,131 @@ case relType of "single_property" -> pure SingleProperty "dual_property" -> do - dp <- o .: "dual_property" - syncedPropertyId <- dp .: "synced_property_id" - syncedPropertyName <- dp .: "synced_property_name" + dp <- o .:? "dual_property" .!= KeyMap.empty + syncedPropertyId <- dp .:? "synced_property_id" + syncedPropertyName <- dp .:? "synced_property_name" pure DualProperty {..} other -> fail $ "Unknown RelationType: " <> unpack other _ -> fail "Expected object for RelationType" instance ToJSON RelationType where - toJSON SingleProperty = - object ["type" .= ("single_property" :: Text)] - toJSON DualProperty {..} = - object - [ "type" .= ("dual_property" :: Text), - "dual_property" - .= object - [ "synced_property_id" .= syncedPropertyId, - "synced_property_name" .= syncedPropertyName - ] - ] + toJSON relType = object (relationTypeFields relType) +relationTypeFields :: RelationType -> [(Aeson.Key, Value)] +relationTypeFields = \case + SingleProperty -> + [ "type" .= ("single_property" :: Text), + "single_property" .= object [] + ] + DualProperty {..} -> + [ "type" .= ("dual_property" :: Text), + "dual_property" + .= object + ( maybe [] (\v -> ["synced_property_id" .= v]) syncedPropertyId + <> maybe [] (\v -> ["synced_property_name" .= v]) syncedPropertyName + ) + ] + -- | Typed property schema for a database or data source property. -- --- Each constructor carries the common envelope fields (@schemaId@, @schemaName@) --- plus any type-specific configuration. The JSON representation uses a @type@ --- discriminator with the configuration nested under a key matching the type name. +-- Each constructor carries the common envelope fields (@schemaId@, @schemaName@, +-- @schemaDescription@) plus any type-specific configuration. The JSON representation uses a +-- @type@ discriminator with the configuration nested under a key matching the type name. +-- +-- Request bodies may leave @schemaId@ empty; an empty id is not sent. data PropertySchema - = TitleSchema {schemaId :: Text, schemaName :: Text} - | RichTextSchema {schemaId :: Text, schemaName :: Text} - | NumberSchema {schemaId :: Text, schemaName :: Text, numberFormat :: NumberFormat} - | SelectSchema {schemaId :: Text, schemaName :: Text, selectOptions :: Vector SelectOption} - | MultiSelectSchema {schemaId :: Text, schemaName :: Text, multiSelectOptions :: Vector SelectOption} - | DateSchema {schemaId :: Text, schemaName :: Text} - | PeopleSchema {schemaId :: Text, schemaName :: Text} - | FilesSchema {schemaId :: Text, schemaName :: Text} - | CheckboxSchema {schemaId :: Text, schemaName :: Text} - | UrlSchema {schemaId :: Text, schemaName :: Text} - | EmailSchema {schemaId :: Text, schemaName :: Text} - | PhoneNumberSchema {schemaId :: Text, schemaName :: Text} - | FormulaSchema {schemaId :: Text, schemaName :: Text, formulaExpression :: Text} - | RelationSchema {schemaId :: Text, schemaName :: Text, relationDataSourceId :: UUID, relationType :: RelationType} + = TitleSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | RichTextSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | NumberSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text, numberFormat :: NumberFormat} + | SelectSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text, selectOptions :: Vector SelectOption} + | MultiSelectSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text, multiSelectOptions :: Vector SelectOption} + | DateSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | PeopleSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | FilesSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | CheckboxSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | UrlSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | EmailSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | PhoneNumberSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | FormulaSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text, formulaExpression :: Text} + | RelationSchema + { schemaId :: Text, + schemaName :: Text, + schemaDescription :: Maybe Text, + relationDataSourceId :: UUID, + -- | The database containing the related data source (response only). + relationDatabaseId :: Maybe UUID, + relationType :: RelationType + } | RollupSchema { schemaId :: Text, schemaName :: Text, + schemaDescription :: Maybe Text, rollupFunction :: RollupFunction, rollupRelationPropertyName :: Maybe Text, rollupRelationPropertyId :: Maybe Text, rollupPropertyName :: Maybe Text, rollupPropertyId :: Maybe Text } - | CreatedTimeSchema {schemaId :: Text, schemaName :: Text} - | CreatedBySchema {schemaId :: Text, schemaName :: Text} - | LastEditedTimeSchema {schemaId :: Text, schemaName :: Text} - | LastEditedBySchema {schemaId :: Text, schemaName :: Text} - | StatusSchema {schemaId :: Text, schemaName :: Text, statusOptions :: Vector SelectOption, statusGroups :: Vector StatusGroup} - | UniqueIdSchema {schemaId :: Text, schemaName :: Text, uniqueIdPrefix :: Maybe Text} - | PlaceSchema {schemaId :: Text, schemaName :: Text} - | ButtonSchema {schemaId :: Text, schemaName :: Text} - | VerificationSchema {schemaId :: Text, schemaName :: Text} + | CreatedTimeSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | CreatedBySchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | LastEditedTimeSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | LastEditedBySchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | -- | A status schema. Creation requests may only send options; 'statusGroups' is omitted + -- when empty. + StatusSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text, statusOptions :: Vector SelectOption, statusGroups :: Vector StatusGroup} + | UniqueIdSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text, uniqueIdPrefix :: Maybe Text} + | PlaceSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | ButtonSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | VerificationSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | LocationSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | LastVisitedTimeSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text} + | -- | A property type this client does not model; @schemaConfig@ is the raw value under the type key. + UnknownSchema {schemaId :: Text, schemaName :: Text, schemaDescription :: Maybe Text, schemaType :: Text, schemaConfig :: Value} deriving stock (Eq, Show, Generic) instance FromJSON PropertySchema where parseJSON = \case Object o -> do - sid <- o .: "id" - sname <- o .: "name" + sid <- o .:? "id" .!= "" + sname <- o .:? "name" .!= "" + sdesc <- o .:? "description" propType <- o .: "type" - parseByType sid sname propType o + parseByType sid sname sdesc propType o _ -> fail "Expected object for PropertySchema" where - parseByType :: Text -> Text -> Text -> Aeson.Object -> Parser PropertySchema - parseByType sid sname = \case - "title" -> \_ -> pure TitleSchema {schemaId = sid, schemaName = sname} - "rich_text" -> \_ -> pure RichTextSchema {schemaId = sid, schemaName = sname} + parseByType :: Text -> Text -> Maybe Text -> Text -> Aeson.Object -> Parser PropertySchema + parseByType sid sname sdesc = \case + "title" -> \_ -> pure TitleSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} + "rich_text" -> \_ -> pure RichTextSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} "number" -> \o -> do cfg <- o .: "number" fmt <- cfg .: "format" - pure NumberSchema {schemaId = sid, schemaName = sname, numberFormat = fmt} + pure NumberSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc, numberFormat = fmt} "select" -> \o -> do cfg <- o .: "select" opts <- cfg .: "options" - pure SelectSchema {schemaId = sid, schemaName = sname, selectOptions = opts} + pure SelectSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc, selectOptions = opts} "multi_select" -> \o -> do cfg <- o .: "multi_select" opts <- cfg .: "options" - pure MultiSelectSchema {schemaId = sid, schemaName = sname, multiSelectOptions = opts} - "date" -> \_ -> pure DateSchema {schemaId = sid, schemaName = sname} - "people" -> \_ -> pure PeopleSchema {schemaId = sid, schemaName = sname} - "files" -> \_ -> pure FilesSchema {schemaId = sid, schemaName = sname} - "checkbox" -> \_ -> pure CheckboxSchema {schemaId = sid, schemaName = sname} - "url" -> \_ -> pure UrlSchema {schemaId = sid, schemaName = sname} - "email" -> \_ -> pure EmailSchema {schemaId = sid, schemaName = sname} - "phone_number" -> \_ -> pure PhoneNumberSchema {schemaId = sid, schemaName = sname} + pure MultiSelectSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc, multiSelectOptions = opts} + "date" -> \_ -> pure DateSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} + "people" -> \_ -> pure PeopleSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} + "files" -> \_ -> pure FilesSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} + "checkbox" -> \_ -> pure CheckboxSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} + "url" -> \_ -> pure UrlSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} + "email" -> \_ -> pure EmailSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} + "phone_number" -> \_ -> pure PhoneNumberSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} "formula" -> \o -> do cfg <- o .: "formula" expr <- cfg .: "expression" - pure FormulaSchema {schemaId = sid, schemaName = sname, formulaExpression = expr} + pure FormulaSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc, formulaExpression = expr} "relation" -> \o -> do cfg <- o .: "relation" dsId <- cfg .: "data_source_id" + dbId <- cfg .:? "database_id" relType <- Aeson.parseJSON (Object cfg) - pure RelationSchema {schemaId = sid, schemaName = sname, relationDataSourceId = dsId, relationType = relType} + pure RelationSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc, relationDataSourceId = dsId, relationDatabaseId = dbId, relationType = relType} "rollup" -> \o -> do cfg <- o .: "rollup" fn <- cfg .: "function" @@ -448,38 +486,42 @@ RollupSchema { schemaId = sid, schemaName = sname, + schemaDescription = sdesc, rollupFunction = fn, rollupRelationPropertyName = relPropName, rollupRelationPropertyId = relPropId, rollupPropertyName = propName, rollupPropertyId = propId } - "created_time" -> \_ -> pure CreatedTimeSchema {schemaId = sid, schemaName = sname} - "created_by" -> \_ -> pure CreatedBySchema {schemaId = sid, schemaName = sname} - "last_edited_time" -> \_ -> pure LastEditedTimeSchema {schemaId = sid, schemaName = sname} - "last_edited_by" -> \_ -> pure LastEditedBySchema {schemaId = sid, schemaName = sname} + "created_time" -> \_ -> pure CreatedTimeSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} + "created_by" -> \_ -> pure CreatedBySchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} + "last_edited_time" -> \_ -> pure LastEditedTimeSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} + "last_edited_by" -> \_ -> pure LastEditedBySchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} "status" -> \o -> do cfg <- o .: "status" opts <- cfg .: "options" - grps <- cfg .: "groups" - pure StatusSchema {schemaId = sid, schemaName = sname, statusOptions = opts, statusGroups = grps} + grps <- cfg .:? "groups" .!= mempty + pure StatusSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc, statusOptions = opts, statusGroups = grps} "unique_id" -> \o -> do cfg <- o .: "unique_id" prefix <- cfg .:? "prefix" - pure UniqueIdSchema {schemaId = sid, schemaName = sname, uniqueIdPrefix = prefix} - "place" -> \_ -> pure PlaceSchema {schemaId = sid, schemaName = sname} - "button" -> \_ -> pure ButtonSchema {schemaId = sid, schemaName = sname} - "verification" -> \_ -> pure VerificationSchema {schemaId = sid, schemaName = sname} - other -> \_ -> fail $ "Unknown property type: " <> unpack other + pure UniqueIdSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc, uniqueIdPrefix = prefix} + "place" -> \_ -> pure PlaceSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} + "button" -> \_ -> pure ButtonSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} + "verification" -> \_ -> pure VerificationSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} + "location" -> \_ -> pure LocationSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} + "last_visited_time" -> \_ -> pure LastVisitedTimeSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc} + other -> \o -> do + cfg <- o .:? Key.fromText other .!= object [] + pure UnknownSchema {schemaId = sid, schemaName = sname, schemaDescription = sdesc, schemaType = other, schemaConfig = cfg} instance ToJSON PropertySchema where toJSON schema = let (sid, sname, typeName, typeConfig) = schemaFields schema in object $ - [ "id" .= sid, - "name" .= sname, - "type" .= typeName - ] + (if Text.null sid then [] else ["id" .= sid]) + <> ["name" .= sname, "type" .= typeName] + <> maybe [] (\d -> ["description" .= d]) (schemaDescription schema) <> [typeName .= typeConfig] schemaFields :: PropertySchema -> (Text, Text, Aeson.Key, Value) @@ -498,19 +540,11 @@ PhoneNumberSchema {..} -> (schemaId, schemaName, "phone_number", object []) FormulaSchema {..} -> (schemaId, schemaName, "formula", object ["expression" .= formulaExpression]) RelationSchema {..} -> - let relObj = case relationType of - SingleProperty -> - object - [ "data_source_id" .= relationDataSourceId, - "type" .= ("single_property" :: Text), - "single_property" .= object [] - ] - DualProperty {..} -> - object - [ "data_source_id" .= relationDataSourceId, - "type" .= ("dual_property" :: Text), - "dual_property" .= object ["synced_property_id" .= syncedPropertyId, "synced_property_name" .= syncedPropertyName] - ] + let relObj = + object $ + maybe [] (\v -> ["database_id" .= v]) relationDatabaseId + <> ["data_source_id" .= relationDataSourceId] + <> relationTypeFields relationType in (schemaId, schemaName, "relation", relObj) RollupSchema {..} -> ( schemaId, @@ -527,7 +561,12 @@ CreatedBySchema {..} -> (schemaId, schemaName, "created_by", object []) LastEditedTimeSchema {..} -> (schemaId, schemaName, "last_edited_time", object []) LastEditedBySchema {..} -> (schemaId, schemaName, "last_edited_by", object []) - StatusSchema {..} -> (schemaId, schemaName, "status", object ["options" .= statusOptions, "groups" .= statusGroups]) + StatusSchema {..} -> + ( schemaId, + schemaName, + "status", + object (["options" .= statusOptions] <> (if Vector.null statusGroups then [] else ["groups" .= statusGroups])) + ) UniqueIdSchema {..} -> ( schemaId, schemaName, @@ -537,3 +576,60 @@ PlaceSchema {..} -> (schemaId, schemaName, "place", object []) ButtonSchema {..} -> (schemaId, schemaName, "button", object []) VerificationSchema {..} -> (schemaId, schemaName, "verification", object []) + LocationSchema {..} -> (schemaId, schemaName, "location", object []) + LastVisitedTimeSchema {..} -> (schemaId, schemaName, "last_visited_time", object []) + UnknownSchema {..} -> (schemaId, schemaName, Key.fromText schemaType, schemaConfig) + +-- | Which existing option an option update addresses. +data OptionTarget + = -- | @{"name": ...}@: match (or create) by name. + OptionNamed Text + | -- | @{"id": ..., "name"?: ...}@: match by id, optionally renaming. + OptionWithId Text (Maybe Text) + deriving stock (Eq, Show, Generic) + +-- | One entry of a select, multi-select or status @options@ list in a data source update. +data OptionUpdate = OptionUpdate + { target :: OptionTarget, + color :: Maybe SelectColor, + description :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +instance ToJSON OptionUpdate where + toJSON OptionUpdate {..} = + object $ + ( case target of + OptionNamed n -> ["name" .= n] + OptionWithId i mn -> ["id" .= i] <> maybe [] (\n -> ["name" .= n]) mn + ) + <> maybe [] (\c -> ["color" .= c]) color + <> maybe [] (\d -> ["description" .= d]) description + +-- | One entry of @UpdateDataSource.properties@. +data PropertyUpdate + = -- | @null@: remove the property. + RemoveProperty + | -- | @{"name": ...}@: rename only. + RenameProperty Text + | -- | A full property configuration. + SetPropertySchema PropertySchema + | -- | @{"name"?:..., "select": {"options": [...]}}@ + UpdateSelectOptions {newName :: Maybe Text, optionUpdates :: Vector OptionUpdate} + | -- | @{"name"?:..., "multi_select": {"options": [...]}}@ + UpdateMultiSelectOptions {newName :: Maybe Text, optionUpdates :: Vector OptionUpdate} + | -- | @{"name"?:..., "status": {"options": [...]}}@ + UpdateStatusOptions {newName :: Maybe Text, optionUpdates :: Vector OptionUpdate} + deriving stock (Eq, Show, Generic) + +instance ToJSON PropertyUpdate where + toJSON = \case + RemoveProperty -> Null + RenameProperty n -> object ["name" .= n] + SetPropertySchema s -> toJSON s + UpdateSelectOptions {..} -> opts "select" newName optionUpdates + UpdateMultiSelectOptions {..} -> opts "multi_select" newName optionUpdates + UpdateStatusOptions {..} -> opts "status" newName optionUpdates + where + opts :: Aeson.Key -> Maybe Text -> Vector OptionUpdate -> Value + opts key mName us = object $ maybe [] (\n -> ["name" .= n]) mName <> [key .= object ["options" .= us]] diff --git a/src/Notion/V1/PropertyValue.hs b/src/Notion/V1/PropertyValue.hs --- a/src/Notion/V1/PropertyValue.hs +++ b/src/Notion/V1/PropertyValue.hs @@ -22,6 +22,8 @@ RollupResult (..), UniqueIdResult (..), VerificationResult (..), + VerificationState (..), + Place (..), -- * Smart constructors titleValue, @@ -37,6 +39,10 @@ relationValue, statusValue, peopleValue, + peopleEntriesValue, + placeValue, + verifiedValue, + unverifiedValue, filesValue, fileUploadFilesValue, ) @@ -45,13 +51,14 @@ import Data.Aeson ((.:), (.:?), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as Key +import Data.Maybe (fromMaybe) import Data.Scientific (Scientific) import Data.Vector qualified as Vector import Notion.Prelude import Notion.V1.Common (ExternalFile (..), File, UUID (..)) import Notion.V1.Properties (RollupFunction) import Notion.V1.RichText (Date (..), RichText) -import Notion.V1.Users (UserReference (..)) +import Notion.V1.Users (PeopleEntry (..), UserReference (..), UserValue (..)) import Prelude hiding (id) -- | A typed property value from a Notion page. @@ -63,6 +70,10 @@ -- Read-only variants ('FormulaValue', 'RollupValue', 'UniqueIdValue', -- 'CreatedTimeValue', 'CreatedByValue', 'LastEditedTimeValue', 'LastEditedByValue', -- 'VerificationValue') only appear in API responses. +-- +-- A property value of a type this library does not know decodes as +-- 'UnknownPropertyValue'. Values nested in a rollup array carry no ID; their +-- first field is @\"\"@. data PropertyValue = TitleValue Text (Vector RichText) | RichTextValue Text (Vector RichText) @@ -70,7 +81,7 @@ | SelectValue Text (Maybe SelectOptionValue) | MultiSelectValue Text (Vector SelectOptionValue) | DateValue Text (Maybe Date) - | PeopleValue Text (Vector UserReference) + | PeopleValue Text (Vector PeopleEntry) | FilesValue Text (Vector FileValue) | CheckboxValue Text Bool | UrlValue Text (Maybe Text) @@ -85,15 +96,18 @@ | LastEditedByValue Text UserReference | StatusValue Text (Maybe SelectOptionValue) | UniqueIdValue Text UniqueIdResult - | PlaceValue Text (Maybe Value) + | PlaceValue Text (Maybe Place) | ButtonValue Text (Maybe Value) | VerificationValue Text (Maybe VerificationResult) + | -- | A property type this library does not model yet: the property ID, the + -- type name and the raw value under the type key ('Null' when absent). + UnknownPropertyValue Text Text Value deriving stock (Show) instance FromJSON PropertyValue where parseJSON = \case Object o -> do - pid <- o .: "id" + pid <- fromMaybe "" <$> o .:? "id" propType <- o .: "type" let key = Key.fromText propType case propType of @@ -121,7 +135,7 @@ "place" -> PlaceValue pid <$> o .:? key "button" -> ButtonValue pid <$> o .:? key "verification" -> VerificationValue pid <$> o .:? key - other -> fail $ "Unknown property value type: " <> unpack other + other -> UnknownPropertyValue pid other . fromMaybe Null <$> o .:? key _ -> fail "Expected object for PropertyValue" instance ToJSON PropertyValue where @@ -150,6 +164,7 @@ PlaceValue _ v -> Aeson.object ["place" .= v] ButtonValue _ v -> Aeson.object ["button" .= v] VerificationValue _ v -> Aeson.object ["verification" .= v] + UnknownPropertyValue _ t v -> Aeson.object [Key.fromText t .= v] -- --------------------------------------------------------------------------- -- Supporting types @@ -162,7 +177,8 @@ data SelectOptionValue = SelectOptionValue { id :: Maybe Text, name :: Text, - color :: Maybe Text + color :: Maybe Text, + description :: Maybe Text } deriving stock (Generic, Show) @@ -225,18 +241,22 @@ | FormulaNumberResult (Maybe Scientific) | FormulaBooleanResult (Maybe Bool) | FormulaDateResult (Maybe Date) + | FormulaUnsupportedResult + | -- | A result kind this library does not model yet; holds the raw object. + UnknownFormulaResult Value deriving stock (Show) instance FromJSON FormulaResult where parseJSON = \case Object o -> do - formulaType <- o .: "type" + formulaType :: Text <- o .: "type" case formulaType of "string" -> FormulaStringResult <$> o .:? "string" "number" -> FormulaNumberResult <$> o .:? "number" "boolean" -> FormulaBooleanResult <$> o .:? "boolean" "date" -> FormulaDateResult <$> o .:? "date" - other -> fail $ "Unknown formula result type: " <> unpack other + "unsupported" -> pure FormulaUnsupportedResult + _ -> pure (UnknownFormulaResult (Object o)) _ -> fail "Expected object for FormulaResult" instance ToJSON FormulaResult where @@ -245,28 +265,37 @@ FormulaNumberResult v -> Aeson.object ["type" .= ("number" :: Text), "number" .= v] FormulaBooleanResult v -> Aeson.object ["type" .= ("boolean" :: Text), "boolean" .= v] FormulaDateResult v -> Aeson.object ["type" .= ("date" :: Text), "date" .= v] + FormulaUnsupportedResult -> Aeson.object ["type" .= ("unsupported" :: Text), "unsupported" .= Aeson.object []] + UnknownFormulaResult v -> v -- | The result of a rollup property (read-only). data RollupResult = RollupNumberResult (Maybe Scientific) RollupFunction | RollupDateResult (Maybe Date) RollupFunction - | RollupArrayResult (Vector Value) RollupFunction + | -- | The rolled-up property values. They carry no property ID. + RollupArrayResult (Vector PropertyValue) RollupFunction | RollupIncompleteResult RollupFunction | RollupUnsupportedResult RollupFunction + | -- | A rollup result type this library does not model yet: the type name + -- and the raw rollup object. + RollupUnknownResult Text Value deriving stock (Show) instance FromJSON RollupResult where parseJSON = \case Object o -> do rollupType <- o .: "type" - fn <- o .: "function" case rollupType of - "number" -> RollupNumberResult <$> o .:? "number" <*> pure fn - "date" -> RollupDateResult <$> o .:? "date" <*> pure fn - "array" -> RollupArrayResult <$> o .: "array" <*> pure fn - "incomplete" -> pure $ RollupIncompleteResult fn - "unsupported" -> pure $ RollupUnsupportedResult fn - other -> fail $ "Unknown rollup result type: " <> unpack other + "number" -> RollupNumberResult <$> o .:? "number" <*> o .: "function" + "date" -> RollupDateResult <$> o .:? "date" <*> o .: "function" + "array" -> do + raw :: Vector Value <- o .: "array" + -- The paginated property-item summary sends empty objects here. + values <- traverse parseJSON (Vector.filter (/= Aeson.object []) raw) + RollupArrayResult values <$> o .: "function" + "incomplete" -> RollupIncompleteResult <$> o .: "function" + "unsupported" -> RollupUnsupportedResult <$> o .: "function" + other -> pure (RollupUnknownResult other (Object o)) _ -> fail "Expected object for RollupResult" instance ToJSON RollupResult where @@ -276,10 +305,11 @@ RollupArrayResult v fn -> Aeson.object ["type" .= ("array" :: Text), "array" .= v, "function" .= fn] RollupIncompleteResult fn -> Aeson.object ["type" .= ("incomplete" :: Text), "function" .= fn] RollupUnsupportedResult fn -> Aeson.object ["type" .= ("unsupported" :: Text), "function" .= fn] + RollupUnknownResult _ v -> v -- | Unique ID property value (read-only). data UniqueIdResult = UniqueIdResult - { number :: Natural, + { number :: Maybe Natural, prefix :: Maybe Text } deriving stock (Generic, Show) @@ -290,10 +320,11 @@ instance ToJSON UniqueIdResult where toJSON = genericToJSON aesonOptions --- | Verification property value (read-only). +-- | Verification property value. Build request values with 'verifiedValue' +-- and 'unverifiedValue'. data VerificationResult = VerificationResult - { state :: Text, - verifiedBy :: Maybe UserReference, + { state :: VerificationState, + verifiedBy :: Maybe UserValue, date :: Maybe Date } deriving stock (Generic, Show) @@ -301,7 +332,52 @@ instance FromJSON VerificationResult where parseJSON = genericParseJSON aesonOptions +-- | Always writes @state@; @date@ and @verified_by@ only when present. instance ToJSON VerificationResult where + toJSON VerificationResult {..} = + Aeson.object $ + ["state" .= state] + <> maybe [] (\d -> ["date" .= d]) date + <> maybe [] (\u -> ["verified_by" .= u]) verifiedBy + +-- | State of a verification property. +data VerificationState + = Verified + | Expired + | Unverified + | -- | A state this library does not know yet; holds the raw string. + UnknownVerificationState Text + deriving stock (Eq, Generic, Show) + +instance FromJSON VerificationState where + parseJSON = Aeson.withText "VerificationState" $ \case + "verified" -> pure Verified + "expired" -> pure Expired + "unverified" -> pure Unverified + other -> pure (UnknownVerificationState other) + +instance ToJSON VerificationState where + toJSON = \case + Verified -> String "verified" + Expired -> String "expired" + Unverified -> String "unverified" + UnknownVerificationState t -> String t + +-- | A place property value (a location with optional name and address). +data Place = Place + { lat :: Double, + lon :: Double, + name :: Maybe Text, + address :: Maybe Text, + awsPlaceId :: Maybe Text, + googlePlaceId :: Maybe Text + } + deriving stock (Eq, Generic, Show) + +instance FromJSON Place where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON Place where toJSON = genericToJSON aesonOptions -- --------------------------------------------------------------------------- @@ -322,11 +398,11 @@ -- | Create a select property value by option name. selectValue :: Text -> PropertyValue -selectValue name = SelectValue "" (Just (SelectOptionValue Nothing name Nothing)) +selectValue name = SelectValue "" (Just (SelectOptionValue Nothing name Nothing Nothing)) -- | Create a multi-select property value from a list of option names. multiSelectValue :: [Text] -> PropertyValue -multiSelectValue names = MultiSelectValue "" (Vector.fromList (map (\n -> SelectOptionValue Nothing n Nothing) names)) +multiSelectValue names = MultiSelectValue "" (Vector.fromList (map (\n -> SelectOptionValue Nothing n Nothing Nothing) names)) -- | Create a date property value. dateValue :: Text -> Maybe Text -> PropertyValue @@ -354,11 +430,28 @@ -- | Create a status property value by option name. statusValue :: Text -> PropertyValue -statusValue name = StatusValue "" (Just (SelectOptionValue Nothing name Nothing)) +statusValue name = StatusValue "" (Just (SelectOptionValue Nothing name Nothing Nothing)) -- | Create a people property value from a list of user IDs. peopleValue :: [UUID] -> PropertyValue -peopleValue ids = PeopleValue "" (Vector.fromList (map (\i -> UserReference i "user") ids)) +peopleValue ids = PeopleValue "" (Vector.fromList (map (PersonEntry . PartialUser) ids)) + +-- | Create a people property value from users and groups. +peopleEntriesValue :: [PeopleEntry] -> PropertyValue +peopleEntriesValue = PeopleValue "" . Vector.fromList + +-- | Create a place property value from a latitude and longitude. +placeValue :: Double -> Double -> PropertyValue +placeValue latitude longitude = + PlaceValue "" (Just (Place latitude longitude Nothing Nothing Nothing Nothing)) + +-- | Mark a verification property as verified, optionally until a date. +verifiedValue :: Maybe Date -> PropertyValue +verifiedValue d = VerificationValue "" (Just (VerificationResult Verified Nothing d)) + +-- | Mark a verification property as unverified. +unverifiedValue :: PropertyValue +unverifiedValue = VerificationValue "" (Just (VerificationResult Unverified Nothing Nothing)) -- | Create a files property value from a list of external URLs. filesValue :: [Text] -> PropertyValue diff --git a/src/Notion/V1/Retry.hs b/src/Notion/V1/Retry.hs new file mode 100644 --- /dev/null +++ b/src/Notion/V1/Retry.hs @@ -0,0 +1,99 @@ +-- | Retry policy for Notion API requests, ported from the official JS SDK. +-- +-- Everything here is pure; 'Notion.V1.Client.withRetries' runs the loop. +module Notion.V1.Retry + ( -- * Options + RetryOptions (..), + defaultRetryOptions, + noRetries, + + -- * Policy + canRetry, + parseRetryAfter, + retryDelay, + validateRequestPath, + ) +where + +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BS8 +import Data.Char (isDigit, isSpace) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime) +import Data.Time.Format (defaultTimeLocale, parseTimeM) +import Network.HTTP.Types (Method, methodDelete, methodGet, urlDecode) +import Notion.Prelude hiding (ByteString) +import Notion.V1.Error (APIErrorCode (..), InvalidPathParameterError (..)) + +-- | How failed requests are retried. +data RetryOptions = RetryOptions + { -- | Maximum number of retries after the first attempt; 0 disables retries. + maxRetries :: Natural, + -- | Base of the exponential back-off. + initialRetryDelay :: NominalDiffTime, + -- | Upper bound for both @retry-after@ and back-off delays. + maxRetryDelay :: NominalDiffTime + } + deriving stock (Eq, Show) + +-- | Two retries, starting at one second and capped at one minute (the JS SDK defaults). +defaultRetryOptions :: RetryOptions +defaultRetryOptions = RetryOptions {maxRetries = 2, initialRetryDelay = 1, maxRetryDelay = 60} + +-- | Never retry. +noRetries :: RetryOptions +noRetries = RetryOptions {maxRetries = 0, initialRetryDelay = 0, maxRetryDelay = 0} + +-- | Whether a failed request may be retried. @rate_limited@ and +-- @service_overload@ are retried for any method; @internal_server_error@ and +-- @service_unavailable@ only for @GET@ and @DELETE@. +canRetry :: Method -> APIErrorCode -> Bool +canRetry method = \case + RateLimited -> True + ServiceOverload -> True + InternalServerError -> idempotent + ServiceUnavailable -> idempotent + _ -> False + where + idempotent = method == methodGet || method == methodDelete + +-- | Parse a @retry-after@ header value at time @now@. +-- +-- Leading ASCII digits (after skipping spaces) are delta-seconds, like +-- JavaScript's @parseInt@ (@"1.5"@ is one second). Otherwise the value may be +-- an HTTP date such as @Wed, 21 Oct 2015 07:28:00 GMT@; a date in the past +-- gives 0. Anything else gives 'Nothing'. +parseRetryAfter :: UTCTime -> BS.ByteString -> Maybe NominalDiffTime +parseRetryAfter now raw + | not (BS.null digits) = fromInteger <$> readInteger digits + | otherwise = do + date <- parseTimeM False defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" (BS8.unpack trimmed) + pure (max 0 (diffUTCTime date now)) + where + trimmed = BS8.dropWhileEnd isSpace (BS8.dropWhile isSpace raw) + digits = BS8.takeWhile isDigit trimmed + readInteger bs = case BS8.readInteger bs of + Just (n, rest) | BS.null rest -> Just n + _ -> Nothing + +-- | Delay before retry number @attempt + 1@ (@attempt@ counts from 0). +-- A @retry-after@ value wins, capped at 'maxRetryDelay'. Otherwise exponential +-- back-off with @jitter@ in [0, 1): @base * jitter + base / 2@, where +-- @base = initialRetryDelay * 2 ^ attempt@. +retryDelay :: RetryOptions -> Natural -> Double -> Maybe NominalDiffTime -> NominalDiffTime +retryDelay RetryOptions {initialRetryDelay, maxRetryDelay} attempt jitter = \case + Just retryAfter -> min retryAfter maxRetryDelay + Nothing -> + let base = initialRetryDelay * 2 ^ attempt + in min (base * realToFrac jitter + base / 2) maxRetryDelay + +-- | Reject request paths containing a path traversal sequence (@..@), plain or +-- percent-encoded. +validateRequestPath :: Text -> Either InvalidPathParameterError () +validateRequestPath path + | ".." `Text.isInfixOf` path = Left (InvalidPathParameterError path) + | "%2e" `Text.isInfixOf` Text.toLower path, + ".." `BS.isInfixOf` urlDecode False (Text.encodeUtf8 path) = + Left (InvalidPathParameterError path) + | otherwise = Right () diff --git a/src/Notion/V1/RichText.hs b/src/Notion/V1/RichText.hs --- a/src/Notion/V1/RichText.hs +++ b/src/Notion/V1/RichText.hs @@ -5,6 +5,7 @@ RichTextContent (..), TextContent (..), MentionContent (..), + LinkMentionValue (..), EquationContent (..), Annotations (..), defaultAnnotations, @@ -16,7 +17,8 @@ import Data.Aeson (object, (.:), (.:?), (.=)) import Notion.Prelude -import Notion.V1.Common (Color (..), UUID) +import Notion.V1.Common (Color (..), CustomEmojiRef, UUID) +import Notion.V1.Users (UserValue) -- | Rich text object in Notion data RichText = RichText @@ -75,26 +77,32 @@ -- the corresponding field name. For example: -- -- @ --- { "type": "user", "user": { "id": "..." } } +-- { "type": "user", "user": { "object": "user", "id": "..." } } -- @ data MentionContent - = UserMention {user :: UUID} + = -- | A user mention; Notion sends either a reference or the full user. + UserMention {user :: UserValue} | PageMention {page :: UUID} | DatabaseMention {database :: UUID} | DateMention {date :: Date} | LinkPreviewMention {url :: Text} | TemplateMentionDate {templateMentionDate :: Text} | TemplateMentionUser {templateMentionUser :: Text} + | -- | A link with rich preview metadata. + LinkMention {linkMention :: LinkMentionValue} + | -- | A workspace custom emoji. + CustomEmojiMention {customEmoji :: CustomEmojiRef} + | -- | A mention kind this library does not model yet; holds the whole mention + -- object. + UnknownMention Value deriving stock (Eq, Generic, Show) instance FromJSON MentionContent where - parseJSON = \case + parseJSON v = case v of Object o -> do - mentionType <- o .: "type" + mentionType :: Text <- o .: "type" case mentionType of - "user" -> do - userObj <- o .: "user" - UserMention <$> parseIdField userObj + "user" -> UserMention <$> o .: "user" "page" -> do pageObj <- o .: "page" PageMention <$> parseIdField pageObj @@ -107,12 +115,14 @@ LinkPreviewMention <$> parseUrlField lpObj "template_mention" -> do tmObj <- o .: "template_mention" - tmType <- tmObj .: "type" + tmType :: Text <- tmObj .: "type" case tmType of "template_mention_date" -> TemplateMentionDate <$> tmObj .: "template_mention_date" "template_mention_user" -> TemplateMentionUser <$> tmObj .: "template_mention_user" - other2 -> fail $ "Unknown template_mention type: " <> unpack other2 - other -> fail $ "Unknown mention type: " <> unpack other + _ -> pure (UnknownMention v) + "link_mention" -> LinkMention <$> o .: "link_mention" + "custom_emoji" -> CustomEmojiMention <$> o .: "custom_emoji" + _ -> pure (UnknownMention v) _ -> fail "Expected object for MentionContent" where parseIdField = \case @@ -124,8 +134,8 @@ instance ToJSON MentionContent where toJSON = \case - UserMention uid -> - object ["type" .= ("user" :: Text), "user" .= object ["id" .= uid]] + UserMention u -> + object ["type" .= ("user" :: Text), "user" .= u] PageMention pid -> object ["type" .= ("page" :: Text), "page" .= object ["id" .= pid]] DatabaseMention dbid -> @@ -144,6 +154,33 @@ [ "type" .= ("template_mention" :: Text), "template_mention" .= object ["type" .= ("template_mention_user" :: Text), "template_mention_user" .= u] ] + LinkMention lm -> + object ["type" .= ("link_mention" :: Text), "link_mention" .= lm] + CustomEmojiMention ce -> + object ["type" .= ("custom_emoji" :: Text), "custom_emoji" .= ce] + UnknownMention raw -> raw + +-- | Rich link preview metadata carried by a @link_mention@. +data LinkMentionValue = LinkMentionValue + { href :: Text, + title :: Maybe Text, + description :: Maybe Text, + linkAuthor :: Maybe Text, + linkProvider :: Maybe Text, + thumbnailUrl :: Maybe Text, + iconUrl :: Maybe Text, + iframeUrl :: Maybe Text, + height :: Maybe Double, + padding :: Maybe Double, + paddingTop :: Maybe Double + } + deriving stock (Eq, Generic, Show) + +instance FromJSON LinkMentionValue where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON LinkMentionValue where + toJSON = genericToJSON aesonOptions -- | Equation content newtype EquationContent = EquationContent diff --git a/src/Notion/V1/Search.hs b/src/Notion/V1/Search.hs --- a/src/Notion/V1/Search.hs +++ b/src/Notion/V1/Search.hs @@ -8,9 +8,13 @@ SearchFilter (..), SearchObjectType (..), - -- * Response parsing - SearchResult (..), - parseSearchResults, + -- * Results + SearchResult, + PageOrDataSource (..), + PartialPageObject (..), + PartialDataSourceObject (..), + pageResults, + dataSourceResults, -- * Convenience constructors pageFilter, @@ -21,12 +25,11 @@ ) where +import Data.Aeson ((.=)) import Data.Aeson qualified as Aeson -import Data.Vector qualified as Vector import Notion.Prelude -import Notion.V1.DataSources (DataSourceObject) -import Notion.V1.ListOf (ListOf (..)) -import Notion.V1.Pages (PageObject) +import Notion.V1.DataSources (PageOrDataSource (..), PartialDataSourceObject (..), PartialPageObject (..), dataSourceResults, pageResults) +import Notion.V1.ListOf (ListOf) -- | Search request data SearchRequest = SearchRequest @@ -62,14 +65,16 @@ toJSON = genericToJSON aesonOptions -- | Search sort -data SearchSort = SearchSort - { direction :: SearchSortDirection, - timestamp :: Text - } +data SearchSort + = -- | @{"timestamp":"last_edited_time","direction":...}@ + SearchByLastEditedTime SearchSortDirection + | -- | @{"property":"relevance"}@ + SearchByRelevance deriving stock (Generic, Show) instance ToJSON SearchSort where - toJSON = genericToJSON aesonOptions + toJSON (SearchByLastEditedTime dir) = Aeson.object ["timestamp" .= ("last_edited_time" :: Text), "direction" .= dir] + toJSON SearchByRelevance = Aeson.object ["property" .= ("relevance" :: Text)] -- | Object types supported by the search filter. -- In API version 2025-09-03, the search API filters by @page@ or @data_source@. @@ -89,53 +94,31 @@ other -> fail $ "Unknown search object type: " <> unpack other -- | Search filter -data SearchFilter = SearchFilter - { value :: SearchObjectType, - property :: Text - } +data SearchFilter + = -- | @{"property":"object","value":...,"in_trash"?:...}@ + SearchObjectFilter SearchObjectType (Maybe Bool) + | -- | @{"in_trash":...}@ + SearchInTrashFilter Bool deriving stock (Generic, Show) instance ToJSON SearchFilter where - toJSON = genericToJSON aesonOptions + toJSON (SearchObjectFilter v mTrash) = + Aeson.object $ ["property" .= ("object" :: Text), "value" .= v] <> maybe [] (\t -> ["in_trash" .= t]) mTrash + toJSON (SearchInTrashFilter t) = Aeson.object ["in_trash" .= t] -- | Create a filter to search only for pages pageFilter :: SearchFilter -pageFilter = SearchFilter {value = SearchPage, property = "object"} +pageFilter = SearchObjectFilter SearchPage Nothing -- | Create a filter to search only for data sources dataSourceFilter :: SearchFilter -dataSourceFilter = SearchFilter {value = SearchDataSource, property = "object"} +dataSourceFilter = SearchObjectFilter SearchDataSource Nothing +-- | A search result: the same union as a data source query result. +type SearchResult = PageOrDataSource + -- | Servant API type API = "search" :> ReqBody '[JSON] SearchRequest - :> Post '[JSON] (ListOf Aeson.Value) - --- * Response parsing - --- | A search result can be either a page or a data source -data SearchResult - = PageResult PageObject - | DataSourceResult DataSourceObject - deriving stock (Show) - -instance FromJSON SearchResult where - parseJSON v = do - obj <- Aeson.parseJSON v - objectType <- obj Aeson..: "object" - case objectType of - "page" -> PageResult <$> Aeson.parseJSON v - "data_source" -> DataSourceResult <$> Aeson.parseJSON v - other -> fail $ "Unknown object type in search result: " <> other - --- | Parse raw search results into typed 'SearchResult' values. --- Results that fail to parse are silently dropped. -parseSearchResults :: ListOf Aeson.Value -> Vector SearchResult -parseSearchResults listOf = - Vector.mapMaybe parseOne (results listOf) - where - parseOne :: Aeson.Value -> Maybe SearchResult - parseOne v = case Aeson.fromJSON v of - Aeson.Success r -> Just r - Aeson.Error _ -> Nothing + :> Post '[JSON] (ListOf PageOrDataSource) diff --git a/src/Notion/V1/Users.hs b/src/Notion/V1/Users.hs --- a/src/Notion/V1/Users.hs +++ b/src/Notion/V1/Users.hs @@ -8,14 +8,25 @@ UserType (..), PersonUser (..), BotUser (..), + UserOwner (..), WorkspaceLimits (..), UserReference (..), + -- * Users inside values + UserValue (..), + userValueId, + GroupObject (..), + PeopleEntry (..), + -- * Servant API, ) where +import Control.Applicative ((<|>)) +import Data.Aeson ((.:?), (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap import Data.Aeson.Types ((.:)) import Notion.Prelude import Notion.V1.Common (ObjectType (..), UUID) @@ -34,7 +45,7 @@ bot :: Maybe BotUser, object :: ObjectType } - deriving stock (Generic, Show) + deriving stock (Eq, Generic, Show) instance FromJSON UserObject where parseJSON = genericParseJSON aesonOptions {fieldLabelModifier = \s -> if s == "type_" then "type" else labelModifier s} @@ -43,16 +54,16 @@ data UserType = Person | Bot - deriving stock (Generic, Show) + deriving stock (Eq, Generic, Show) instance FromJSON UserType where parseJSON = genericParseJSON aesonOptions -- | Person user newtype PersonUser = PersonUser - { email :: Text + { email :: Maybe Text } - deriving stock (Generic, Show) + deriving stock (Eq, Generic, Show) instance FromJSON PersonUser where parseJSON = genericParseJSON aesonOptions @@ -61,7 +72,7 @@ data WorkspaceLimits = WorkspaceLimits { maxFileUploadSizeInBytes :: Maybe Natural } - deriving stock (Generic, Show) + deriving stock (Eq, Generic, Show) instance FromJSON WorkspaceLimits where parseJSON = genericParseJSON aesonOptions @@ -73,7 +84,7 @@ workspaceId :: Maybe Text, workspaceLimits :: Maybe WorkspaceLimits } - deriving stock (Generic, Show) + deriving stock (Eq, Generic, Show) instance FromJSON BotUser where parseJSON = genericParseJSON aesonOptions @@ -82,16 +93,21 @@ data UserOwner = UserOwner {type_ :: Text, user :: UserID} | WorkspaceOwner {type_ :: Text, workspace :: Bool} - deriving stock (Generic, Show) + | -- | Owner kind not modelled yet; holds the raw owner object. + UnknownOwner {type_ :: Text, ownerValue :: Value} + deriving stock (Eq, Generic, Show) instance FromJSON UserOwner where parseJSON = \case Object o -> do - ownerType <- o .: "type" + ownerType :: Text <- o .: "type" case ownerType of - "user" -> UserOwner ownerType <$> (o .: "user") + "user" -> do + -- Notion sends the owning user object, not a bare ID. + userObj <- o .: "user" + UserOwner ownerType <$> userObj .: "id" "workspace" -> WorkspaceOwner ownerType <$> (o .: "workspace") - _ -> fail $ "Unknown owner type: " <> unpack ownerType + _ -> pure (UnknownOwner ownerType (Object o)) _ -> fail "Expected object for UserOwner" -- | Simple user reference objects that appear in created_by and last_edited_by fields @@ -108,6 +124,61 @@ instance ToJSON UserReference where toJSON = genericToJSON aesonOptions + +-- | A user as it appears inside mentions, people values and verification +-- values: either just a reference (@{"object":"user","id":...}@) or a full +-- user object (one with a @type@ key). +data UserValue + = PartialUser UserID + | FullUser UserObject + deriving stock (Eq, Generic, Show) + +-- | The ID of a partial or full user. +userValueId :: UserValue -> UserID +userValueId (PartialUser i) = i +userValueId (FullUser UserObject {id = i}) = i + +-- | A full user object that this library cannot decode (for example a new +-- user type) is kept as a 'PartialUser' rather than failing the response. +instance FromJSON UserValue where + parseJSON = \case + Object o + | KeyMap.member "type" o -> (FullUser <$> parseJSON (Object o)) <|> (PartialUser <$> o .: "id") + | otherwise -> PartialUser <$> o .: "id" + _ -> fail "Expected object for UserValue" + +-- | Encodes the request shape only (@object@ and @id@); full user details are +-- not sent back to the API. +instance ToJSON UserValue where + toJSON u = Aeson.object ["object" .= ("user" :: Text), "id" .= userValueId u] + +-- | A group (team) that can appear in a people property. +data GroupObject = GroupObject + { id :: UUID, + name :: Maybe Text + } + deriving stock (Eq, Generic, Show) + +-- | One entry of a people property: a user or a group. +data PeopleEntry + = PersonEntry UserValue + | GroupEntry GroupObject + deriving stock (Eq, Generic, Show) + +instance FromJSON PeopleEntry where + parseJSON = \case + Object o -> do + objectType :: Maybe Text <- o .:? "object" + case objectType of + Just "group" -> GroupEntry <$> (GroupObject <$> o .: "id" <*> o .:? "name") + _ -> PersonEntry <$> parseJSON (Object o) + _ -> fail "Expected object for PeopleEntry" + +instance ToJSON PeopleEntry where + toJSON = \case + PersonEntry u -> toJSON u + GroupEntry (GroupObject gid gname) -> + Aeson.object (["object" .= ("group" :: Text), "id" .= gid] <> maybe [] (\n -> ["name" .= n]) gname) -- | Servant API type API = diff --git a/src/Notion/V1/ViewConfig.hs b/src/Notion/V1/ViewConfig.hs new file mode 100644 --- /dev/null +++ b/src/Notion/V1/ViewConfig.hs @@ -0,0 +1,1706 @@ +-- | Typed view configuration: the layout settings of table, board, calendar, +-- timeline, gallery, list, map, form, chart and dashboard views. +-- +-- One set of types serves both responses and requests. Fields Notion accepts +-- as @null@ (to clear a setting) are 'Clearable'. Response-only convenience +-- fields such as @property_name@ are decoded but dropped when encoding, so a +-- retrieved configuration can be changed and sent back as is. Every sum type +-- and enum keeps unrecognised values as raw JSON or text. +module Notion.V1.ViewConfig + ( -- * View configuration + ViewConfig (..), + TableViewConfig (..), + BoardViewConfig (..), + CalendarViewConfig (..), + TimelineViewConfig (..), + GalleryViewConfig (..), + ListViewConfig (..), + TimelinePreference (..), + TimelineArrowsBy (..), + MapViewConfig (..), + FormViewConfig (..), + ChartViewConfig (..), + ChartAggregation (..), + ChartReferenceLine (..), + DashboardViewConfig (..), + DashboardRow (..), + DashboardWidget (..), + + -- * Shared pieces + ViewPropertyConfig (..), + SubtaskConfig (..), + CoverConfig (..), + + -- * Group by + GroupByConfig (..), + SelectGroupByConfig (..), + StatusGroupByConfig (..), + PersonGroupByConfig (..), + RelationGroupByConfig (..), + DateGroupByConfig (..), + TextGroupByConfig (..), + NumberGroupByConfig (..), + CheckboxGroupByConfig (..), + FormulaGroupByConfig (..), + FormulaSubGroupBy (..), + FormulaDateSubGroupBy (..), + FormulaTextSubGroupBy (..), + FormulaNumberSubGroupBy (..), + FormulaCheckboxSubGroupBy (..), + + -- * Enumerations + GroupSort (..), + SelectGroupKind (..), + PersonGroupKind (..), + DateGroupKind (..), + TextGroupKind (..), + DateGranularity (..), + TextGroupMode (..), + StatusGroupMode (..), + StatusShowAs (..), + CardPropertyWidthMode (..), + DateFormat (..), + TimeFormat (..), + SubtaskDisplayMode (..), + SubtaskFilterScope (..), + CoverType (..), + CoverSize (..), + CoverAspect (..), + CardLayout (..), + CalendarRange (..), + TimelineZoomLevel (..), + ViewHeight (..), + SubmissionPermission (..), + ChartType (..), + ChartSort (..), + ChartColorTheme (..), + LegendPosition (..), + AxisLabels (..), + GridLines (..), + GroupStyle (..), + DonutLabels (..), + ChartAggregator (..), + ReferenceLineColor (..), + DashStyle (..), + ) +where + +import Control.Applicative ((<|>)) +import Data.Aeson ((.:), (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (Parser) +import Data.Maybe (fromMaybe) +import Data.Scientific (Scientific) +import Data.Tuple (swap) +import Notion.Prelude +import Notion.V1.Clearable (Clearable (..)) +import Notion.V1.Common (UUID) +import Prelude hiding (id) + +-- ===================================================================== +-- Helpers +-- ===================================================================== + +-- | Decode a string enum from a lookup table; unknown strings go to the fallback constructor. +parseEnum :: String -> [(Text, a)] -> (Text -> a) -> Value -> Parser a +parseEnum name table unknown = + Aeson.withText name $ \t -> pure (fromMaybe (unknown t) (lookup t table)) + +-- | Encode a known enum constructor via the same table (callers handle the unknown constructor). +enumToJSON :: (Eq a) => [(Text, a)] -> a -> Value +enumToJSON table a = maybe Null String (lookup a (map swap table)) + +-- | Add the @type@ discriminator to an encoded object. +withType :: Text -> Value -> Value +withType t = \case + Object o -> Object (KeyMap.insert "type" (String t) o) + other -> other + +-- | Remove response-only convenience keys before sending a configuration back to Notion. +dropKeys :: [Aeson.Key] -> Value -> Value +dropKeys ks = \case + Object o -> Object (foldr KeyMap.delete o ks) + other -> other + +-- ===================================================================== +-- Enumerations +-- ===================================================================== + +-- | How groups are ordered. Encoded as @{"type": ...}@. +data GroupSort + = GroupSortManual + | GroupSortAscending + | GroupSortDescending + | -- | A value this library does not know yet; holds the raw string. + UnknownGroupSort Text + deriving stock (Eq, Show, Generic) + +groupSortTable :: [(Text, GroupSort)] +groupSortTable = + [ ("manual", GroupSortManual), + ("ascending", GroupSortAscending), + ("descending", GroupSortDescending) + ] + +instance FromJSON GroupSort where + parseJSON = Aeson.withObject "GroupSort" $ \o -> + o .: "type" >>= parseEnum "GroupSort" groupSortTable UnknownGroupSort + +instance ToJSON GroupSort where + toJSON s = Aeson.object ["type" .= typeName] + where + typeName = case s of + UnknownGroupSort t -> String t + known -> enumToJSON groupSortTable known + +-- | Property type of a select group-by. +data SelectGroupKind + = SelectKind + | MultiSelectKind + | -- | A value this library does not know yet; holds the raw string. + UnknownSelectGroupKind Text + deriving stock (Eq, Show, Generic) + +selectGroupKindTable :: [(Text, SelectGroupKind)] +selectGroupKindTable = + [ ("select", SelectKind), + ("multi_select", MultiSelectKind) + ] + +instance FromJSON SelectGroupKind where + parseJSON = parseEnum "SelectGroupKind" selectGroupKindTable UnknownSelectGroupKind + +instance ToJSON SelectGroupKind where + toJSON = \case + UnknownSelectGroupKind t -> String t + known -> enumToJSON selectGroupKindTable known + +-- | Property type of a person group-by. +data PersonGroupKind + = PersonKind + | CreatedByKind + | LastEditedByKind + | -- | A value this library does not know yet; holds the raw string. + UnknownPersonGroupKind Text + deriving stock (Eq, Show, Generic) + +personGroupKindTable :: [(Text, PersonGroupKind)] +personGroupKindTable = + [ ("person", PersonKind), + ("created_by", CreatedByKind), + ("last_edited_by", LastEditedByKind) + ] + +instance FromJSON PersonGroupKind where + parseJSON = parseEnum "PersonGroupKind" personGroupKindTable UnknownPersonGroupKind + +instance ToJSON PersonGroupKind where + toJSON = \case + UnknownPersonGroupKind t -> String t + known -> enumToJSON personGroupKindTable known + +-- | Property type of a date group-by. +data DateGroupKind + = DateKind + | CreatedTimeKind + | LastEditedTimeKind + | -- | A value this library does not know yet; holds the raw string. + UnknownDateGroupKind Text + deriving stock (Eq, Show, Generic) + +dateGroupKindTable :: [(Text, DateGroupKind)] +dateGroupKindTable = + [ ("date", DateKind), + ("created_time", CreatedTimeKind), + ("last_edited_time", LastEditedTimeKind) + ] + +instance FromJSON DateGroupKind where + parseJSON = parseEnum "DateGroupKind" dateGroupKindTable UnknownDateGroupKind + +instance ToJSON DateGroupKind where + toJSON = \case + UnknownDateGroupKind t -> String t + known -> enumToJSON dateGroupKindTable known + +-- | Property type of a text group-by. +data TextGroupKind + = TextKind + | TitleKind + | UrlKind + | EmailKind + | PhoneNumberKind + | -- | A value this library does not know yet; holds the raw string. + UnknownTextGroupKind Text + deriving stock (Eq, Show, Generic) + +textGroupKindTable :: [(Text, TextGroupKind)] +textGroupKindTable = + [ ("text", TextKind), + ("title", TitleKind), + ("url", UrlKind), + ("email", EmailKind), + ("phone_number", PhoneNumberKind) + ] + +instance FromJSON TextGroupKind where + parseJSON = parseEnum "TextGroupKind" textGroupKindTable UnknownTextGroupKind + +instance ToJSON TextGroupKind where + toJSON = \case + UnknownTextGroupKind t -> String t + known -> enumToJSON textGroupKindTable known + +-- | Bucket size when grouping by a date. +data DateGranularity + = GranularityRelative + | GranularityDay + | GranularityWeek + | GranularityMonth + | GranularityYear + | -- | A value this library does not know yet; holds the raw string. + UnknownDateGranularity Text + deriving stock (Eq, Show, Generic) + +dateGranularityTable :: [(Text, DateGranularity)] +dateGranularityTable = + [ ("relative", GranularityRelative), + ("day", GranularityDay), + ("week", GranularityWeek), + ("month", GranularityMonth), + ("year", GranularityYear) + ] + +instance FromJSON DateGranularity where + parseJSON = parseEnum "DateGranularity" dateGranularityTable UnknownDateGranularity + +instance ToJSON DateGranularity where + toJSON = \case + UnknownDateGranularity t -> String t + known -> enumToJSON dateGranularityTable known + +-- | How text values are grouped. +data TextGroupMode + = GroupExact + | GroupAlphabetPrefix + | -- | A value this library does not know yet; holds the raw string. + UnknownTextGroupMode Text + deriving stock (Eq, Show, Generic) + +textGroupModeTable :: [(Text, TextGroupMode)] +textGroupModeTable = + [ ("exact", GroupExact), + ("alphabet_prefix", GroupAlphabetPrefix) + ] + +instance FromJSON TextGroupMode where + parseJSON = parseEnum "TextGroupMode" textGroupModeTable UnknownTextGroupMode + +instance ToJSON TextGroupMode where + toJSON = \case + UnknownTextGroupMode t -> String t + known -> enumToJSON textGroupModeTable known + +-- | Whether a status group-by uses status groups or individual options. +data StatusGroupMode + = GroupByStatusGroup + | GroupByStatusOption + | -- | A value this library does not know yet; holds the raw string. + UnknownStatusGroupMode Text + deriving stock (Eq, Show, Generic) + +statusGroupModeTable :: [(Text, StatusGroupMode)] +statusGroupModeTable = + [ ("group", GroupByStatusGroup), + ("option", GroupByStatusOption) + ] + +instance FromJSON StatusGroupMode where + parseJSON = parseEnum "StatusGroupMode" statusGroupModeTable UnknownStatusGroupMode + +instance ToJSON StatusGroupMode where + toJSON = \case + UnknownStatusGroupMode t -> String t + known -> enumToJSON statusGroupModeTable known + +-- | How a status property is displayed. +data StatusShowAs + = ShowAsSelect + | ShowAsCheckbox + | -- | A value this library does not know yet; holds the raw string. + UnknownStatusShowAs Text + deriving stock (Eq, Show, Generic) + +statusShowAsTable :: [(Text, StatusShowAs)] +statusShowAsTable = + [ ("select", ShowAsSelect), + ("checkbox", ShowAsCheckbox) + ] + +instance FromJSON StatusShowAs where + parseJSON = parseEnum "StatusShowAs" statusShowAsTable UnknownStatusShowAs + +instance ToJSON StatusShowAs where + toJSON = \case + UnknownStatusShowAs t -> String t + known -> enumToJSON statusShowAsTable known + +-- | How a property is laid out on a card. +data CardPropertyWidthMode + = WidthFullLine + | WidthInline + | -- | A value this library does not know yet; holds the raw string. + UnknownCardPropertyWidthMode Text + deriving stock (Eq, Show, Generic) + +cardPropertyWidthModeTable :: [(Text, CardPropertyWidthMode)] +cardPropertyWidthModeTable = + [ ("full_line", WidthFullLine), + ("inline", WidthInline) + ] + +instance FromJSON CardPropertyWidthMode where + parseJSON = parseEnum "CardPropertyWidthMode" cardPropertyWidthModeTable UnknownCardPropertyWidthMode + +instance ToJSON CardPropertyWidthMode where + toJSON = \case + UnknownCardPropertyWidthMode t -> String t + known -> enumToJSON cardPropertyWidthModeTable known + +-- | Display format of a date property. +data DateFormat + = DateFormatFull + | DateFormatShort + | DateFormatMonthDayYear + | DateFormatDayMonthYear + | DateFormatYearMonthDay + | DateFormatRelative + | -- | A value this library does not know yet; holds the raw string. + UnknownDateFormat Text + deriving stock (Eq, Show, Generic) + +dateFormatTable :: [(Text, DateFormat)] +dateFormatTable = + [ ("full", DateFormatFull), + ("short", DateFormatShort), + ("month_day_year", DateFormatMonthDayYear), + ("day_month_year", DateFormatDayMonthYear), + ("year_month_day", DateFormatYearMonthDay), + ("relative", DateFormatRelative) + ] + +instance FromJSON DateFormat where + parseJSON = parseEnum "DateFormat" dateFormatTable UnknownDateFormat + +instance ToJSON DateFormat where + toJSON = \case + UnknownDateFormat t -> String t + known -> enumToJSON dateFormatTable known + +-- | Display format of the time part of a date property. +data TimeFormat + = TimeFormat12Hour + | TimeFormat24Hour + | TimeFormatHidden + | -- | A value this library does not know yet; holds the raw string. + UnknownTimeFormat Text + deriving stock (Eq, Show, Generic) + +timeFormatTable :: [(Text, TimeFormat)] +timeFormatTable = + [ ("12_hour", TimeFormat12Hour), + ("24_hour", TimeFormat24Hour), + ("hidden", TimeFormatHidden) + ] + +instance FromJSON TimeFormat where + parseJSON = parseEnum "TimeFormat" timeFormatTable UnknownTimeFormat + +instance ToJSON TimeFormat where + toJSON = \case + UnknownTimeFormat t -> String t + known -> enumToJSON timeFormatTable known + +-- | How sub-items are shown. +data SubtaskDisplayMode + = SubtasksShow + | SubtasksHidden + | SubtasksFlattened + | SubtasksDisabled + | -- | A value this library does not know yet; holds the raw string. + UnknownSubtaskDisplayMode Text + deriving stock (Eq, Show, Generic) + +subtaskDisplayModeTable :: [(Text, SubtaskDisplayMode)] +subtaskDisplayModeTable = + [ ("show", SubtasksShow), + ("hidden", SubtasksHidden), + ("flattened", SubtasksFlattened), + ("disabled", SubtasksDisabled) + ] + +instance FromJSON SubtaskDisplayMode where + parseJSON = parseEnum "SubtaskDisplayMode" subtaskDisplayModeTable UnknownSubtaskDisplayMode + +instance ToJSON SubtaskDisplayMode where + toJSON = \case + UnknownSubtaskDisplayMode t -> String t + known -> enumToJSON subtaskDisplayModeTable known + +-- | Which rows a filter applies to when sub-items are shown. +data SubtaskFilterScope + = ScopeParents + | ScopeParentsAndSubitems + | ScopeSubitems + | -- | A value this library does not know yet; holds the raw string. + UnknownSubtaskFilterScope Text + deriving stock (Eq, Show, Generic) + +subtaskFilterScopeTable :: [(Text, SubtaskFilterScope)] +subtaskFilterScopeTable = + [ ("parents", ScopeParents), + ("parents_and_subitems", ScopeParentsAndSubitems), + ("subitems", ScopeSubitems) + ] + +instance FromJSON SubtaskFilterScope where + parseJSON = parseEnum "SubtaskFilterScope" subtaskFilterScopeTable UnknownSubtaskFilterScope + +instance ToJSON SubtaskFilterScope where + toJSON = \case + UnknownSubtaskFilterScope t -> String t + known -> enumToJSON subtaskFilterScopeTable known + +-- | Source of a card cover image. @page_content_first@ appears only in responses. +data CoverType + = CoverPageCover + | CoverPageContent + | CoverPageContentFirst + | CoverProperty + | -- | A value this library does not know yet; holds the raw string. + UnknownCoverType Text + deriving stock (Eq, Show, Generic) + +coverTypeTable :: [(Text, CoverType)] +coverTypeTable = + [ ("page_cover", CoverPageCover), + ("page_content", CoverPageContent), + ("page_content_first", CoverPageContentFirst), + ("property", CoverProperty) + ] + +instance FromJSON CoverType where + parseJSON = parseEnum "CoverType" coverTypeTable UnknownCoverType + +instance ToJSON CoverType where + toJSON = \case + UnknownCoverType t -> String t + known -> enumToJSON coverTypeTable known + +-- | Card cover size. +data CoverSize + = CoverSmall + | CoverMedium + | CoverLarge + | -- | A value this library does not know yet; holds the raw string. + UnknownCoverSize Text + deriving stock (Eq, Show, Generic) + +coverSizeTable :: [(Text, CoverSize)] +coverSizeTable = + [ ("small", CoverSmall), + ("medium", CoverMedium), + ("large", CoverLarge) + ] + +instance FromJSON CoverSize where + parseJSON = parseEnum "CoverSize" coverSizeTable UnknownCoverSize + +instance ToJSON CoverSize where + toJSON = \case + UnknownCoverSize t -> String t + known -> enumToJSON coverSizeTable known + +-- | How a cover image is fitted. +data CoverAspect + = AspectContain + | AspectCover + | -- | A value this library does not know yet; holds the raw string. + UnknownCoverAspect Text + deriving stock (Eq, Show, Generic) + +coverAspectTable :: [(Text, CoverAspect)] +coverAspectTable = + [ ("contain", AspectContain), + ("cover", AspectCover) + ] + +instance FromJSON CoverAspect where + parseJSON = parseEnum "CoverAspect" coverAspectTable UnknownCoverAspect + +instance ToJSON CoverAspect where + toJSON = \case + UnknownCoverAspect t -> String t + known -> enumToJSON coverAspectTable known + +-- | Card layout of a board or gallery. +data CardLayout + = CardLayoutList + | CardLayoutCompact + | -- | A value this library does not know yet; holds the raw string. + UnknownCardLayout Text + deriving stock (Eq, Show, Generic) + +cardLayoutTable :: [(Text, CardLayout)] +cardLayoutTable = + [ ("list", CardLayoutList), + ("compact", CardLayoutCompact) + ] + +instance FromJSON CardLayout where + parseJSON = parseEnum "CardLayout" cardLayoutTable UnknownCardLayout + +instance ToJSON CardLayout where + toJSON = \case + UnknownCardLayout t -> String t + known -> enumToJSON cardLayoutTable known + +-- | Range shown by a calendar view. +data CalendarRange + = RangeWeek + | RangeMonth + | -- | A value this library does not know yet; holds the raw string. + UnknownCalendarRange Text + deriving stock (Eq, Show, Generic) + +calendarRangeTable :: [(Text, CalendarRange)] +calendarRangeTable = + [ ("week", RangeWeek), + ("month", RangeMonth) + ] + +instance FromJSON CalendarRange where + parseJSON = parseEnum "CalendarRange" calendarRangeTable UnknownCalendarRange + +instance ToJSON CalendarRange where + toJSON = \case + UnknownCalendarRange t -> String t + known -> enumToJSON calendarRangeTable known + +-- | Zoom level of a timeline view. +data TimelineZoomLevel + = ZoomHours + | ZoomDay + | ZoomWeek + | ZoomBiWeek + | ZoomMonth + | ZoomQuarter + | ZoomYear + | ZoomFiveYears + | -- | A value this library does not know yet; holds the raw string. + UnknownTimelineZoomLevel Text + deriving stock (Eq, Show, Generic) + +timelineZoomLevelTable :: [(Text, TimelineZoomLevel)] +timelineZoomLevelTable = + [ ("hours", ZoomHours), + ("day", ZoomDay), + ("week", ZoomWeek), + ("bi_week", ZoomBiWeek), + ("month", ZoomMonth), + ("quarter", ZoomQuarter), + ("year", ZoomYear), + ("5_years", ZoomFiveYears) + ] + +instance FromJSON TimelineZoomLevel where + parseJSON = parseEnum "TimelineZoomLevel" timelineZoomLevelTable UnknownTimelineZoomLevel + +instance ToJSON TimelineZoomLevel where + toJSON = \case + UnknownTimelineZoomLevel t -> String t + known -> enumToJSON timelineZoomLevelTable known + +-- | Height of a map or chart view. +data ViewHeight + = HeightSmall + | HeightMedium + | HeightLarge + | HeightExtraLarge + | -- | A value this library does not know yet; holds the raw string. + UnknownViewHeight Text + deriving stock (Eq, Show, Generic) + +viewHeightTable :: [(Text, ViewHeight)] +viewHeightTable = + [ ("small", HeightSmall), + ("medium", HeightMedium), + ("large", HeightLarge), + ("extra_large", HeightExtraLarge) + ] + +instance FromJSON ViewHeight where + parseJSON = parseEnum "ViewHeight" viewHeightTable UnknownViewHeight + +instance ToJSON ViewHeight where + toJSON = \case + UnknownViewHeight t -> String t + known -> enumToJSON viewHeightTable known + +-- | What a form submitter may do with their submission. +data SubmissionPermission + = SubmissionNone + | SubmissionCommentOnly + | SubmissionReader + | SubmissionReadAndWrite + | SubmissionEditor + | -- | A value this library does not know yet; holds the raw string. + UnknownSubmissionPermission Text + deriving stock (Eq, Show, Generic) + +submissionPermissionTable :: [(Text, SubmissionPermission)] +submissionPermissionTable = + [ ("none", SubmissionNone), + ("comment_only", SubmissionCommentOnly), + ("reader", SubmissionReader), + ("read_and_write", SubmissionReadAndWrite), + ("editor", SubmissionEditor) + ] + +instance FromJSON SubmissionPermission where + parseJSON = parseEnum "SubmissionPermission" submissionPermissionTable UnknownSubmissionPermission + +instance ToJSON SubmissionPermission where + toJSON = \case + UnknownSubmissionPermission t -> String t + known -> enumToJSON submissionPermissionTable known + +-- | Kind of chart. +data ChartType + = ChartColumn + | ChartBar + | ChartLine + | ChartDonut + | ChartNumber + | -- | A value this library does not know yet; holds the raw string. + UnknownChartType Text + deriving stock (Eq, Show, Generic) + +chartTypeTable :: [(Text, ChartType)] +chartTypeTable = + [ ("column", ChartColumn), + ("bar", ChartBar), + ("line", ChartLine), + ("donut", ChartDonut), + ("number", ChartNumber) + ] + +instance FromJSON ChartType where + parseJSON = parseEnum "ChartType" chartTypeTable UnknownChartType + +instance ToJSON ChartType where + toJSON = \case + UnknownChartType t -> String t + known -> enumToJSON chartTypeTable known + +-- | Order of chart groups. +data ChartSort + = ChartSortManual + | ChartSortXAscending + | ChartSortXDescending + | ChartSortYAscending + | ChartSortYDescending + | -- | A value this library does not know yet; holds the raw string. + UnknownChartSort Text + deriving stock (Eq, Show, Generic) + +chartSortTable :: [(Text, ChartSort)] +chartSortTable = + [ ("manual", ChartSortManual), + ("x_ascending", ChartSortXAscending), + ("x_descending", ChartSortXDescending), + ("y_ascending", ChartSortYAscending), + ("y_descending", ChartSortYDescending) + ] + +instance FromJSON ChartSort where + parseJSON = parseEnum "ChartSort" chartSortTable UnknownChartSort + +instance ToJSON ChartSort where + toJSON = \case + UnknownChartSort t -> String t + known -> enumToJSON chartSortTable known + +-- | Chart color theme. +data ChartColorTheme + = ThemeGray + | ThemeBlue + | ThemeYellow + | ThemeGreen + | ThemePurple + | ThemeTeal + | ThemeOrange + | ThemePink + | ThemeRed + | ThemeAuto + | ThemeColorful + | -- | A value this library does not know yet; holds the raw string. + UnknownChartColorTheme Text + deriving stock (Eq, Show, Generic) + +chartColorThemeTable :: [(Text, ChartColorTheme)] +chartColorThemeTable = + [ ("gray", ThemeGray), + ("blue", ThemeBlue), + ("yellow", ThemeYellow), + ("green", ThemeGreen), + ("purple", ThemePurple), + ("teal", ThemeTeal), + ("orange", ThemeOrange), + ("pink", ThemePink), + ("red", ThemeRed), + ("auto", ThemeAuto), + ("colorful", ThemeColorful) + ] + +instance FromJSON ChartColorTheme where + parseJSON = parseEnum "ChartColorTheme" chartColorThemeTable UnknownChartColorTheme + +instance ToJSON ChartColorTheme where + toJSON = \case + UnknownChartColorTheme t -> String t + known -> enumToJSON chartColorThemeTable known + +-- | Where a chart legend is placed. +data LegendPosition + = LegendOff + | LegendBottom + | LegendSide + | -- | A value this library does not know yet; holds the raw string. + UnknownLegendPosition Text + deriving stock (Eq, Show, Generic) + +legendPositionTable :: [(Text, LegendPosition)] +legendPositionTable = + [ ("off", LegendOff), + ("bottom", LegendBottom), + ("side", LegendSide) + ] + +instance FromJSON LegendPosition where + parseJSON = parseEnum "LegendPosition" legendPositionTable UnknownLegendPosition + +instance ToJSON LegendPosition where + toJSON = \case + UnknownLegendPosition t -> String t + known -> enumToJSON legendPositionTable known + +-- | Which chart axes show labels. +data AxisLabels + = AxisLabelsNone + | AxisLabelsX + | AxisLabelsY + | AxisLabelsBoth + | -- | A value this library does not know yet; holds the raw string. + UnknownAxisLabels Text + deriving stock (Eq, Show, Generic) + +axisLabelsTable :: [(Text, AxisLabels)] +axisLabelsTable = + [ ("none", AxisLabelsNone), + ("x_axis", AxisLabelsX), + ("y_axis", AxisLabelsY), + ("both", AxisLabelsBoth) + ] + +instance FromJSON AxisLabels where + parseJSON = parseEnum "AxisLabels" axisLabelsTable UnknownAxisLabels + +instance ToJSON AxisLabels where + toJSON = \case + UnknownAxisLabels t -> String t + known -> enumToJSON axisLabelsTable known + +-- | Which chart grid lines are drawn. +data GridLines + = GridLinesNone + | GridLinesHorizontal + | GridLinesVertical + | GridLinesBoth + | -- | A value this library does not know yet; holds the raw string. + UnknownGridLines Text + deriving stock (Eq, Show, Generic) + +gridLinesTable :: [(Text, GridLines)] +gridLinesTable = + [ ("none", GridLinesNone), + ("horizontal", GridLinesHorizontal), + ("vertical", GridLinesVertical), + ("both", GridLinesBoth) + ] + +instance FromJSON GridLines where + parseJSON = parseEnum "GridLines" gridLinesTable UnknownGridLines + +instance ToJSON GridLines where + toJSON = \case + UnknownGridLines t -> String t + known -> enumToJSON gridLinesTable known + +-- | How grouped chart series are drawn. +data GroupStyle + = GroupStyleNormal + | GroupStylePercent + | GroupStyleSideBySide + | -- | A value this library does not know yet; holds the raw string. + UnknownGroupStyle Text + deriving stock (Eq, Show, Generic) + +groupStyleTable :: [(Text, GroupStyle)] +groupStyleTable = + [ ("normal", GroupStyleNormal), + ("percent", GroupStylePercent), + ("side_by_side", GroupStyleSideBySide) + ] + +instance FromJSON GroupStyle where + parseJSON = parseEnum "GroupStyle" groupStyleTable UnknownGroupStyle + +instance ToJSON GroupStyle where + toJSON = \case + UnknownGroupStyle t -> String t + known -> enumToJSON groupStyleTable known + +-- | Labels on a donut chart. +data DonutLabels + = DonutLabelsNone + | DonutLabelsValue + | DonutLabelsName + | DonutLabelsNameAndValue + | -- | A value this library does not know yet; holds the raw string. + UnknownDonutLabels Text + deriving stock (Eq, Show, Generic) + +donutLabelsTable :: [(Text, DonutLabels)] +donutLabelsTable = + [ ("none", DonutLabelsNone), + ("value", DonutLabelsValue), + ("name", DonutLabelsName), + ("name_and_value", DonutLabelsNameAndValue) + ] + +instance FromJSON DonutLabels where + parseJSON = parseEnum "DonutLabels" donutLabelsTable UnknownDonutLabels + +instance ToJSON DonutLabels where + toJSON = \case + UnknownDonutLabels t -> String t + known -> enumToJSON donutLabelsTable known + +-- | Aggregation applied to a chart value. +data ChartAggregator + = AggCount + | AggCountValues + | AggSum + | AggAverage + | AggMedian + | AggMin + | AggMax + | AggRange + | AggUnique + | AggEmpty + | AggNotEmpty + | AggPercentEmpty + | AggPercentNotEmpty + | AggChecked + | AggUnchecked + | AggPercentChecked + | AggPercentUnchecked + | AggEarliestDate + | AggLatestDate + | AggDateRange + | -- | A value this library does not know yet; holds the raw string. + UnknownChartAggregator Text + deriving stock (Eq, Show, Generic) + +chartAggregatorTable :: [(Text, ChartAggregator)] +chartAggregatorTable = + [ ("count", AggCount), + ("count_values", AggCountValues), + ("sum", AggSum), + ("average", AggAverage), + ("median", AggMedian), + ("min", AggMin), + ("max", AggMax), + ("range", AggRange), + ("unique", AggUnique), + ("empty", AggEmpty), + ("not_empty", AggNotEmpty), + ("percent_empty", AggPercentEmpty), + ("percent_not_empty", AggPercentNotEmpty), + ("checked", AggChecked), + ("unchecked", AggUnchecked), + ("percent_checked", AggPercentChecked), + ("percent_unchecked", AggPercentUnchecked), + ("earliest_date", AggEarliestDate), + ("latest_date", AggLatestDate), + ("date_range", AggDateRange) + ] + +instance FromJSON ChartAggregator where + parseJSON = parseEnum "ChartAggregator" chartAggregatorTable UnknownChartAggregator + +instance ToJSON ChartAggregator where + toJSON = \case + UnknownChartAggregator t -> String t + known -> enumToJSON chartAggregatorTable known + +-- | Color of a chart reference line. +data ReferenceLineColor + = LineGray + | LineLightGray + | LineBrown + | LineYellow + | LineOrange + | LineGreen + | LineBlue + | LinePurple + | LinePink + | LineRed + | -- | A value this library does not know yet; holds the raw string. + UnknownReferenceLineColor Text + deriving stock (Eq, Show, Generic) + +referenceLineColorTable :: [(Text, ReferenceLineColor)] +referenceLineColorTable = + [ ("gray", LineGray), + ("lightgray", LineLightGray), + ("brown", LineBrown), + ("yellow", LineYellow), + ("orange", LineOrange), + ("green", LineGreen), + ("blue", LineBlue), + ("purple", LinePurple), + ("pink", LinePink), + ("red", LineRed) + ] + +instance FromJSON ReferenceLineColor where + parseJSON = parseEnum "ReferenceLineColor" referenceLineColorTable UnknownReferenceLineColor + +instance ToJSON ReferenceLineColor where + toJSON = \case + UnknownReferenceLineColor t -> String t + known -> enumToJSON referenceLineColorTable known + +-- | Line style of a chart reference line. +data DashStyle + = DashSolid + | DashDashed + | -- | A value this library does not know yet; holds the raw string. + UnknownDashStyle Text + deriving stock (Eq, Show, Generic) + +dashStyleTable :: [(Text, DashStyle)] +dashStyleTable = + [ ("solid", DashSolid), + ("dash", DashDashed) + ] + +instance FromJSON DashStyle where + parseJSON = parseEnum "DashStyle" dashStyleTable UnknownDashStyle + +instance ToJSON DashStyle where + toJSON = \case + UnknownDashStyle t -> String t + known -> enumToJSON dashStyleTable known + +-- ===================================================================== +-- Shared pieces +-- ===================================================================== + +-- | Display settings of one property in a view. +data ViewPropertyConfig = ViewPropertyConfig + { propertyId :: Text, + -- | Response only; dropped when encoding + propertyName :: Maybe Text, + visible :: Maybe Bool, + width :: Maybe Int, + wrap :: Maybe Bool, + statusShowAs :: Maybe StatusShowAs, + cardPropertyWidthMode :: Maybe CardPropertyWidthMode, + dateFormat :: Maybe DateFormat, + timeFormat :: Maybe TimeFormat + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ViewPropertyConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON ViewPropertyConfig where + toJSON = dropKeys ["property_name"] . genericToJSON aesonOptions + +-- | Sub-item settings of a table view. +data SubtaskConfig = SubtaskConfig + { propertyId :: Maybe Text, + displayMode :: Maybe SubtaskDisplayMode, + filterScope :: Maybe SubtaskFilterScope, + toggleColumnId :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +instance FromJSON SubtaskConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON SubtaskConfig where + toJSON = genericToJSON aesonOptions + +-- | Card cover of a board or gallery view. +data CoverConfig = CoverConfig + { type_ :: CoverType, + -- | The files property to use when the type is 'CoverProperty' + propertyId :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +instance FromJSON CoverConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON CoverConfig where + toJSON = genericToJSON aesonOptions + +-- ===================================================================== +-- Group by +-- ===================================================================== + +-- | Group by a select or multi-select property. +data SelectGroupByConfig = SelectGroupByConfig + { type_ :: SelectGroupKind, + propertyId :: Text, + sort :: GroupSort, + -- | Response only; dropped when encoding + propertyName :: Maybe Text, + hideEmptyGroups :: Maybe Bool + } + deriving stock (Eq, Show, Generic) + +instance FromJSON SelectGroupByConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON SelectGroupByConfig where + toJSON = dropKeys ["property_name"] . genericToJSON aesonOptions + +-- | Group by a status property. +data StatusGroupByConfig = StatusGroupByConfig + { propertyId :: Text, + groupBy :: StatusGroupMode, + sort :: GroupSort, + -- | Response only; dropped when encoding + propertyName :: Maybe Text, + hideEmptyGroups :: Maybe Bool + } + deriving stock (Eq, Show, Generic) + +instance FromJSON StatusGroupByConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON StatusGroupByConfig where + toJSON = dropKeys ["property_name"] . genericToJSON aesonOptions + +-- | Group by a person, created-by or last-edited-by property. +data PersonGroupByConfig = PersonGroupByConfig + { type_ :: PersonGroupKind, + propertyId :: Text, + sort :: GroupSort, + -- | Response only; dropped when encoding + propertyName :: Maybe Text, + hideEmptyGroups :: Maybe Bool + } + deriving stock (Eq, Show, Generic) + +instance FromJSON PersonGroupByConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON PersonGroupByConfig where + toJSON = dropKeys ["property_name"] . genericToJSON aesonOptions + +-- | Group by a relation property. +data RelationGroupByConfig = RelationGroupByConfig + { propertyId :: Text, + sort :: GroupSort, + -- | Response only; dropped when encoding + propertyName :: Maybe Text, + hideEmptyGroups :: Maybe Bool + } + deriving stock (Eq, Show, Generic) + +instance FromJSON RelationGroupByConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON RelationGroupByConfig where + toJSON = dropKeys ["property_name"] . genericToJSON aesonOptions + +-- | Group by a date, created-time or last-edited-time property. +data DateGroupByConfig = DateGroupByConfig + { type_ :: DateGroupKind, + propertyId :: Text, + groupBy :: DateGranularity, + sort :: GroupSort, + -- | Response only; dropped when encoding + propertyName :: Maybe Text, + hideEmptyGroups :: Maybe Bool, + -- | 0 (Sunday) or 1 (Monday) + startDayOfWeek :: Maybe Int + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DateGroupByConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON DateGroupByConfig where + toJSON = dropKeys ["property_name"] . genericToJSON aesonOptions + +-- | Group by a text, title, URL, email or phone number property. +data TextGroupByConfig = TextGroupByConfig + { type_ :: TextGroupKind, + propertyId :: Text, + groupBy :: TextGroupMode, + sort :: GroupSort, + -- | Response only; dropped when encoding + propertyName :: Maybe Text, + hideEmptyGroups :: Maybe Bool + } + deriving stock (Eq, Show, Generic) + +instance FromJSON TextGroupByConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON TextGroupByConfig where + toJSON = dropKeys ["property_name"] . genericToJSON aesonOptions + +-- | Group by a number property, in ranges. +data NumberGroupByConfig = NumberGroupByConfig + { propertyId :: Text, + sort :: GroupSort, + -- | Response only; dropped when encoding + propertyName :: Maybe Text, + hideEmptyGroups :: Maybe Bool, + rangeStart :: Maybe Scientific, + rangeEnd :: Maybe Scientific, + rangeSize :: Maybe Scientific + } + deriving stock (Eq, Show, Generic) + +instance FromJSON NumberGroupByConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON NumberGroupByConfig where + toJSON = dropKeys ["property_name"] . genericToJSON aesonOptions + +-- | Group by a checkbox property. +data CheckboxGroupByConfig = CheckboxGroupByConfig + { propertyId :: Text, + sort :: GroupSort, + -- | Response only; dropped when encoding + propertyName :: Maybe Text, + hideEmptyGroups :: Maybe Bool + } + deriving stock (Eq, Show, Generic) + +instance FromJSON CheckboxGroupByConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON CheckboxGroupByConfig where + toJSON = dropKeys ["property_name"] . genericToJSON aesonOptions + +-- | Group by a formula property, according to its result type. +data FormulaGroupByConfig = FormulaGroupByConfig + { propertyId :: Text, + groupBy :: FormulaSubGroupBy, + -- | Response only; dropped when encoding + propertyName :: Maybe Text, + hideEmptyGroups :: Maybe Bool + } + deriving stock (Eq, Show, Generic) + +instance FromJSON FormulaGroupByConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON FormulaGroupByConfig where + toJSON = dropKeys ["property_name"] . genericToJSON aesonOptions + +-- | Grouping of a date-valued formula. +data FormulaDateSubGroupBy = FormulaDateSubGroupBy + { groupBy :: DateGranularity, + sort :: GroupSort, + startDayOfWeek :: Maybe Int + } + deriving stock (Eq, Show, Generic) + +instance FromJSON FormulaDateSubGroupBy where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON FormulaDateSubGroupBy where + toJSON = genericToJSON aesonOptions + +-- | Grouping of a text-valued formula. +data FormulaTextSubGroupBy = FormulaTextSubGroupBy + { groupBy :: TextGroupMode, + sort :: GroupSort + } + deriving stock (Eq, Show, Generic) + +instance FromJSON FormulaTextSubGroupBy where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON FormulaTextSubGroupBy where + toJSON = genericToJSON aesonOptions + +-- | Grouping of a number-valued formula. +data FormulaNumberSubGroupBy = FormulaNumberSubGroupBy + { sort :: GroupSort, + rangeStart :: Maybe Scientific, + rangeEnd :: Maybe Scientific, + rangeSize :: Maybe Scientific + } + deriving stock (Eq, Show, Generic) + +instance FromJSON FormulaNumberSubGroupBy where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON FormulaNumberSubGroupBy where + toJSON = genericToJSON aesonOptions + +-- | Grouping of a checkbox-valued formula. +newtype FormulaCheckboxSubGroupBy = FormulaCheckboxSubGroupBy + { sort :: GroupSort + } + deriving stock (Eq, Show, Generic) + +instance FromJSON FormulaCheckboxSubGroupBy where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON FormulaCheckboxSubGroupBy where + toJSON = genericToJSON aesonOptions + +-- | How a formula group-by buckets values, by the formula's result type. +data FormulaSubGroupBy + = FormulaDateGroup FormulaDateSubGroupBy + | FormulaTextGroup FormulaTextSubGroupBy + | FormulaNumberGroup FormulaNumberSubGroupBy + | FormulaCheckboxGroup FormulaCheckboxSubGroupBy + | -- | An unrecognised type or shape; sent back verbatim. + UnknownFormulaGroup Value + deriving stock (Eq, Show, Generic) + +instance FromJSON FormulaSubGroupBy where + parseJSON v = typed <|> pure (UnknownFormulaGroup v) + where + typed = flip (Aeson.withObject "FormulaSubGroupBy") v $ \o -> do + t <- o .: "type" + case (t :: Text) of + "date" -> FormulaDateGroup <$> parseJSON v + "text" -> FormulaTextGroup <$> parseJSON v + "number" -> FormulaNumberGroup <$> parseJSON v + "checkbox" -> FormulaCheckboxGroup <$> parseJSON v + other -> fail ("unknown formula group-by type: " <> unpack other) + +instance ToJSON FormulaSubGroupBy where + toJSON = \case + FormulaDateGroup c -> withType "date" (toJSON c) + FormulaTextGroup c -> withType "text" (toJSON c) + FormulaNumberGroup c -> withType "number" (toJSON c) + FormulaCheckboxGroup c -> withType "checkbox" (toJSON c) + UnknownFormulaGroup raw -> raw + +-- | How a view groups its rows, by the grouped property's type. +data GroupByConfig + = -- | @select@, @multi_select@ + SelectGroupBy SelectGroupByConfig + | -- | @status@ + StatusGroupBy StatusGroupByConfig + | -- | @person@, @created_by@, @last_edited_by@ + PersonGroupBy PersonGroupByConfig + | -- | @relation@ + RelationGroupBy RelationGroupByConfig + | -- | @date@, @created_time@, @last_edited_time@ + DateGroupBy DateGroupByConfig + | -- | @text@, @title@, @url@, @email@, @phone_number@ + TextGroupBy TextGroupByConfig + | -- | @number@ + NumberGroupBy NumberGroupByConfig + | -- | @checkbox@ + CheckboxGroupBy CheckboxGroupByConfig + | -- | @formula@ + FormulaGroupBy FormulaGroupByConfig + | -- | An unrecognised type or shape; sent back verbatim. + UnknownGroupBy Value + deriving stock (Eq, Show, Generic) + +instance FromJSON GroupByConfig where + parseJSON v = typed <|> pure (UnknownGroupBy v) + where + typed = flip (Aeson.withObject "GroupByConfig") v $ \o -> do + t <- o .: "type" + case (t :: Text) of + "select" -> SelectGroupBy <$> parseJSON v + "multi_select" -> SelectGroupBy <$> parseJSON v + "status" -> StatusGroupBy <$> parseJSON v + "person" -> PersonGroupBy <$> parseJSON v + "created_by" -> PersonGroupBy <$> parseJSON v + "last_edited_by" -> PersonGroupBy <$> parseJSON v + "relation" -> RelationGroupBy <$> parseJSON v + "date" -> DateGroupBy <$> parseJSON v + "created_time" -> DateGroupBy <$> parseJSON v + "last_edited_time" -> DateGroupBy <$> parseJSON v + "text" -> TextGroupBy <$> parseJSON v + "title" -> TextGroupBy <$> parseJSON v + "url" -> TextGroupBy <$> parseJSON v + "email" -> TextGroupBy <$> parseJSON v + "phone_number" -> TextGroupBy <$> parseJSON v + "number" -> NumberGroupBy <$> parseJSON v + "checkbox" -> CheckboxGroupBy <$> parseJSON v + "formula" -> FormulaGroupBy <$> parseJSON v + other -> fail ("unknown group-by type: " <> unpack other) + +instance ToJSON GroupByConfig where + toJSON = \case + -- The multi-kind records write "type" from their own type_ field + SelectGroupBy c -> toJSON c + StatusGroupBy c -> withType "status" (toJSON c) + PersonGroupBy c -> toJSON c + RelationGroupBy c -> withType "relation" (toJSON c) + DateGroupBy c -> toJSON c + TextGroupBy c -> toJSON c + NumberGroupBy c -> withType "number" (toJSON c) + CheckboxGroupBy c -> withType "checkbox" (toJSON c) + FormulaGroupBy c -> withType "formula" (toJSON c) + UnknownGroupBy raw -> raw + +-- ===================================================================== +-- View configurations +-- ===================================================================== + +-- | Table view settings. +data TableViewConfig = TableViewConfig + { properties :: Clearable (Vector ViewPropertyConfig), + groupBy :: Clearable GroupByConfig, + subtasks :: Clearable SubtaskConfig, + wrapCells :: Maybe Bool, + frozenColumnIndex :: Maybe Int, + showVerticalLines :: Maybe Bool + } + deriving stock (Eq, Show, Generic) + +instance FromJSON TableViewConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON TableViewConfig where + toJSON = genericToJSON aesonOptions + +-- | Board view settings. +data BoardViewConfig = BoardViewConfig + { groupBy :: GroupByConfig, + subGroupBy :: Clearable GroupByConfig, + properties :: Clearable (Vector ViewPropertyConfig), + cover :: Clearable CoverConfig, + coverSize :: Clearable CoverSize, + coverAspect :: Clearable CoverAspect, + cardLayout :: Clearable CardLayout + } + deriving stock (Eq, Show, Generic) + +instance FromJSON BoardViewConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON BoardViewConfig where + toJSON = genericToJSON aesonOptions + +-- | Calendar view settings. +data CalendarViewConfig = CalendarViewConfig + { datePropertyId :: Text, + -- | Response only; dropped when encoding + datePropertyName :: Maybe Text, + properties :: Clearable (Vector ViewPropertyConfig), + viewRange :: Clearable CalendarRange, + showWeekends :: Clearable Bool + } + deriving stock (Eq, Show, Generic) + +instance FromJSON CalendarViewConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON CalendarViewConfig where + toJSON = dropKeys ["date_property_name"] . genericToJSON aesonOptions + +-- | Zoom and scroll position of a timeline. +data TimelinePreference = TimelinePreference + { zoomLevel :: TimelineZoomLevel, + -- | Milliseconds since the Unix epoch + centerTimestamp :: Maybe Integer + } + deriving stock (Eq, Show, Generic) + +instance FromJSON TimelinePreference where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON TimelinePreference where + toJSON = genericToJSON aesonOptions + +-- | Dependency arrows of a timeline. +newtype TimelineArrowsBy = TimelineArrowsBy + { -- | 'Clear' disables arrows + propertyId :: Clearable Text + } + deriving stock (Eq, Show, Generic) + +instance FromJSON TimelineArrowsBy where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON TimelineArrowsBy where + toJSON = genericToJSON aesonOptions + +-- | Timeline view settings. +data TimelineViewConfig = TimelineViewConfig + { datePropertyId :: Text, + -- | Response only; dropped when encoding + datePropertyName :: Maybe Text, + endDatePropertyId :: Clearable Text, + -- | Response only; dropped when encoding + endDatePropertyName :: Maybe Text, + properties :: Clearable (Vector ViewPropertyConfig), + showTable :: Clearable Bool, + tableProperties :: Clearable (Vector ViewPropertyConfig), + preference :: Clearable TimelinePreference, + arrowsBy :: Clearable TimelineArrowsBy, + colorBy :: Clearable Bool + } + deriving stock (Eq, Show, Generic) + +instance FromJSON TimelineViewConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON TimelineViewConfig where + toJSON = dropKeys ["date_property_name", "end_date_property_name"] . genericToJSON aesonOptions + +-- | Gallery view settings. +data GalleryViewConfig = GalleryViewConfig + { properties :: Clearable (Vector ViewPropertyConfig), + cover :: Clearable CoverConfig, + coverSize :: Clearable CoverSize, + coverAspect :: Clearable CoverAspect, + cardLayout :: Clearable CardLayout + } + deriving stock (Eq, Show, Generic) + +instance FromJSON GalleryViewConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON GalleryViewConfig where + toJSON = genericToJSON aesonOptions + +-- | List view settings. +newtype ListViewConfig = ListViewConfig + { properties :: Clearable (Vector ViewPropertyConfig) + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ListViewConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON ListViewConfig where + toJSON = genericToJSON aesonOptions + +-- | Map view settings. +data MapViewConfig = MapViewConfig + { height :: Clearable ViewHeight, + -- | ID of the place property the map plots + mapBy :: Clearable Text, + -- | Response only; dropped when encoding + mapByPropertyName :: Maybe Text, + properties :: Clearable (Vector ViewPropertyConfig) + } + deriving stock (Eq, Show, Generic) + +instance FromJSON MapViewConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON MapViewConfig where + toJSON = dropKeys ["map_by_property_name"] . genericToJSON aesonOptions + +-- | Form view settings. +data FormViewConfig = FormViewConfig + { isFormClosed :: Clearable Bool, + anonymousSubmissions :: Clearable Bool, + submissionPermissions :: Clearable SubmissionPermission + } + deriving stock (Eq, Show, Generic) + +instance FromJSON FormViewConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON FormViewConfig where + toJSON = genericToJSON aesonOptions + +-- | An aggregated chart value. +data ChartAggregation = ChartAggregation + { aggregator :: ChartAggregator, + -- | Required unless the aggregator is 'AggCount' + propertyId :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ChartAggregation where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON ChartAggregation where + toJSON = genericToJSON aesonOptions + +-- | A horizontal reference line on a chart. +data ChartReferenceLine = ChartReferenceLine + { -- | Always present in responses; optional in requests (Notion generates one) + id :: Maybe Text, + value :: Scientific, + label :: Text, + color :: ReferenceLineColor, + dashStyle :: DashStyle + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ChartReferenceLine where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON ChartReferenceLine where + toJSON = genericToJSON aesonOptions + +-- | Chart view settings. +data ChartViewConfig = ChartViewConfig + { chartType :: ChartType, + xAxis :: Clearable GroupByConfig, + yAxis :: Clearable ChartAggregation, + xAxisPropertyId :: Clearable Text, + yAxisPropertyId :: Clearable Text, + -- | The value shown by a number chart + value :: Clearable ChartAggregation, + sort :: Clearable ChartSort, + colorTheme :: Clearable ChartColorTheme, + height :: Clearable ViewHeight, + hideEmptyGroups :: Clearable Bool, + legendPosition :: Clearable LegendPosition, + showDataLabels :: Clearable Bool, + axisLabels :: Clearable AxisLabels, + gridLines :: Clearable GridLines, + cumulative :: Clearable Bool, + smoothLine :: Clearable Bool, + hideLineFillArea :: Clearable Bool, + groupStyle :: Clearable GroupStyle, + yAxisMin :: Clearable Scientific, + yAxisMax :: Clearable Scientific, + donutLabels :: Clearable DonutLabels, + hideTitle :: Clearable Bool, + stackBy :: Clearable GroupByConfig, + referenceLines :: Clearable (Vector ChartReferenceLine), + caption :: Clearable Text, + colorByValue :: Clearable Bool + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ChartViewConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON ChartViewConfig where + toJSON = genericToJSON aesonOptions + +-- | A widget on a dashboard: another view placed in a row. +data DashboardWidget = DashboardWidget + { id :: Text, + viewId :: UUID, + -- | Width in grid columns (1 to 12) + width :: Maybe Int, + rowIndex :: Maybe Int + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DashboardWidget where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON DashboardWidget where + toJSON = genericToJSON aesonOptions + +-- | A row of widgets on a dashboard. +data DashboardRow = DashboardRow + { id :: Text, + widgets :: Vector DashboardWidget, + -- | Height in pixels + height :: Maybe Int + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DashboardRow where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON DashboardRow where + toJSON = genericToJSON aesonOptions + +-- | Dashboard view layout. Notion returns it but does not accept it in requests. +newtype DashboardViewConfig = DashboardViewConfig + { rows :: Vector DashboardRow + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DashboardViewConfig where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON DashboardViewConfig where + toJSON = genericToJSON aesonOptions + +-- | A view's layout configuration, discriminated by @type@. +data ViewConfig + = TableConfig TableViewConfig + | BoardConfig BoardViewConfig + | CalendarConfig CalendarViewConfig + | TimelineConfig TimelineViewConfig + | GalleryConfig GalleryViewConfig + | ListConfig ListViewConfig + | MapConfig MapViewConfig + | FormConfig FormViewConfig + | ChartConfig ChartViewConfig + | -- | Returned by Notion only; requests have no dashboard configuration. + DashboardConfig DashboardViewConfig + | -- | Any other type, or a shape the typed parse rejected; sent back verbatim. + UnknownViewConfig Value + deriving stock (Eq, Show, Generic) + +instance FromJSON ViewConfig where + parseJSON v = typed <|> pure (UnknownViewConfig v) + where + typed = flip (Aeson.withObject "ViewConfig") v $ \o -> do + t <- o .: "type" + case (t :: Text) of + "table" -> TableConfig <$> parseJSON v + "board" -> BoardConfig <$> parseJSON v + "calendar" -> CalendarConfig <$> parseJSON v + "timeline" -> TimelineConfig <$> parseJSON v + "gallery" -> GalleryConfig <$> parseJSON v + "list" -> ListConfig <$> parseJSON v + "map" -> MapConfig <$> parseJSON v + "form" -> FormConfig <$> parseJSON v + "chart" -> ChartConfig <$> parseJSON v + "dashboard" -> DashboardConfig <$> parseJSON v + other -> fail ("unknown view configuration type: " <> unpack other) + +instance ToJSON ViewConfig where + toJSON = \case + TableConfig c -> withType "table" (toJSON c) + BoardConfig c -> withType "board" (toJSON c) + CalendarConfig c -> withType "calendar" (toJSON c) + TimelineConfig c -> withType "timeline" (toJSON c) + GalleryConfig c -> withType "gallery" (toJSON c) + ListConfig c -> withType "list" (toJSON c) + MapConfig c -> withType "map" (toJSON c) + FormConfig c -> withType "form" (toJSON c) + ChartConfig c -> withType "chart" (toJSON c) + -- Notion may reject a dashboard configuration in a request + DashboardConfig c -> withType "dashboard" (toJSON c) + UnknownViewConfig raw -> raw diff --git a/src/Notion/V1/ViewQueries.hs b/src/Notion/V1/ViewQueries.hs new file mode 100644 --- /dev/null +++ b/src/Notion/V1/ViewQueries.hs @@ -0,0 +1,31 @@ +-- | Convenience helpers for the view-query flow. +module Notion.V1.ViewQueries + ( queryAllViewPages, + ) +where + +import Control.Exception qualified as Exception +import Notion.Prelude +import Notion.V1 (Methods (..)) +import Notion.V1.ListOf (ListOf (..)) +import Notion.V1.Pages (PartialPageObject) +import Notion.V1.Views (CreateViewQuery (..), ViewID, ViewQuery (..)) +import Prelude hiding (id) + +-- | Create a view query, collect every result page, then delete the query. +-- +-- The page size (max 100) applies to every request. Errors from the final +-- delete are swallowed: the cached query expires on its own. +queryAllViewPages :: Methods -> ViewID -> Maybe Natural -> IO (Vector PartialPageObject) +queryAllViewPages Methods {createViewQuery, getViewQueryResults, deleteViewQuery} viewId pageSize = do + ViewQuery {id = queryId, results = firstPage, nextCursor, hasMore} <- + createViewQuery viewId CreateViewQuery {pageSize} + let cleanup = do + _ <- Exception.try @Exception.SomeException (deleteViewQuery viewId queryId) + pure () + go acc (Just cursor) True = do + List {results, nextCursor = next, hasMore = more} <- + getViewQueryResults viewId queryId (Just cursor) pageSize + go (acc <> results) next more + go acc _ _ = pure acc + go firstPage nextCursor hasMore `Exception.finally` cleanup diff --git a/src/Notion/V1/Views.hs b/src/Notion/V1/Views.hs --- a/src/Notion/V1/Views.hs +++ b/src/Notion/V1/Views.hs @@ -10,19 +10,43 @@ ViewType (..), CreateView (..), UpdateView (..), - QueryView (..), + -- * Filters, sorts and placement + ViewFilter (..), + ViewSort (..), + QuickFilter (..), + ViewPropertySort (..), + ViewPosition (..), + WidgetPlacement (..), + CreateDatabaseForView (..), + Clearable (..), + + -- * Configuration + module Notion.V1.ViewConfig, + + -- * View queries + ViewQueryID, + CreateViewQuery (..), + ViewQuery (..), + DeletedViewQuery (..), + PartialPageObject (..), + -- * Servant API, ) where -import Data.Aeson ((.:), (.:?)) +import Control.Applicative ((<|>)) +import Data.Aeson ((.:), (.:?), (.=)) +import Data.Aeson qualified as Aeson import Notion.Prelude -import Notion.V1.Common (ObjectType, UUID) -import Notion.V1.ListOf (ListOf) -import Notion.V1.Pages (PageObject) +import Notion.V1.Clearable (Clearable (..)) +import Notion.V1.Common (ObjectType, Parent, UUID) +import Notion.V1.Filter (Filter, PropertyCondition, Sort, SortDirection) +import Notion.V1.ListOf (ListOf, RequestStatus) +import Notion.V1.Pages (PartialPageObject (..)) import Notion.V1.Users (UserReference) +import Notion.V1.ViewConfig import Prelude hiding (id) -- | View ID @@ -40,10 +64,12 @@ | ChartView | MapView | DashboardView + | -- | A view type this library does not know yet; holds the raw string. + UnknownViewType Text deriving stock (Eq, Show, Generic) instance FromJSON ViewType where - parseJSON = \case + parseJSON = Aeson.withText "ViewType" $ \case "table" -> pure TableView "board" -> pure BoardView "list" -> pure ListViewType @@ -54,7 +80,7 @@ "chart" -> pure ChartView "map" -> pure MapView "dashboard" -> pure DashboardView - other -> fail $ "Unknown view type: " <> show other + other -> pure (UnknownViewType other) instance ToJSON ViewType where toJSON = \case @@ -68,14 +94,106 @@ ChartView -> "chart" MapView -> "map" DashboardView -> "dashboard" + UnknownViewType t -> String t +-- | A view's filter: typed when the 'Filter' DSL can express it, raw JSON otherwise. +data ViewFilter + = ViewFilter Filter + | RawViewFilter Value + deriving stock (Eq, Show) + +instance FromJSON ViewFilter where + parseJSON v = (ViewFilter <$> parseJSON v) <|> pure (RawViewFilter v) + +instance ToJSON ViewFilter where + toJSON = \case + ViewFilter f -> toJSON f + RawViewFilter v -> v + +-- | A view sort: typed property or timestamp sort, or raw JSON. +data ViewSort + = ViewSort Sort + | RawViewSort Value + deriving stock (Eq, Show) + +instance FromJSON ViewSort where + parseJSON v = (ViewSort <$> parseJSON v) <|> pure (RawViewSort v) + +instance ToJSON ViewSort where + toJSON = \case + ViewSort s -> toJSON s + RawViewSort v -> v + +-- | A quick filter condition (a property condition without the @property@ +-- key, e.g. @{"select":{"equals":"High"}}@), or raw JSON. +data QuickFilter + = QuickFilter PropertyCondition + | RawQuickFilter Value + deriving stock (Eq, Show) + +instance FromJSON QuickFilter where + parseJSON v = (QuickFilter <$> parseJSON v) <|> pure (RawQuickFilter v) + +instance ToJSON QuickFilter where + toJSON = \case + QuickFilter c -> toJSON c + RawQuickFilter v -> v + +-- | A property sort, the only kind 'UpdateView' accepts. +data ViewPropertySort = ViewPropertySort + { property :: Text, + direction :: SortDirection + } + deriving stock (Eq, Generic, Show) + +instance ToJSON ViewPropertySort where + toJSON = genericToJSON aesonOptions + +-- | Where a new view tab goes in the database's tab bar. +data ViewPosition + = ViewPositionStart + | ViewPositionEnd + | ViewPositionAfterView ViewID + deriving stock (Eq, Show) + +instance ToJSON ViewPosition where + toJSON = \case + ViewPositionStart -> Aeson.object ["type" .= ("start" :: Text)] + ViewPositionEnd -> Aeson.object ["type" .= ("end" :: Text)] + ViewPositionAfterView v -> Aeson.object ["type" .= ("after_view" :: Text), "view_id" .= v] + +-- | Where a new widget goes inside a dashboard view (0-based row index). +data WidgetPlacement + = NewRow (Maybe Natural) + | ExistingRow Natural + deriving stock (Eq, Show) + +instance ToJSON WidgetPlacement where + toJSON = \case + NewRow Nothing -> Aeson.object ["type" .= ("new_row" :: Text)] + NewRow (Just i) -> Aeson.object ["type" .= ("new_row" :: Text), "row_index" .= i] + ExistingRow i -> Aeson.object ["type" .= ("existing_row" :: Text), "row_index" .= i] + +-- | Create a new linked database block on a page and put the view in it. +data CreateDatabaseForView = CreateDatabaseForView + { parentPageId :: UUID, + afterBlockId :: Maybe UUID + } + deriving stock (Eq, Show) + +instance ToJSON CreateDatabaseForView where + toJSON CreateDatabaseForView {..} = + Aeson.object $ + ["parent" .= Aeson.object ["type" .= ("page_id" :: Text), "page_id" .= parentPageId]] + <> maybe [] (\b -> ["position" .= Aeson.object ["type" .= ("after_block" :: Text), "block_id" .= b]]) afterBlockId + -- | Notion view object -- -- Many fields are 'Maybe' because the API returns partial or full view objects -- depending on context (list endpoints return minimal objects with just id, parent, type). data ViewObject = ViewObject { id :: ViewID, - parent :: Maybe Value, + parent :: Maybe Parent, name :: Maybe Text, type_ :: Maybe ViewType, createdTime :: Maybe POSIXTime, @@ -84,10 +202,10 @@ dataSourceId :: Maybe UUID, createdBy :: Maybe UserReference, lastEditedBy :: Maybe UserReference, - filter :: Maybe Value, - sorts :: Maybe (Vector Value), - quickFilters :: Maybe Value, - configuration :: Maybe Value, + filter :: Maybe ViewFilter, + sorts :: Maybe (Vector ViewSort), + quickFilters :: Maybe (Map Text QuickFilter), + configuration :: Maybe ViewConfig, dashboardViewId :: Maybe ViewID, object :: Maybe ObjectType } @@ -122,42 +240,94 @@ { dataSourceId :: UUID, name :: Text, type_ :: ViewType, + -- | Mutually exclusive with 'viewId' and 'createDatabase_' databaseId :: Maybe UUID, + -- | Dashboard view to add this view to as a widget viewId :: Maybe ViewID, - filter :: Maybe Value, - sorts :: Maybe (Vector Value), - quickFilters :: Maybe Value, - configuration :: Maybe Value, - position :: Maybe Value + filter :: Maybe ViewFilter, + sorts :: Maybe (Vector ViewSort), + -- | Keyed by property ID + quickFilters :: Maybe (Map Text QuickFilter), + -- | Wire name @create_database@ + createDatabase_ :: Maybe CreateDatabaseForView, + configuration :: Maybe ViewConfig, + position :: Maybe ViewPosition, + placement :: Maybe WidgetPlacement } deriving stock (Generic, Show) instance ToJSON CreateView where toJSON = genericToJSON aesonOptions --- | Update a view request (all fields optional) +-- | Update a view request. 'Unset' leaves a field unchanged and 'Clear' sends +-- @null@ to clear it. data UpdateView = UpdateView { name :: Maybe Text, - filter :: Maybe Value, - sorts :: Maybe (Vector Value), - quickFilters :: Maybe Value, - configuration :: Maybe Value + filter :: Clearable ViewFilter, + sorts :: Clearable (Vector ViewPropertySort), + -- | A 'Nothing' value removes that quick filter; 'Clear' removes all of them + quickFilters :: Clearable (Map Text (Maybe QuickFilter)), + configuration :: Maybe ViewConfig } deriving stock (Generic, Show) instance ToJSON UpdateView where toJSON = genericToJSON aesonOptions --- | Query a view request (pagination only, view's own filters/sorts are used) -data QueryView = QueryView - { startCursor :: Maybe Text, +-- | View query ID +type ViewQueryID = UUID + +-- | Body of @POST views/{view_id}/queries@. +newtype CreateViewQuery = CreateViewQuery + { -- | Results per page (max 100) pageSize :: Maybe Natural } deriving stock (Generic, Show) -instance ToJSON QueryView where +instance ToJSON CreateViewQuery where toJSON = genericToJSON aesonOptions +-- | Response of @POST views/{view_id}/queries@: a cached server-side snapshot +-- of the rows the view matches, plus its first page of results. +data ViewQuery = ViewQuery + { id :: ViewQueryID, + viewId :: ViewID, + -- | When the cached results expire + expiresAt :: POSIXTime, + totalCount :: Natural, + results :: Vector PartialPageObject, + nextCursor :: Maybe Text, + hasMore :: Bool, + requestStatus :: Maybe RequestStatus + } + deriving stock (Generic, Show) + +instance FromJSON ViewQuery where + parseJSON = \case + Object o -> do + id <- o .: "id" + viewId <- o .: "view_id" + expiresAt <- o .: "expires_at" >>= parseISO8601 + totalCount <- o .: "total_count" + results <- o .: "results" + nextCursor <- o .:? "next_cursor" + hasMore <- o .: "has_more" + requestStatus <- o .:? "request_status" + pure ViewQuery {..} + _ -> fail "Expected object for ViewQuery" + +-- | Response of @DELETE views/{view_id}/queries/{query_id}@. +data DeletedViewQuery = DeletedViewQuery + { id :: ViewQueryID, + deleted :: Bool + } + deriving stock (Generic, Show) + +instance FromJSON DeletedViewQuery where + parseJSON = \case + Object o -> DeletedViewQuery <$> o .: "id" <*> o .: "deleted" + _ -> fail "Expected object for DeletedViewQuery" + -- | Servant API type API = "views" @@ -176,7 +346,17 @@ :> QueryParam "page_size" Natural :> Get '[JSON] (ListOf ViewObject) :<|> Capture "view_id" ViewID - :> "query" - :> ReqBody '[JSON] QueryView - :> Post '[JSON] (ListOf PageObject) + :> "queries" + :> ReqBody '[JSON] CreateViewQuery + :> Post '[JSON] ViewQuery + :<|> Capture "view_id" ViewID + :> "queries" + :> Capture "query_id" ViewQueryID + :> QueryParam "start_cursor" Text + :> QueryParam "page_size" Natural + :> Get '[JSON] (ListOf PartialPageObject) + :<|> Capture "view_id" ViewID + :> "queries" + :> Capture "query_id" ViewQueryID + :> Delete '[JSON] DeletedViewQuery ) diff --git a/src/Notion/V1/Webhooks.hs b/src/Notion/V1/Webhooks.hs --- a/src/Notion/V1/Webhooks.hs +++ b/src/Notion/V1/Webhooks.hs @@ -35,6 +35,17 @@ Author (..), AccessibleBy (..), + -- * Event data + WebhookEventData (..), + WebhookParent (..), + WebhookParentType (..), + WebhookBlockRef (..), + WebhookRefType (..), + UpdatedPropertySchema (..), + PropertyAction (..), + ViewField (..), + parseEventData, + -- * Verification VerificationPayload (..), verifySignature, @@ -42,15 +53,20 @@ ) where +import Control.Applicative ((<|>)) import Crypto.Hash.SHA256 qualified as SHA256 -import Data.Aeson (object, (.:), (.:?), (.=)) +import Data.Aeson (object, withObject, withText, (.!=), (.:), (.:?), (.=)) +import Data.Aeson.Types (Parser) import Data.Bits (xor, (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Base16 qualified as Base16 +import Data.Char (isHexDigit) +import Data.Text qualified as T import Data.Text.Encoding qualified as Text import Notion.Prelude hiding (ByteString) import Notion.V1.Common (UUID (..)) +import Notion.V1.FileUploads (FileImportResult) -- | Webhook event types supported by Notion data EventType @@ -85,6 +101,13 @@ ViewCreated | ViewUpdated | ViewDeleted + | -- | File upload events + FileUploadCreated + | FileUploadCompleted + | FileUploadExpired + | FileUploadUploadFailed + | -- | A meeting transcript was deleted + PageTranscriptBlockTranscriptDeleted | -- | Unknown event type (for forward compatibility) UnknownEvent Text deriving stock (Eq, Show, Generic) @@ -117,6 +140,11 @@ String "view.created" -> pure ViewCreated String "view.updated" -> pure ViewUpdated String "view.deleted" -> pure ViewDeleted + String "file_upload.created" -> pure FileUploadCreated + String "file_upload.completed" -> pure FileUploadCompleted + String "file_upload.expired" -> pure FileUploadExpired + String "file_upload.upload_failed" -> pure FileUploadUploadFailed + String "page.transcription_block.transcript_deleted" -> pure PageTranscriptBlockTranscriptDeleted String other -> pure $ UnknownEvent other _ -> fail "Expected string for EventType" @@ -148,6 +176,11 @@ ViewCreated -> String "view.created" ViewUpdated -> String "view.updated" ViewDeleted -> String "view.deleted" + FileUploadCreated -> String "file_upload.created" + FileUploadCompleted -> String "file_upload.completed" + FileUploadExpired -> String "file_upload.expired" + FileUploadUploadFailed -> String "file_upload.upload_failed" + PageTranscriptBlockTranscriptDeleted -> String "page.transcription_block.transcript_deleted" UnknownEvent t -> String t -- | Entity types in webhook events @@ -157,6 +190,9 @@ | DataSourceEntity | CommentEntity | ViewEntity + | FileUploadEntity + | -- | A linked database block (database events) + BlockEntity | UnknownEntityType Text deriving stock (Eq, Show, Generic) @@ -167,6 +203,8 @@ String "data_source" -> pure DataSourceEntity String "comment" -> pure CommentEntity String "view" -> pure ViewEntity + String "file_upload" -> pure FileUploadEntity + String "block" -> pure BlockEntity String other -> pure $ UnknownEntityType other _ -> fail "Expected string for EntityType" @@ -177,6 +215,8 @@ DataSourceEntity -> String "data_source" CommentEntity -> String "comment" ViewEntity -> String "view" + FileUploadEntity -> String "file_upload" + BlockEntity -> String "block" UnknownEntityType t -> String t -- | Entity that triggered the webhook event @@ -253,6 +293,8 @@ timestamp :: POSIXTime, -- | Workspace where the event originated workspaceId :: UUID, + -- | Name of that workspace + workspaceName :: Maybe Text, -- | Associated webhook subscription subscriptionId :: UUID, -- | Integration that owns the subscription @@ -267,8 +309,10 @@ attemptNumber :: Int, -- | Entity that triggered the event entity :: WebhookEntity, - -- | Event-specific data (varies by event type) - data_ :: Maybe Value + -- | Event-specific data, typed by event family + data_ :: Maybe WebhookEventData, + -- | API version the subscription uses, for example @2026-03-11@ + apiVersion :: Maybe Text } deriving stock (Show, Generic) @@ -279,20 +323,257 @@ timestampText <- o .: "timestamp" timestamp <- parseISO8601 timestampText workspaceId <- o .: "workspace_id" + workspaceName <- o .:? "workspace_name" subscriptionId <- o .: "subscription_id" integrationId <- o .: "integration_id" type_ <- o .: "type" authors <- o .: "authors" - accessibleBy <- o .: "accessible_by" + -- Only present for public integrations + accessibleBy <- o .:? "accessible_by" .!= mempty attemptNumber <- o .: "attempt_number" entity <- o .: "entity" - data_ <- o .:? "data" + mRaw <- o .:? "data" + data_ <- traverse (parseEventData type_) mRaw + apiVersion <- o .:? "api_version" pure WebhookEvent {..} _ -> fail "Expected object for WebhookEvent" instance ToJSON WebhookEvent where toJSON = genericToJSON aesonOptions +-- | Kind of an event entity's parent +data WebhookParentType + = WebhookParentSpace + | WebhookParentBlock + | WebhookParentPage + | WebhookParentDatabase + | WebhookParentTeam + | WebhookParentAgent + | UnknownWebhookParentType Text + deriving stock (Eq, Show, Generic) + +instance FromJSON WebhookParentType where + parseJSON = withText "WebhookParentType" $ \case + "space" -> pure WebhookParentSpace + "block" -> pure WebhookParentBlock + "page" -> pure WebhookParentPage + "database" -> pure WebhookParentDatabase + "team" -> pure WebhookParentTeam + "agent" -> pure WebhookParentAgent + other -> pure (UnknownWebhookParentType other) + +instance ToJSON WebhookParentType where + toJSON = \case + WebhookParentSpace -> String "space" + WebhookParentBlock -> String "block" + WebhookParentPage -> String "page" + WebhookParentDatabase -> String "database" + WebhookParentTeam -> String "team" + WebhookParentAgent -> String "agent" + UnknownWebhookParentType t -> String t + +-- | The parent of the entity an event is about. +data WebhookParent = WebhookParent + { id :: UUID, + type_ :: WebhookParentType, + dataSourceId :: Maybe UUID + } + deriving stock (Eq, Show, Generic) + +instance FromJSON WebhookParent where + parseJSON = withObject "WebhookParent" $ \o -> + WebhookParent <$> o .: "id" <*> o .: "type" <*> o .:? "data_source_id" + +instance ToJSON WebhookParent where + toJSON (WebhookParent pid ptype dsId) = + object (["id" .= pid, "type" .= ptype] <> maybe [] (\d -> ["data_source_id" .= d]) dsId) + +-- | Kind of a page, database or block referenced by an event +data WebhookRefType + = WebhookRefPage + | WebhookRefDatabase + | WebhookRefBlock + | UnknownWebhookRefType Text + deriving stock (Eq, Show, Generic) + +instance FromJSON WebhookRefType where + parseJSON = withText "WebhookRefType" $ \case + "page" -> pure WebhookRefPage + "database" -> pure WebhookRefDatabase + "block" -> pure WebhookRefBlock + other -> pure (UnknownWebhookRefType other) + +instance ToJSON WebhookRefType where + toJSON = \case + WebhookRefPage -> String "page" + WebhookRefDatabase -> String "database" + WebhookRefBlock -> String "block" + UnknownWebhookRefType t -> String t + +-- | A page, database, or block referenced by an event (updated blocks, +-- comment parents, transcript targets). +data WebhookBlockRef = WebhookBlockRef + { id :: UUID, + type_ :: WebhookRefType + } + deriving stock (Eq, Show, Generic) + +instance FromJSON WebhookBlockRef where + parseJSON = withObject "WebhookBlockRef" $ \o -> + WebhookBlockRef <$> o .: "id" <*> o .: "type" + +instance ToJSON WebhookBlockRef where + toJSON (WebhookBlockRef rid rtype) = object ["id" .= rid, "type" .= rtype] + +-- | What happened to a property in a schema update +data PropertyAction + = PropertyCreated + | PropertyUpdated + | PropertyDeleted + | UnknownPropertyAction Text + deriving stock (Eq, Show, Generic) + +instance FromJSON PropertyAction where + parseJSON = withText "PropertyAction" $ \case + "created" -> pure PropertyCreated + "updated" -> pure PropertyUpdated + "deleted" -> pure PropertyDeleted + other -> pure (UnknownPropertyAction other) + +instance ToJSON PropertyAction where + toJSON = \case + PropertyCreated -> String "created" + PropertyUpdated -> String "updated" + PropertyDeleted -> String "deleted" + UnknownPropertyAction t -> String t + +-- | A property changed by a database or data source schema update +data UpdatedPropertySchema = UpdatedPropertySchema + { id :: Text, + name :: Maybe Text, + action :: PropertyAction + } + deriving stock (Eq, Show, Generic) + +instance FromJSON UpdatedPropertySchema where + parseJSON = withObject "UpdatedPropertySchema" $ \o -> + UpdatedPropertySchema <$> o .: "id" <*> o .:? "name" <*> o .: "action" + +instance ToJSON UpdatedPropertySchema where + toJSON (UpdatedPropertySchema pid pname act) = + object ["id" .= pid, "name" .= pname, "action" .= act] + +-- | A view setting changed by a @view.updated@ event +data ViewField + = ViewFieldName + | ViewFieldFilter + | ViewFieldSorts + | ViewFieldConfiguration + | UnknownViewField Text + deriving stock (Eq, Show, Generic) + +instance FromJSON ViewField where + parseJSON = withText "ViewField" $ \case + "name" -> pure ViewFieldName + "filter" -> pure ViewFieldFilter + "sorts" -> pure ViewFieldSorts + "configuration" -> pure ViewFieldConfiguration + other -> pure (UnknownViewField other) + +instance ToJSON ViewField where + toJSON = \case + ViewFieldName -> String "name" + ViewFieldFilter -> String "filter" + ViewFieldSorts -> String "sorts" + ViewFieldConfiguration -> String "configuration" + UnknownViewField t -> String t + +-- | Event-specific data, typed by event family. +data WebhookEventData + = -- | created / deleted / undeleted / moved / locked / unlocked, and @view.deleted@ + ParentData WebhookParent + | -- | @*.content_updated@ + ContentUpdatedData WebhookParent (Vector WebhookBlockRef) + | -- | @page.properties_updated@: IDs of the changed properties + PagePropertiesUpdatedData WebhookParent (Vector Text) + | -- | @database.schema_updated@ / @data_source.schema_updated@ + SchemaUpdatedData WebhookParent (Vector UpdatedPropertySchema) + | -- | @view.created@: the view type (for example @table@ or @board@) + ViewCreatedData WebhookParent Text + | -- | @view.updated@: the settings that changed + ViewUpdatedData WebhookParent (Vector ViewField) + | -- | @comment.*@: the comment's parent and the containing page ID + CommentEventData WebhookBlockRef UUID + | -- | @file_upload.upload_failed@ + FileUploadFailedData FileImportResult + | -- | @page.transcription_block.transcript_deleted@: the transcript block + -- and the deleted transcript's ID + TranscriptDeletedData WebhookBlockRef (Maybe Text) + | -- | Any data the typed decoder does not recognize, kept verbatim. + RawEventData Value + deriving stock (Show, Generic) + +-- | Encodes the inner @data@ object, without any tag. +instance ToJSON WebhookEventData where + toJSON = \case + ParentData p -> object ["parent" .= p] + ContentUpdatedData p bs -> object ["parent" .= p, "updated_blocks" .= bs] + PagePropertiesUpdatedData p ps -> object ["parent" .= p, "updated_properties" .= ps] + SchemaUpdatedData p ps -> object ["parent" .= p, "updated_properties" .= ps] + ViewCreatedData p vt -> object ["parent" .= p, "view_type" .= vt] + ViewUpdatedData p fs -> object ["parent" .= p, "updated_fields" .= fs] + CommentEventData p pid -> object ["parent" .= p, "page_id" .= pid] + FileUploadFailedData r -> object ["file_import_result" .= r] + TranscriptDeletedData t tid -> object ["target" .= t, "transcript_id" .= tid] + RawEventData v -> v + +-- | Decode an event's @data@ according to its event type. Never fails: if the +-- typed shape does not match, the raw value is returned as 'RawEventData'. +parseEventData :: EventType -> Value -> Parser WebhookEventData +parseEventData evType v = typed <|> pure (RawEventData v) + where + typed = case v of + Object o -> + let parent = o .: "parent" + in case evType of + _ + | evType `elem` parentOnlyEvents -> ParentData <$> parent + PageContentUpdated -> contentUpdated o parent + DatabaseContentUpdated -> contentUpdated o parent + DataSourceContentUpdated -> contentUpdated o parent + PagePropertiesUpdated -> PagePropertiesUpdatedData <$> parent <*> o .: "updated_properties" + DatabaseSchemaUpdated -> schemaUpdated o parent + DataSourceSchemaUpdated -> schemaUpdated o parent + ViewCreated -> ViewCreatedData <$> parent <*> o .: "view_type" + ViewUpdated -> ViewUpdatedData <$> parent <*> o .: "updated_fields" + CommentCreated -> commentData o + CommentUpdated -> commentData o + CommentDeleted -> commentData o + FileUploadUploadFailed -> FileUploadFailedData <$> o .: "file_import_result" + PageTranscriptBlockTranscriptDeleted -> TranscriptDeletedData <$> o .: "target" <*> o .:? "transcript_id" + _ -> fail "untyped event data" + _ -> fail "event data is not an object" + contentUpdated o parent = ContentUpdatedData <$> parent <*> o .: "updated_blocks" + schemaUpdated o parent = SchemaUpdatedData <$> parent <*> (o .:? "updated_properties" .!= mempty) + commentData o = CommentEventData <$> o .: "parent" <*> o .: "page_id" + parentOnlyEvents = + [ PageCreated, + PageDeleted, + PageUndeleted, + PageMoved, + PageLocked, + PageUnlocked, + DatabaseCreated, + DatabaseDeleted, + DatabaseUndeleted, + DatabaseMoved, + DataSourceCreated, + DataSourceDeleted, + DataSourceUndeleted, + DataSourceMoved, + ViewDeleted + ] + -- | Verification payload sent by Notion when setting up a webhook -- Your endpoint should receive this and confirm the token in the Notion UI data VerificationPayload = VerificationPayload @@ -324,7 +605,9 @@ -- | Verify webhook signature from X-Notion-Signature header -- --- Uses constant-time comparison to prevent timing attacks. +-- Uses constant-time comparison to prevent timing attacks. The header must +-- start with @sha256=@ followed by exactly 64 hex digits; the hex digits are +-- compared case-insensitively. -- -- Example: -- @@ -341,10 +624,14 @@ -- | True if signature is valid Bool verifySignature verificationToken body headerSignature = - constantTimeCompare expected actual - where - expected = Text.encodeUtf8 $ computeSignature verificationToken body - actual = Text.encodeUtf8 headerSignature + case T.stripPrefix "sha256=" headerSignature of + Nothing -> False + Just provided -> + let providedHex = T.toLower provided + computedHex = Base16.encode (SHA256.hmac (Text.encodeUtf8 verificationToken) body) + in T.length providedHex == 64 + && T.all isHexDigit providedHex + && constantTimeCompare (Text.encodeUtf8 providedHex) computedHex -- | Constant-time comparison to prevent timing attacks constantTimeCompare :: ByteString -> ByteString -> Bool diff --git a/tasty/AsyncTaskTests.hs b/tasty/AsyncTaskTests.hs new file mode 100644 --- /dev/null +++ b/tasty/AsyncTaskTests.hs @@ -0,0 +1,211 @@ +-- | Async task decoding, @allow_async@ requests and polling (EP-3). +module AsyncTaskTests (tests) where + +import Control.Exception (Exception, throwIO, try) +import Data.Aeson (Value) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy qualified as LBS +import Data.IORef (atomicModifyIORef', newIORef, readIORef, writeIORef) +import Data.Map qualified as Map +import FakeNotion +import Network.HTTP.Client qualified as HTTP +import Notion.V1 (Methods (..), makeMethods) +import Notion.V1.AsyncTasks +import Notion.V1.Common (Parent (..), UUID (..)) +import Notion.V1.Error (APIErrorCode (..)) +import Notion.V1.Pages (CreatePage (..), ReplaceContentRequest (..), UpdatePageMarkdown (..), mkCreatePage) +import Servant.Client qualified as Client +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Async tasks (EP-3)" + [ testCase "Decode running task" testRunning, + testCase "Decode succeeded task" testSucceeded, + testCase "Decode failed task" testFailed, + testCase "Unknown status and surface are tolerated" testUnknown, + testCase "AsyncTask round-trips" testRoundTrip, + testCase "AsyncOr picks async_task" testAsyncOr, + testCase "AllowAsync adds the flag" testAllowAsync, + testCase "waitForAsyncTask polls until terminal" testWaitUntilTerminal, + testCase "waitForAsyncTask stops at maxAttempts" testWaitMaxAttempts, + testCase "createPageAsync sends allow_async to POST /pages" testCreatePageAsyncRequest, + testCase "retrieveAsyncTask and updatePageMarkdownAsync (202) routes" testRoutes + ] + +runningFixture :: LBS.ByteString +runningFixture = + "{\"object\":\"async_task\",\"id\":\"task_01\",\ + \\"status_url\":\"https://api.notion.com/v1/async_tasks/task_01\",\ + \\"created_time\":\"2026-09-14T10:00:00.000Z\",\ + \\"operation\":{\"surface\":\"rest\",\"name\":\"pages.create\"},\ + \\"status\":\"running\",\"poll_after_seconds\":2}" + +succeededFixture :: LBS.ByteString +succeededFixture = + "{\"object\":\"async_task\",\"id\":\"task_01\",\ + \\"status_url\":\"https://api.notion.com/v1/async_tasks/task_01\",\ + \\"created_time\":\"2026-09-14T10:00:00.000Z\",\ + \\"operation\":{\"surface\":\"rest\",\"name\":\"pages.create\"},\ + \\"status\":\"succeeded\",\"result\":{\"page_id\":\"5c6a2821-0000-4000-8000-00000000000a\"}}" + +failedFixture :: LBS.ByteString +failedFixture = + "{\"object\":\"async_task\",\"id\":\"task_02\",\ + \\"status_url\":\"https://api.notion.com/v1/async_tasks/task_02\",\ + \\"created_time\":\"2026-09-14T10:00:00.000Z\",\ + \\"operation\":{\"surface\":\"mcp\",\"name\":\"pages.update_markdown\"},\ + \\"status\":\"failed\",\"error\":{\"object\":\"error\",\"status\":400,\ + \\"code\":\"validation_error\",\"message\":\"markdown is required\",\ + \\"additional_data\":{\"field\":[\"markdown\"]}}}" + +unknownFixture :: LBS.ByteString +unknownFixture = + "{\"object\":\"async_task\",\"id\":\"task_03\",\ + \\"status_url\":\"https://api.notion.com/v1/async_tasks/task_03\",\ + \\"created_time\":\"2026-09-14T10:00:00.000Z\",\ + \\"operation\":{\"surface\":\"cli\",\"name\":\"pages.create\"},\ + \\"status\":\"cancelled\"}" + +decodeTask :: LBS.ByteString -> IO AsyncTask +decodeTask bs = either (assertFailure . ("decode: " <>)) pure (Aeson.eitherDecode bs) + +testRunning :: Assertion +testRunning = do + AsyncTask {status, operation = AsyncTaskOperation {surface, name}} <- decodeTask runningFixture + status @?= AsyncTaskRunning 2.0 + surface @?= SurfaceRest + name @?= "pages.create" + +testSucceeded :: Assertion +testSucceeded = do + AsyncTask {status} <- decodeTask succeededFixture + case status of + AsyncTaskSucceeded result -> assertBool "page_id in result" (KeyMap.member "page_id" result) + other -> assertFailure ("expected AsyncTaskSucceeded, got " <> show other) + +testFailed :: Assertion +testFailed = do + AsyncTask {status, operation = AsyncTaskOperation {surface}} <- decodeTask failedFixture + surface @?= SurfaceMcp + case status of + AsyncTaskFailed AsyncTaskError {status = errStatus, code, additionalData} -> do + errStatus @?= 400 + code @?= ValidationError + assertBool "additional_data.field" (maybe False (KeyMap.member "field") additionalData) + other -> assertFailure ("expected AsyncTaskFailed, got " <> show other) + +testUnknown :: Assertion +testUnknown = do + task@AsyncTask {status, operation = AsyncTaskOperation {surface}} <- decodeTask unknownFixture + status @?= UnknownAsyncTaskStatus "cancelled" + surface @?= UnknownSurface "cli" + assertBool "unknown status is terminal" (isTerminal task) + +testRoundTrip :: Assertion +testRoundTrip = + mapM_ + ( \fixture -> do + task <- decodeTask fixture + Aeson.eitherDecode (Aeson.encode task) @?= Right task + ) + [runningFixture, succeededFixture, failedFixture, unknownFixture] + +testAsyncOr :: Assertion +testAsyncOr = do + case Aeson.eitherDecode runningFixture :: Either String (AsyncOr Value) of + Right (AcceptedAsync _) -> pure () + other -> assertFailure ("expected AcceptedAsync, got " <> show other) + case Aeson.eitherDecode "{\"object\":\"page\",\"id\":\"p\"}" :: Either String (AsyncOr Value) of + Right (CompletedSync _) -> pure () + other -> assertFailure ("expected CompletedSync, got " <> show other) + +testAllowAsync :: Assertion +testAllowAsync = do + expected <- + either assertFailure pure $ + Aeson.eitherDecode + "{\"type\":\"replace_content\",\"replace_content\":{\"new_str\":\"new\"},\"allow_async\":true}" + Aeson.toJSON (AllowAsync (ReplaceContent (ReplaceContentRequest "new" Nothing))) @?= (expected :: Value) + +-- | A pending task that asks to be polled again immediately. +pendingTask :: IO AsyncTask +pendingTask = do + AsyncTask {id = taskId, statusUrl, createdTime, operation, object} <- decodeTask runningFixture + pure AsyncTask {id = taskId, statusUrl, createdTime, operation, object, status = AsyncTaskRunning 0} + +testWaitUntilTerminal :: Assertion +testWaitUntilTerminal = do + start <- pendingTask + done <- decodeTask succeededFixture + script <- newIORef [start, done] + calls <- newIORef (0 :: Int) + let retrieve _ = do + atomicModifyIORef' calls (\n -> (n + 1, ())) + atomicModifyIORef' script (\case t : ts -> (ts, t); [] -> ([], done)) + AsyncTask {status} <- waitForAsyncTask defaultWaitOptions retrieve start + case status of + AsyncTaskSucceeded _ -> pure () + other -> assertFailure ("expected AsyncTaskSucceeded, got " <> show other) + readIORef calls >>= (@?= 2) + +testWaitMaxAttempts :: Assertion +testWaitMaxAttempts = do + start <- pendingTask + calls <- newIORef (0 :: Int) + let retrieve _ = atomicModifyIORef' calls (\n -> (n + 1, start)) + result <- waitForAsyncTask WaitOptions {maxAttempts = 3, maxPollSeconds = 1} retrieve start + assertBool "result is still pending" (not (isTerminal result)) + readIORef calls >>= (@?= 3) + +data RequestCaptured = RequestCaptured deriving stock (Show) + +instance Exception RequestCaptured + +-- | Build a request through 'Methods' without sending it. +captureRequest :: (Methods -> IO a) -> IO HTTP.Request +captureRequest call = do + ref <- newIORef Nothing + manager <- HTTP.newManager HTTP.defaultManagerSettings + let env0 = Client.mkClientEnv manager fakeBaseUrl + env = + env0 + { Client.makeClientRequest = \burl req -> do + built <- Client.defaultMakeClientRequest burl req + writeIORef ref (Just built) + throwIO RequestCaptured + } + _ <- try @RequestCaptured (call (makeMethods env "secret_test_token")) + readIORef ref >>= maybe (assertFailure "no request was built") pure + +testCreatePageAsyncRequest :: Assertion +testCreatePageAsyncRequest = do + let CreatePage {..} = mkCreatePage (PageParent (UUID "p-1")) Map.empty + page = CreatePage {markdown = Just "# Hello", ..} + req <- captureRequest (\m -> createPageAsync m page) + HTTP.method req @?= "POST" + HTTP.path req @?= "/v1/pages" + case HTTP.requestBody req of + HTTP.RequestBodyLBS lbs -> case Aeson.decode lbs of + Just (Aeson.Object o) -> do + KeyMap.lookup "allow_async" o @?= Just (Aeson.Bool True) + KeyMap.lookup "markdown" o @?= Just (Aeson.String "# Hello") + other -> assertFailure ("expected a JSON object body, got " <> show other) + _ -> assertFailure "expected a lazy ByteString body" + +testRoutes :: Assertion +testRoutes = do + (env, recorded) <- fakeClientEnv [jsonReply 200 succeededFixture, jsonReply 202 runningFixture] + let Methods {retrieveAsyncTask, updatePageMarkdownAsync} = makeMethods env "secret_test" + AsyncTask {id = taskId} <- retrieveAsyncTask "task_01" + taskId @?= "task_01" + updated <- updatePageMarkdownAsync (UUID "p-1") (ReplaceContent (ReplaceContentRequest "new" Nothing)) + case updated of + AcceptedAsync _ -> pure () + CompletedSync _ -> assertFailure "expected AcceptedAsync" + requests <- readIORef recorded + map (\Recorded {method, path} -> (method, path)) requests + @?= [("GET", "/async_tasks/task_01"), ("PATCH", "/pages/p-1/markdown")] diff --git a/tasty/CommentTests.hs b/tasty/CommentTests.hs new file mode 100644 --- /dev/null +++ b/tasty/CommentTests.hs @@ -0,0 +1,140 @@ +-- | Comment retrieval, mutation and create-comment request shapes (EP-3). +module CommentTests (tests) where + +import Data.Aeson (Value, (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy.Char8 qualified as L8 +import Data.IORef (readIORef) +import Data.Text (Text) +import Data.Vector qualified as Vector +import FakeNotion +import Notion.V1 (Methods (..), makeMethods) +import Notion.V1.BlockContent (mkRichText) +import Notion.V1.Comments +import Notion.V1.Common (Parent (..), UUID (..)) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Comment mutation (EP-3)" + [ testCase "CommentResponse decodes a full comment" testFullComment, + testCase "CommentResponse decodes a partial comment" testPartialComment, + testCase "CommentResponse with parent but missing fields fails" testBrokenFullComment, + testCase "CreateComment on a page with rich text" testCreateOnPage, + testCase "CreateComment reply with Markdown" testReplyMarkdown, + testCase "CreateComment attachments and custom display name" testAttachmentsAndDisplayName, + testCase "Display name integration and user" testDisplayNames, + testCase "Update comment body" testUpdateBody, + testCase "Retrieve, update and delete use comments/{id}" testRoutes + ] + +fullCommentFixture :: LBS.ByteString +fullCommentFixture = + L8.pack + "{\"object\":\"comment\",\"id\":\"2b0c5f7e-0000-4000-8000-000000000001\",\ + \\"parent\":{\"type\":\"page_id\",\"page_id\":\"5c6a2821-0000-4000-8000-00000000000a\"},\ + \\"discussion_id\":\"f1d2d2f9-0000-4000-8000-00000000000b\",\ + \\"created_time\":\"2026-09-14T10:00:00.000Z\",\"last_edited_time\":\"2026-09-14T10:05:00.000Z\",\ + \\"created_by\":{\"object\":\"user\",\"id\":\"9a8b7c6d-0000-4000-8000-00000000000c\"},\ + \\"rich_text\":[{\"type\":\"text\",\"text\":{\"content\":\"Looks good\",\"link\":null},\ + \\"annotations\":{\"bold\":false,\"italic\":false,\"strikethrough\":false,\"underline\":false,\"code\":false,\"color\":\"default\"},\ + \\"plain_text\":\"Looks good\",\"href\":null}],\ + \\"display_name\":{\"type\":\"user\",\"resolved_name\":\"Tanaka Hanako\"},\ + \\"attachments\":[{\"category\":\"image\",\"file\":{\"url\":\"https://example.com/a.png\",\"expiry_time\":\"2026-09-14T11:00:00.000Z\"}}]}" + +partialCommentFixture :: LBS.ByteString +partialCommentFixture = "{\"object\":\"comment\",\"id\":\"2b0c5f7e-0000-4000-8000-000000000002\"}" + +decodeValue :: LBS.ByteString -> IO Value +decodeValue bs = either (assertFailure . ("fixture: " <>)) pure (Aeson.eitherDecode bs) + +testFullComment :: Assertion +testFullComment = + case Aeson.eitherDecode fullCommentFixture of + Right (FullComment c@CommentObject {displayName = Just CommentDisplayName {resolvedName}}) -> do + assertEqual "id" (UUID "2b0c5f7e-0000-4000-8000-000000000001") (commentResponseId (FullComment c)) + assertEqual "resolved name" (Just "Tanaka Hanako") resolvedName + Right other -> assertFailure ("expected a full comment with display name, got " <> show other) + Left err -> assertFailure err + +testPartialComment :: Assertion +testPartialComment = + case Aeson.eitherDecode partialCommentFixture of + Right (PartialComment cid) -> assertEqual "id" (UUID "2b0c5f7e-0000-4000-8000-000000000002") cid + Right other -> assertFailure ("expected PartialComment, got " <> show other) + Left err -> assertFailure err + +testBrokenFullComment :: Assertion +testBrokenFullComment = + case Aeson.eitherDecode "{\"object\":\"comment\",\"id\":\"x\",\"parent\":{\"type\":\"page_id\",\"page_id\":\"p\"}}" :: Either String CommentResponse of + Left _ -> pure () + Right r -> assertFailure ("expected a decoding failure, got " <> show r) + +testCreateOnPage :: Assertion +testCreateOnPage = + case Aeson.toJSON (mkCreateComment (PageParent (UUID "p-1")) (CommentRichText (mkRichText "Hello"))) of + Aeson.Object o -> do + assertBool "parent" (KeyMap.member "parent" o) + assertBool "rich_text" (KeyMap.member "rich_text" o) + mapM_ + (\k -> assertBool ("no " <> show k) (not (KeyMap.member k o))) + ["discussion_id", "markdown", "attachments", "display_name"] + other -> assertFailure ("expected object, got " <> show other) + +testReplyMarkdown :: Assertion +testReplyMarkdown = do + expected <- decodeValue "{\"discussion_id\":\"d-1\",\"markdown\":\"**Hi**\"}" + assertEqual "body" expected (Aeson.toJSON (mkReplyComment (UUID "d-1") (CommentMarkdown "**Hi**"))) + +testAttachmentsAndDisplayName :: Assertion +testAttachmentsAndDisplayName = do + let req = + CreateComment + { target = CommentOnParent (BlockParent (UUID "b-1")), + content = CommentMarkdown "See file", + attachments = Just (Vector.singleton (CommentAttachmentRequest (UUID "fu-1"))), + displayName = Just (DisplayAsCustom "Sato Kenji") + } + expected <- + decodeValue + "{\"parent\":{\"type\":\"block_id\",\"block_id\":\"b-1\"},\"markdown\":\"See file\",\ + \\"attachments\":[{\"file_upload_id\":\"fu-1\",\"type\":\"file_upload\"}],\ + \\"display_name\":{\"type\":\"custom\",\"custom\":{\"name\":\"Sato Kenji\"}}}" + assertEqual "body" expected (Aeson.toJSON req) + +testDisplayNames :: Assertion +testDisplayNames = do + assertEqual "integration" (Aeson.object ["type" .= ("integration" :: Text)]) (Aeson.toJSON DisplayAsIntegration) + assertEqual "user" (Aeson.object ["type" .= ("user" :: Text)]) (Aeson.toJSON DisplayAsUser) + +testUpdateBody :: Assertion +testUpdateBody = do + assertEqual "markdown" (Aeson.object ["markdown" .= ("edited" :: Text)]) (Aeson.toJSON (CommentMarkdown "edited")) + case Aeson.toJSON (CommentRichText (mkRichText "x")) of + Aeson.Object o -> assertEqual "keys" ["rich_text"] (KeyMap.keys o) + other -> assertFailure ("expected object, got " <> show other) + +testRoutes :: Assertion +testRoutes = do + (env, recorded) <- + fakeClientEnv + [jsonReply 200 fullCommentFixture, jsonReply 200 partialCommentFixture, jsonReply 200 partialCommentFixture] + let Methods {retrieveComment, updateComment, deleteComment} = makeMethods env "secret_test" + cid = UUID "2b0c5f7e-0000-4000-8000-000000000001" + retrieved <- retrieveComment cid + assertBool "retrieve decodes full" (case retrieved of FullComment _ -> True; _ -> False) + updated <- updateComment cid (CommentMarkdown "edited") + assertEqual "update id" (UUID "2b0c5f7e-0000-4000-8000-000000000002") (commentResponseId updated) + _ <- deleteComment cid + requests <- readIORef recorded + assertEqual + "methods and paths" + [ ("GET", "/comments/2b0c5f7e-0000-4000-8000-000000000001"), + ("PATCH", "/comments/2b0c5f7e-0000-4000-8000-000000000001"), + ("DELETE", "/comments/2b0c5f7e-0000-4000-8000-000000000001") + ] + (map (\Recorded {method, path} -> (method, path)) requests) diff --git a/tasty/DataSourceSearchTests.hs b/tasty/DataSourceSearchTests.hs new file mode 100644 --- /dev/null +++ b/tasty/DataSourceSearchTests.hs @@ -0,0 +1,579 @@ +-- | Data sources, databases, search, property schemas, filters and the full-row helper (EP-5). +module DataSourceSearchTests (tests) where + +import Control.Exception (try) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy.Char8 qualified as L8 +import Data.IORef (atomicModifyIORef', modifyIORef', newIORef, readIORef) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map qualified as Map +import Data.Text qualified as Text +import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds) +import Data.Time.Format.ISO8601 (iso8601ParseM) +import Data.Vector qualified as Vector +import Notion.V1.Common (Parent (..)) +import Notion.V1.DataSourceRows +import Notion.V1.DataSources +import Notion.V1.Databases (CreateDatabase (..), CreateDatabaseType (..), DatabaseObject (..), DatabaseType (..), InitialDataSource (..), PartialDatabaseObject (..)) +import Notion.V1.Filter +import Notion.V1.ListOf (IncompleteReason (..), ListOf (..), RequestStatus (..), RequestStatusType (..)) +import Notion.V1.Properties +import Notion.V1.Search (SearchFilter (..), SearchObjectType (..), SearchSort (..), SearchSortDirection) +import Notion.V1.Search qualified as Search +import Test.Tasty +import Test.Tasty.HUnit +import Prelude hiding (id) + +tests :: TestTree +tests = + testGroup + "EP-5 Data sources, databases, search, filters" + [ milestone1Tests, + milestone2Tests, + milestone3Tests, + milestone4Tests, + milestone5Tests + ] + +-- --------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------- + +decodeOrFail :: (Aeson.FromJSON a) => L8.ByteString -> IO a +decodeOrFail bs = either (assertFailure . ("decode failed: " <>)) pure (Aeson.eitherDecode bs) + +fromValueOrFail :: (Aeson.FromJSON a) => Aeson.Value -> IO a +fromValueOrFail v = case Aeson.fromJSON v of + Aeson.Success a -> pure a + Aeson.Error e -> assertFailure ("decode failed: " <> e) + +objectOf :: Aeson.Value -> IO Aeson.Object +objectOf = \case + Aeson.Object o -> pure o + other -> assertFailure ("expected object, got " <> show other) + +userJson :: Aeson.Value +userJson = Aeson.object ["object" Aeson..= ("user" :: Text.Text), "id" Aeson..= ("user-1" :: Text.Text)] + +-- | A full page with every field the page decoder requires. +pageJson :: Text.Text -> Text.Text -> Aeson.Value +pageJson pid created = + Aeson.object + [ "object" Aeson..= ("page" :: Text.Text), + "id" Aeson..= pid, + "created_time" Aeson..= created, + "last_edited_time" Aeson..= created, + "created_by" Aeson..= userJson, + "last_edited_by" Aeson..= userJson, + "cover" Aeson..= Aeson.Null, + "icon" Aeson..= Aeson.Null, + "parent" Aeson..= Aeson.object ["type" Aeson..= ("data_source_id" :: Text.Text), "data_source_id" Aeson..= ("ds-1" :: Text.Text), "database_id" Aeson..= ("db-1" :: Text.Text)], + "in_trash" Aeson..= False, + "is_locked" Aeson..= False, + "properties" Aeson..= Aeson.object [], + "url" Aeson..= ("https://www.notion.so/" <> pid), + "public_url" Aeson..= Aeson.Null + ] + +-- | A full data source with every field the data source decoder requires. +dataSourceJson :: Text.Text -> Text.Text -> Aeson.Value +dataSourceJson dsid created = + Aeson.object + [ "object" Aeson..= ("data_source" :: Text.Text), + "id" Aeson..= dsid, + "created_time" Aeson..= created, + "last_edited_time" Aeson..= created, + "created_by" Aeson..= userJson, + "last_edited_by" Aeson..= userJson, + "title" Aeson..= ([] :: [Aeson.Value]), + "description" Aeson..= ([] :: [Aeson.Value]), + "properties" Aeson..= Aeson.object [], + "parent" Aeson..= Aeson.object ["type" Aeson..= ("database_id" :: Text.Text), "database_id" Aeson..= ("db-1" :: Text.Text)], + "database_parent" Aeson..= Aeson.object ["type" Aeson..= ("page_id" :: Text.Text), "page_id" Aeson..= ("page-0" :: Text.Text)], + "is_inline" Aeson..= False, + "in_trash" Aeson..= False, + "database_type" Aeson..= ("wiki" :: Text.Text), + "icon" Aeson..= Aeson.Null, + "cover" Aeson..= Aeson.Null, + "url" Aeson..= ("https://www.notion.so/" <> dsid), + "public_url" Aeson..= Aeson.Null + ] + +databaseJson :: Aeson.Value -> Aeson.Value +databaseJson dbType = + Aeson.object + [ "object" Aeson..= ("database" :: Text.Text), + "id" Aeson..= ("db-1" :: Text.Text), + "created_time" Aeson..= ("2024-01-01T00:00:00.000Z" :: Text.Text), + "last_edited_time" Aeson..= ("2024-01-01T00:00:00.000Z" :: Text.Text), + "title" Aeson..= ([] :: [Aeson.Value]), + "url" Aeson..= ("https://www.notion.so/db-1" :: Text.Text), + "parent" Aeson..= Aeson.object ["type" Aeson..= ("page_id" :: Text.Text), "page_id" Aeson..= ("p1" :: Text.Text)], + "data_sources" Aeson..= [Aeson.object ["id" Aeson..= ("ds-1" :: Text.Text), "name" Aeson..= ("Tanaka Hanako Tasks" :: Text.Text)]], + "database_type" Aeson..= dbType + ] + +-- | A list response with the given results and the @page_or_data_source@ envelope. +queryResponse :: [Aeson.Value] -> Maybe Text.Text -> Bool -> Aeson.Value +queryResponse rows cursor incomplete = + Aeson.object $ + [ "object" Aeson..= ("list" :: Text.Text), + "type" Aeson..= ("page_or_data_source" :: Text.Text), + "page_or_data_source" Aeson..= Aeson.object [], + "results" Aeson..= rows, + "has_more" Aeson..= maybe False (const True) cursor, + "next_cursor" Aeson..= cursor + ] + <> [ "request_status" + Aeson..= Aeson.object + [ "type" Aeson..= ("incomplete" :: Text.Text), + "incomplete_reason" Aeson..= ("query_result_limit_reached" :: Text.Text) + ] + | incomplete + ] + +-- | One result of every kind, in the order full page, partial page, full data source, +-- partial data source, unknown. +everyResultKind :: [Aeson.Value] +everyResultKind = + [ pageJson "r1" "2024-01-01T00:00:00.000Z", + Aeson.object ["object" Aeson..= ("page" :: Text.Text), "id" Aeson..= ("r2" :: Text.Text)], + dataSourceJson "ds-child" "2024-01-02T00:00:00.000Z", + Aeson.object ["object" Aeson..= ("data_source" :: Text.Text), "id" Aeson..= ("ds-3" :: Text.Text), "properties" Aeson..= Aeson.object []], + Aeson.object ["object" Aeson..= ("view" :: Text.Text), "id" Aeson..= ("v1" :: Text.Text)] + ] + +resultKind :: PageOrDataSource -> String +resultKind = \case + PageResult _ -> "page" + PartialPageResult _ -> "partial page" + DataSourceResult _ -> "data_source" + PartialDataSourceResult _ -> "partial data_source" + UnknownResult _ -> "unknown" + +-- --------------------------------------------------------------------- +-- Milestone 1 +-- --------------------------------------------------------------------- + +milestone1Tests :: TestTree +milestone1Tests = + testGroup + "Milestone 1" + [ testCase "DatabaseObject decodes database_type" $ do + DatabaseObject {databaseType = t} <- fromValueOrFail (databaseJson (Aeson.String "tasks")) + t @?= Just TasksDatabase, + testCase "DatabaseObject decodes null database_type" $ do + DatabaseObject {databaseType = t} <- fromValueOrFail (databaseJson Aeson.Null) + t @?= Nothing, + testCase "DatabaseType falls back on unknown values" $ + Aeson.eitherDecode "\"roadmaps\"" @?= Right (UnknownDatabaseType "roadmaps"), + testCase "DataSourceObject decodes database_type" $ do + DataSourceObject {databaseType = t} <- fromValueOrFail (dataSourceJson "ds-9" "2024-01-01T00:00:00.000Z") + t @?= Just WikiDatabase, + testCase "CreateDatabase encodes database_type without title" $ do + o <- + objectOf $ + Aeson.toJSON + CreateDatabase + { parent = PageParent {pageId = "p1"}, + title = Nothing, + initialDataSource = Nothing, + icon = Nothing, + cover = Nothing, + description = Nothing, + isInline = Nothing, + databaseType = Just CreateTasksDatabase + } + KeyMap.lookup "database_type" o @?= Just (Aeson.String "tasks") + KeyMap.member "title" o @?= False + KeyMap.keys o @?= ["database_type", "parent"], + testCase "InitialDataSource without properties encodes as {}" $ + Aeson.toJSON (InitialDataSource {properties = Nothing}) @?= Aeson.object [], + testCase "QueryDataSource encodes result_type" $ do + o <- objectOf (Aeson.toJSON _QueryDataSource {resultType = Just ResultTypeDataSource}) + KeyMap.lookup "result_type" o @?= Just (Aeson.String "data_source"), + testCase "Query response decodes every result kind" $ do + list <- fromValueOrFail @(ListOf PageOrDataSource) (queryResponse everyResultKind Nothing False) + let rs = Vector.toList (results list) + map resultKind rs @?= ["page", "partial page", "data_source", "partial data_source", "unknown"] + map resultId rs @?= map Just ["r1", "r2", "ds-child", "ds-3", "v1"], + testCase "pageResults keeps only full pages" $ do + list <- fromValueOrFail @(ListOf PageOrDataSource) (queryResponse everyResultKind Nothing False) + Vector.length (pageResults (results list)) @?= 1 + Vector.length (dataSourceResults (results list)) @?= 1, + testCase "PartialDatabaseObject decodes" $ do + PartialDatabaseObject {id = dbId} <- decodeOrFail "{\"object\":\"database\",\"id\":\"db-2\"}" + dbId @?= "db-2" + ] + +-- --------------------------------------------------------------------- +-- Milestone 2 +-- --------------------------------------------------------------------- + +milestone2Tests :: TestTree +milestone2Tests = + testGroup + "Milestone 2" + [ testCase "SearchSort relevance encodes" $ + Aeson.toJSON SearchByRelevance @?= Aeson.object ["property" Aeson..= ("relevance" :: Text.Text)], + testCase "SearchSort last_edited_time encodes" $ + Aeson.toJSON (SearchByLastEditedTime Search.Descending) + @?= Aeson.object ["timestamp" Aeson..= ("last_edited_time" :: Text.Text), "direction" Aeson..= ("descending" :: Text.Text)], + testCase "SearchFilter object filter with in_trash" $ + Aeson.toJSON (SearchObjectFilter SearchPage (Just True)) + @?= Aeson.object ["property" Aeson..= ("object" :: Text.Text), "value" Aeson..= ("page" :: Text.Text), "in_trash" Aeson..= True], + testCase "SearchFilter standalone in_trash" $ + Aeson.toJSON (SearchInTrashFilter False) @?= Aeson.object ["in_trash" Aeson..= False], + testCase "Search response decodes typed results" $ do + list <- fromValueOrFail @(ListOf PageOrDataSource) (queryResponse everyResultKind Nothing True) + Vector.length (results list) @?= 5 + map resultKind (Vector.toList (results list)) @?= ["page", "partial page", "data_source", "partial data_source", "unknown"] + requestStatus list @?= Just RequestStatus {type_ = RequestIncomplete, incompleteReason = Just QueryResultLimitReached} + ] + +-- --------------------------------------------------------------------- +-- Milestone 3 +-- --------------------------------------------------------------------- + +-- | The value stored under @key@ in an encoded object. +lookupKey :: Aeson.Key -> Aeson.Value -> IO Aeson.Value +lookupKey key v = do + o <- objectOf v + maybe (assertFailure ("missing key " <> show key <> " in " <> show v)) pure (KeyMap.lookup key o) + +updateWithProperties :: Map.Map Text.Text PropertyUpdate -> UpdateDataSource +updateWithProperties ps = UpdateDataSource {title = Nothing, icon = Nothing, properties = Just ps, inTrash = Nothing, parent = Nothing} + +milestone3Tests :: TestTree +milestone3Tests = + testGroup + "Milestone 3" + [ testCase "Property schema decodes description" $ do + schema <- decodeOrFail "{\"id\":\"a1\",\"name\":\"Owner\",\"description\":\"Sato Kenji's column\",\"type\":\"people\",\"people\":{}}" + schemaDescription schema @?= Just "Sato Kenji's column", + testCase "Select and status options decode description" $ do + sel <- decodeOrFail "{\"id\":\"s\",\"name\":\"State\",\"description\":null,\"type\":\"select\",\"select\":{\"options\":[{\"id\":\"o1\",\"name\":\"Done\",\"color\":\"green\",\"description\":null}]}}" + case sel of + SelectSchema {selectOptions} -> + Vector.toList selectOptions @?= [SelectOption {id = Just "o1", name = "Done", color = Just Green, description = Nothing}] + other -> assertFailure ("expected SelectSchema, got " <> show other) + st <- decodeOrFail "{\"id\":\"t\",\"name\":\"Status\",\"description\":null,\"type\":\"status\",\"status\":{\"options\":[{\"id\":\"o2\",\"name\":\"Finished\",\"color\":\"blue\",\"description\":\"finished\"}],\"groups\":[{\"id\":\"g1\",\"name\":\"Complete\",\"color\":\"blue\",\"option_ids\":[\"o2\"]}]}}" + case st of + StatusSchema {statusOptions, statusGroups} -> do + fmap (\SelectOption {description} -> description) (Vector.toList statusOptions) @?= [Just "finished"] + fmap (\StatusGroup {optionIds} -> optionIds) (Vector.toList statusGroups) @?= [Vector.fromList ["o2"]] + other -> assertFailure ("expected StatusSchema, got " <> show other), + testCase "Relation schema decodes database_id" $ do + schema <- decodeOrFail "{\"id\":\"r1\",\"name\":\"Tasks\",\"description\":null,\"type\":\"relation\",\"relation\":{\"database_id\":\"db-1\",\"data_source_id\":\"ds-1\",\"type\":\"dual_property\",\"dual_property\":{\"synced_property_id\":\"sp1\",\"synced_property_name\":\"Related\"}}}" + case schema of + RelationSchema {relationDatabaseId, relationType} -> do + relationDatabaseId @?= Just "db-1" + relationType @?= DualProperty {syncedPropertyId = Just "sp1", syncedPropertyName = Just "Related"} + other -> assertFailure ("expected RelationSchema, got " <> show other), + testCase "Dual property with no synced fields encodes empty dual_property" $ do + let schema = + RelationSchema + { schemaId = "", + schemaName = "Tasks", + schemaDescription = Nothing, + relationDataSourceId = "ds-1", + relationDatabaseId = Nothing, + relationType = DualProperty {syncedPropertyId = Nothing, syncedPropertyName = Nothing} + } + relation <- lookupKey "relation" (Aeson.toJSON schema) + dual <- lookupKey "dual_property" relation + dual @?= Aeson.object [], + testCase "Status schema without groups encodes options only" $ do + let schema = + StatusSchema + { schemaId = "", + schemaName = "Status", + schemaDescription = Nothing, + statusOptions = Vector.fromList [SelectOption {id = Nothing, name = "Todo", color = Nothing, description = Nothing}], + statusGroups = Vector.empty + } + status <- lookupKey "status" (Aeson.toJSON schema) + status @?= Aeson.object ["options" Aeson..= [Aeson.object ["name" Aeson..= ("Todo" :: Text.Text)]]], + testCase "Empty schema id is omitted" $ do + o <- objectOf (Aeson.toJSON TitleSchema {schemaId = "", schemaName = "Name", schemaDescription = Nothing}) + KeyMap.member "id" o @?= False, + testCase "Location and last_visited_time schemas encode" $ do + loc <- objectOf (Aeson.toJSON LocationSchema {schemaId = "", schemaName = "Where", schemaDescription = Nothing}) + KeyMap.lookup "type" loc @?= Just (Aeson.String "location") + KeyMap.lookup "location" loc @?= Just (Aeson.object []) + lv <- objectOf (Aeson.toJSON LastVisitedTimeSchema {schemaId = "", schemaName = "Seen", schemaDescription = Just "Tanaka Hanako's last visit"}) + KeyMap.lookup "type" lv @?= Just (Aeson.String "last_visited_time") + KeyMap.lookup "last_visited_time" lv @?= Just (Aeson.object []) + KeyMap.lookup "description" lv @?= Just (Aeson.String "Tanaka Hanako's last visit"), + testCase "Unknown property type decodes to UnknownSchema" $ do + schema <- decodeOrFail "{\"id\":\"x\",\"name\":\"Mood\",\"type\":\"sentiment\",\"sentiment\":{\"scale\":5}}" + case schema of + UnknownSchema {schemaType} -> schemaType @?= "sentiment" + other -> assertFailure ("expected UnknownSchema, got " <> show other) + sentiment <- lookupKey "sentiment" (Aeson.toJSON schema) + sentiment @?= Aeson.object ["scale" Aeson..= (5 :: Int)], + testCase "UpdateDataSource rename-only property" $ + Aeson.toJSON (updateWithProperties (Map.fromList [("Old", RenameProperty "New")])) + @?= Aeson.object ["properties" Aeson..= Aeson.object ["Old" Aeson..= Aeson.object ["name" Aeson..= ("New" :: Text.Text)]]], + testCase "UpdateDataSource select option targeted by id" $ do + let update = + UpdateSelectOptions + { newName = Nothing, + optionUpdates = Vector.fromList [OptionUpdate (OptionWithId "o1" Nothing) (Just Red) (Just "urgent")] + } + Aeson.toJSON update + @?= Aeson.object + [ "select" + Aeson..= Aeson.object + [ "options" + Aeson..= [ Aeson.object + [ "id" Aeson..= ("o1" :: Text.Text), + "color" Aeson..= ("red" :: Text.Text), + "description" Aeson..= ("urgent" :: Text.Text) + ] + ] + ] + ] + ] + +-- --------------------------------------------------------------------- +-- Milestone 4 +-- --------------------------------------------------------------------- + +jsonValue :: L8.ByteString -> Aeson.Value +jsonValue bs = either error (\v -> v) (Aeson.eitherDecode bs) + +-- | Filters covering every condition constructor, including the EP-5 additions. +everyFilter :: [Filter] +everyFilter = + [ And + [ PropertyFilter "Name" (TitleCondition (TextContains "Tanaka")), + Or + [ PropertyFilter "Notes" (RichTextCondition (TextDoesNotContain "draft")), + PropertyFilter "Phone" (PhoneNumberCondition TextIsNotEmpty) + ] + ], + TimestampFilter FilterCreatedTime (DateOnOrAfter "2024-01-04T00:00:00Z"), + TimestampFilter FilterLastEditedTime DatePastWeek, + PropertyFilter "Estimate" (NumberCondition (NumLessThanOrEqualTo 8)), + PropertyFilter "Done" (CheckboxCondition (CheckboxEquals True)), + PropertyFilter "Priority" (SelectCondition (SelectEquals "High")), + PropertyFilter "Priority" (SelectCondition (SelectEqualsAny ("High" :| ["Medium"]))), + PropertyFilter "Priority" (SelectCondition (SelectDoesNotEqualAny ("Low" :| []))), + PropertyFilter "Priority" (SelectCondition SelectIsEmpty), + PropertyFilter "Tags" (MultiSelectCondition (MultiSelectContains "urgent")), + PropertyFilter "Tags" (MultiSelectCondition (MultiSelectContainsAny ("urgent" :| ["home"]))), + PropertyFilter "Tags" (MultiSelectCondition (MultiSelectDoesNotContainAny ("work" :| []))), + PropertyFilter "Stage" (StatusCondition (StatusDoesNotEqual "Done")), + PropertyFilter "Stage" (StatusCondition (StatusEqualsAny ("Todo" :| ["Doing"]))), + PropertyFilter "Stage" (StatusCondition (StatusDoesNotEqualAny ("Done" :| ["Archived"]))), + PropertyFilter "Due" (DateCondition (DateBefore (relativeDate Tomorrow))), + PropertyFilter "Owner" (PeopleCondition (PeopleContains "user-1")), + PropertyFilter "Attachments" (FilesCondition FilesIsNotEmpty), + PropertyFilter "Project" (RelationCondition (RelationContains "page-1")), + PropertyFilter "Ticket" (UniqueIdCondition (UniqueIdGreaterThan 2.5)), + PropertyFilter "Ticket" (UniqueIdCondition UniqueIdIsEmpty), + PropertyFilter "Ticket" (UniqueIdCondition UniqueIdIsNotEmpty), + PropertyFilter "Reviewed" (VerificationCondition (VerificationStatus VerificationVerified)), + PropertyFilter "Reviewed" (VerificationCondition (VerificationDoesNotEqual VerificationExpired)), + PropertyFilter "Score" (FormulaCondition (FormulaString (TextStartsWith "A"))), + PropertyFilter "Score" (FormulaCondition (FormulaCheckbox (CheckboxDoesNotEqual False))), + PropertyFilter "Score" (FormulaCondition (FormulaDate DateThisMonth)), + PropertyFilter "Tasks" (RollupCondition (RollupAny (SelectCondition (SelectEquals "Done")))), + PropertyFilter "Tasks" (RollupCondition (RollupEvery (StatusCondition StatusIsNotEmpty))), + PropertyFilter "Tasks" (RollupCondition (RollupNone (NumberCondition (NumEquals 0)))), + PropertyFilter "Tasks" (RollupCondition (RollupDate DateIsEmpty)), + PropertyFilter "Created" (CreatedTimeCondition DateNextYear), + PropertyFilter "Author" (CreatedByCondition (PeopleDoesNotContain "user-2")), + PropertyFilter "Edited" (LastEditedTimeCondition (DateEquals "2024-01-01")), + PropertyFilter "Editor" (LastEditedByCondition PeopleIsNotEmpty), + PropertyFilter "Site" (UrlCondition (TextEquals "https://example.jp")), + PropertyFilter "Email" (EmailCondition (TextEndsWith "@example.jp")) + ] + +milestone4Tests :: TestTree +milestone4Tests = + testGroup + "Milestone 4" + [ testCase "Verification does_not_equal encodes" $ + Aeson.toJSON (PropertyFilter "Reviewed" (VerificationCondition (VerificationDoesNotEqual VerificationExpired))) + @?= jsonValue "{\"property\":\"Reviewed\",\"verification\":{\"does_not_equal\":\"expired\"}}", + testCase "Select equals array encodes" $ + Aeson.toJSON (PropertyFilter "Priority" (SelectCondition (SelectEqualsAny ("High" :| ["Medium"])))) + @?= jsonValue "{\"property\":\"Priority\",\"select\":{\"equals\":[\"High\",\"Medium\"]}}", + testCase "Status and multi_select array variants encode" $ do + Aeson.toJSON (PropertyFilter "Stage" (StatusCondition (StatusDoesNotEqualAny ("Done" :| ["Archived"])))) + @?= jsonValue "{\"property\":\"Stage\",\"status\":{\"does_not_equal\":[\"Done\",\"Archived\"]}}" + Aeson.toJSON (PropertyFilter "Tags" (MultiSelectCondition (MultiSelectContainsAny ("urgent" :| ["home"])))) + @?= jsonValue "{\"property\":\"Tags\",\"multi_select\":{\"contains\":[\"urgent\",\"home\"]}}", + testCase "unique_id is_empty and fractional numbers encode" $ do + Aeson.toJSON (PropertyFilter "Ticket" (UniqueIdCondition UniqueIdIsEmpty)) + @?= jsonValue "{\"property\":\"Ticket\",\"unique_id\":{\"is_empty\":true}}" + Aeson.toJSON (PropertyFilter "Ticket" (UniqueIdCondition (UniqueIdGreaterThan 2.5))) + @?= jsonValue "{\"property\":\"Ticket\",\"unique_id\":{\"greater_than\":2.5}}", + testCase "relativeDate renders keywords" $ do + Aeson.toJSON (PropertyFilter "Due" (DateCondition (DateOnOrAfter (relativeDate OneWeekAgo)))) + @?= jsonValue "{\"property\":\"Due\",\"date\":{\"on_or_after\":\"one_week_ago\"}}" + map relativeDate [minBound .. maxBound] + @?= ["today", "tomorrow", "yesterday", "one_week_ago", "one_week_from_now", "one_month_ago", "one_month_from_now"], + testCase "Filter FromJSON round-trips every constructor" $ + mapM_ (\f -> Aeson.fromJSON (Aeson.toJSON f) @?= Aeson.Success f) everyFilter, + testCase "Filter FromJSON accepts optional type discriminator" $ + Aeson.fromJSON (jsonValue "{\"property\":\"Name\",\"type\":\"title\",\"title\":{\"contains\":\"Tanaka\"}}") + @?= Aeson.Success (PropertyFilter "Name" (TitleCondition (TextContains "Tanaka"))), + testCase "Unknown filter shapes fall back" $ do + Aeson.fromJSON (jsonValue "{\"property\":\"Mood\",\"sentiment\":{\"equals\":\"happy\"}}") + @?= Aeson.Success (PropertyFilter "Mood" (UnknownCondition "sentiment" (jsonValue "{\"equals\":\"happy\"}"))) + Aeson.fromJSON (jsonValue "{\"property\":\"Priority\",\"select\":{\"resembles\":\"High\"}}") + @?= Aeson.Success (PropertyFilter "Priority" (UnknownCondition "select" (jsonValue "{\"resembles\":\"High\"}"))) + let weird = jsonValue "{\"weird\":1}" + Aeson.fromJSON weird @?= Aeson.Success (UnknownFilter weird) + Aeson.toJSON (UnknownFilter weird) @?= weird, + testCase "Sort FromJSON round-trips and falls back" $ do + mapM_ + (\srt -> Aeson.fromJSON (Aeson.toJSON srt) @?= Aeson.Success srt) + [PropertySort "Due" Ascending, TimestampSort FilterCreatedTime Descending] + let sideways = jsonValue "{\"property\":\"X\",\"direction\":\"sideways\"}" + Aeson.fromJSON sideways @?= Aeson.Success (UnknownSort sideways) + ] + +-- --------------------------------------------------------------------- +-- Milestone 5 +-- --------------------------------------------------------------------- + +-- | A query function replaying the given response bodies, plus an action returning the JSON of +-- every request sent so far. +fakeQuery :: [Aeson.Value] -> IO (QueryDataSource -> IO (ListOf PageOrDataSource), IO [Aeson.Value]) +fakeQuery bodies = do + queue <- newIORef bodies + sent <- newIORef [] + let run req = do + modifyIORef' sent (Aeson.toJSON req :) + next <- atomicModifyIORef' queue (\case (b : bs) -> (bs, b); [] -> ([], Aeson.Null)) + case Aeson.fromJSON next of + Aeson.Success l -> pure l + Aeson.Error e -> assertFailure ("fake response did not decode: " <> e) + pure (run, reverse <$> readIORef sent) + +posix :: String -> POSIXTime +posix str = maybe (error ("bad time " <> str)) utcTimeToPOSIXSeconds (iso8601ParseM str) + +day :: Int -> Text.Text +day n = "2024-01-0" <> Text.pack (show n) <> "T00:00:00.000Z" + +row :: Text.Text -> Int -> Aeson.Value +row rid n = pageJson rid (day n) + +boundJson :: Text.Text -> Aeson.Value +boundJson start = + Aeson.object + [ "timestamp" Aeson..= ("created_time" :: Text.Text), + "created_time" Aeson..= Aeson.object ["on_or_after" Aeson..= start] + ] + +statusDone :: PropertyCondition +statusDone = StatusCondition (StatusEquals "Done") + +statusDoneJson :: Aeson.Value +statusDoneJson = jsonValue "{\"property\":\"Status\",\"status\":{\"equals\":\"Done\"}}" + +idsOf :: Vector.Vector PageOrDataSource -> [Maybe Text.Text] +idsOf = map resultId . Vector.toList + +-- | Visit every row with 'iterateAllDataSourceRows', returning the visited ids and the requests. +runIterate :: Maybe AllRowsFilter -> [Aeson.Value] -> IO ([Maybe Text.Text], [Aeson.Value]) +runIterate mFilter bodies = do + (run, sentRequests) <- fakeQuery bodies + visited <- newIORef [] + iterateAllDataSourceRows run _QueryDataSource mFilter (\r -> modifyIORef' visited (resultId r :)) + (,) <$> (reverse <$> readIORef visited) <*> sentRequests + +lookupMaybe :: Aeson.Key -> Aeson.Value -> Maybe Aeson.Value +lookupMaybe key = \case + Aeson.Object o -> KeyMap.lookup key o + _ -> Nothing + +milestone5Tests :: TestTree +milestone5Tests = + testGroup + "Milestone 5" + [ testCase "createdTimeLowerBound: first window returns caller filter" $ + createdTimeLowerBound (Just (AllRowsPropertyFilter "Status" statusDone)) Nothing + @?= Just (PropertyFilter "Status" statusDone), + testCase "createdTimeLowerBound: no caller filter returns bound" $ + Aeson.toJSON (createdTimeLowerBound Nothing (Just (posix "2024-01-04T00:00:00Z"))) + @?= boundJson "2024-01-04T00:00:00Z", + testCase "createdTimeLowerBound: and filter gets bound appended" $ do + let a = PropertyFilter "Status" statusDone + t = posix "2024-01-04T00:00:00Z" + createdTimeLowerBound (Just (AllRowsAnd [a])) (Just t) + @?= Just (And [a, TimestampFilter FilterCreatedTime (DateOnOrAfter "2024-01-04T00:00:00Z")]), + testCase "createdTimeLowerBound: property filter is wrapped in and" $ + createdTimeLowerBound (Just (AllRowsPropertyFilter "Status" statusDone)) (Just (posix "2024-01-04T00:00:00Z")) + @?= Just (And [PropertyFilter "Status" statusDone, TimestampFilter FilterCreatedTime (DateOnOrAfter "2024-01-04T00:00:00Z")]), + testCase "iterateAllDataSourceRows: single complete window" $ do + (ids, sent) <- runIterate Nothing [queryResponse [row "r1" 1, row "r2" 2] Nothing False] + ids @?= map Just ["r1", "r2"] + req <- case sent of + [r] -> pure r + _ -> assertFailure ("expected one request, got " <> show (length sent)) + lookupMaybe "sorts" req @?= Just (jsonValue "[{\"timestamp\":\"created_time\",\"direction\":\"ascending\"}]") + lookupMaybe "filter" req @?= Nothing + lookupMaybe "start_cursor" req @?= Nothing, + testCase "iterateAllDataSourceRows: advances past the limit and de-duplicates" $ do + (ids, sent) <- + runIterate + Nothing + [ queryResponse [row "r1" 1, row "r2" 2] (Just "c1") False, + queryResponse [row "r3" 3, row "r4" 4] Nothing True, + queryResponse [row "r4" 4, row "r5" 5] Nothing False + ] + ids @?= map Just ["r1", "r2", "r3", "r4", "r5"] + length sent @?= 3 + lookupMaybe "start_cursor" (sent !! 1) @?= Just (Aeson.String "c1") + lookupMaybe "start_cursor" (sent !! 2) @?= Nothing + lookupMaybe "filter" (sent !! 2) @?= Just (boundJson "2024-01-04T00:00:00Z"), + testCase "iterateAllDataSourceRows: combines caller filter with and" $ do + (ids, sent) <- + runIterate + (Just (AllRowsPropertyFilter "Status" statusDone)) + [ queryResponse [row "r1" 1] Nothing True, + queryResponse [row "r1" 1, row "r2" 2] Nothing False + ] + ids @?= map Just ["r1", "r2"] + map (lookupMaybe "filter") sent + @?= [ Just statusDoneJson, + Just (Aeson.object ["and" Aeson..= [statusDoneJson, boundJson "2024-01-01T00:00:00Z"]]) + ], + testCase "iterateAllDataSourceRows: advances on a data-source boundary row" $ do + (ids, sent) <- + runIterate + Nothing + [ queryResponse [row "r1" 1, dataSourceJson "ds-child" (day 2)] Nothing True, + queryResponse [dataSourceJson "ds-child" (day 2), row "r2" 3] Nothing False + ] + ids @?= map Just ["r1", "ds-child", "r2"] + length sent @?= 2 + lookupMaybe "filter" (sent !! 1) @?= Just (boundJson "2024-01-02T00:00:00Z"), + testCase "collectAllDataSourceRows: cannot make progress throws" $ do + (run, _) <- + fakeQuery + [ queryResponse [row "r1" 1, row "r2" 1] Nothing True, + queryResponse [row "r1" 1, row "r2" 1] Nothing True + ] + result <- try @DataSourceRowsError (collectAllDataSourceRows run _QueryDataSource Nothing) + case result of + Left err@(CannotMakeProgress t) -> do + t @?= Just (posix "2024-01-01T00:00:00Z") + assertBool "show is non-empty" (not (null (show err))) + Right rows -> assertFailure ("expected CannotMakeProgress, got " <> show (idsOf rows)), + testCase "collectAllDataSourceRows: collects across windows" $ do + (run, _) <- + fakeQuery + [ queryResponse [row "r1" 1] Nothing True, + queryResponse [row "r1" 1, row "r2" 2] Nothing False + ] + rows <- collectAllDataSourceRows run _QueryDataSource Nothing + idsOf rows @?= map Just ["r1", "r2"] + ] diff --git a/tasty/FakeNotion.hs b/tasty/FakeNotion.hs new file mode 100644 --- /dev/null +++ b/tasty/FakeNotion.hs @@ -0,0 +1,74 @@ +-- | A scripted stand-in for the Notion API that never touches the network. +-- +-- 'fakeClientEnv' builds a 'ClientEnv' whose middleware ignores the real HTTP +-- application, records every request, and answers from a list of replies. +module FakeNotion + ( Recorded (..), + FakeReply (..), + fakeClientEnv, + fakeBaseUrl, + jsonReply, + lookupRecordedHeader, + ) +where + +import Control.Monad.Error.Class (throwError) +import Control.Monad.IO.Class (liftIO) +import Data.Bifunctor (bimap) +import Data.ByteString qualified as BS +import Data.ByteString.Builder (toLazyByteString) +import Data.ByteString.Lazy qualified as LBS +import Data.Foldable (toList) +import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef) +import Network.HTTP.Client (defaultManagerSettings, newManager) +import Network.HTTP.Types (Header, HeaderName, Method, http11, mkStatus) +import Servant.Client (BaseUrl (..), ClientEnv (..), ClientError (..), Scheme (..), mkClientEnv) +import Servant.Client.Core (RequestF (..), ResponseF (..)) + +-- | A request the fake received. +data Recorded = Recorded + { method :: Method, + path :: LBS.ByteString, + headers :: [Header] + } + deriving stock (Show) + +-- | A scripted reply. +data FakeReply = FakeReply + { status :: Int, + replyHeaders :: [Header], + body :: LBS.ByteString + } + +-- | A reply with a JSON content type. +jsonReply :: Int -> LBS.ByteString -> FakeReply +jsonReply s = FakeReply s [("Content-Type", "application/json")] + +fakeBaseUrl :: BaseUrl +fakeBaseUrl = BaseUrl Https "api.notion.com" 443 "/v1" + +-- | First value of a header in a recorded request. +lookupRecordedHeader :: HeaderName -> Recorded -> Maybe BS.ByteString +lookupRecordedHeader name Recorded {headers} = lookup name headers + +-- | A 'ClientEnv' answering from the script, and the requests it records. +fakeClientEnv :: [FakeReply] -> IO (ClientEnv, IORef [Recorded]) +fakeClientEnv script = do + manager <- newManager defaultManagerSettings + remaining <- newIORef script + recorded <- newIORef [] + let mw _realApp req = do + liftIO $ + modifyIORef' + recorded + (<> [Recorded (requestMethod req) (toLazyByteString (requestPath req)) (toList (requestHeaders req))]) + next <- liftIO $ atomicModifyIORef' remaining (\case [] -> ([], Nothing); r : rs -> (rs, Just r)) + FakeReply {status, replyHeaders, body} <- + maybe (liftIO (ioError (userError "FakeNotion: script exhausted"))) pure next + let resp = Response (mkStatus status "") (foldMap pure replyHeaders) http11 body + if status >= 200 && status < 300 + then pure resp + else + throwError + (FailureResponse (bimap (const ()) (\p -> (fakeBaseUrl, LBS.toStrict (toLazyByteString p))) req) resp) + pure ((mkClientEnv manager fakeBaseUrl) {middleware = mw}, recorded) diff --git a/tasty/HelpersTests.hs b/tasty/HelpersTests.hs new file mode 100644 --- /dev/null +++ b/tasty/HelpersTests.hs @@ -0,0 +1,55 @@ +-- | Tests for URL helpers and pagination folds. +module HelpersTests (tests) where + +import Data.IORef (modifyIORef', newIORef, readIORef) +import Data.Vector qualified as Vector +import Notion.V1.Common (UUID (..)) +import Notion.V1.Helpers +import Notion.V1.ListOf (ListOf (..)) +import Notion.V1.Pagination (paginateFoldM) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Helpers" + [ testCase "hyphenated UUID is lowercased" $ + extractNotionId "12345678-1234-1234-1234-123456789ABC" @?= Just (UUID "12345678-1234-1234-1234-123456789abc"), + testCase "32 hex digits are formatted" $ + extractNotionId "12345678123412341234123456789abc" @?= Just (UUID "12345678-1234-1234-1234-123456789abc"), + testCase "page URL with a title slug" $ + extractNotionId "https://www.notion.so/tanaka/Meeting-Notes-abc123def456789012345678901234ab" + @?= Just (UUID "abc123de-f456-7890-1234-5678901234ab"), + testCase "database URL prefers the path ID over the view ID" $ + extractDatabaseId "https://www.notion.so/tanaka/Tasks-abc123def456789012345678901234ab?v=0123456789abcdef0123456789abcdef" + @?= Just (UUID "abc123de-f456-7890-1234-5678901234ab"), + testCase "query parameter beats the last-resort rule" $ + extractNotionId "https://www.notion.so/tanaka?v=11111111111111111111111111111111&p=22222222222222222222222222222222" + @?= Just (UUID "22222222-2222-2222-2222-222222222222"), + testCase "last resort finds any 32 hex digits" $ + extractNotionId "notion.so/ffffffffffffffffffffffffffffffff" @?= Just (UUID "ffffffff-ffff-ffff-ffff-ffffffffffff"), + testCase "non-IDs give Nothing" $ do + extractNotionId "not-an-id" @?= Nothing + extractNotionId "" @?= Nothing, + testCase "extractBlockId reads the fragment" $ do + extractBlockId (pageUrl <> "#block-fedcba9876543210fedcba9876543210") @?= Just (UUID "fedcba98-7654-3210-fedc-ba9876543210") + extractBlockId (pageUrl <> "#fedcba9876543210fedcba9876543210") @?= Just (UUID "fedcba98-7654-3210-fedc-ba9876543210") + extractBlockId pageUrl @?= Nothing, + testCase "extractPageId on a block URL gives the page ID" $ + extractPageId (pageUrl <> "#block-fedcba9876543210fedcba9876543210") @?= Just (UUID "01234567-89ab-cdef-0123-456789abcdef"), + testCase "paginateFoldM sums across pages" $ do + calls <- newIORef (0 :: Int) + let page rs cursor more = List {results = Vector.fromList rs, nextCursor = cursor, hasMore = more, type_ = Nothing, object = Nothing, requestStatus = Nothing} + fetch cursor = do + modifyIORef' calls (+ 1) + pure $ case cursor of + Nothing -> page [1 :: Int, 2, 3] (Just "cursor-1") True + Just "cursor-1" -> page [4, 5] (Just "cursor-2") True + _ -> page [6] Nothing False + total <- paginateFoldM (\acc x -> pure (acc + x)) 0 fetch + total @?= 21 + readIORef calls >>= (@?= 3) + ] + where + pageUrl = "https://www.notion.so/Page-0123456789abcdef0123456789abcdef" diff --git a/tasty/Main.hs b/tasty/Main.hs --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -1,5 +1,7 @@ module Main where +import AsyncTaskTests qualified +import CommentTests qualified import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap @@ -9,13 +11,16 @@ import Data.Scientific (Scientific) import Data.Text qualified as Text import Data.Vector qualified as Vector +import DataSourceSearchTests qualified +import HelpersTests qualified +import MeetingNotesTests qualified import Notion.V1 import Notion.V1.BlockContent (BlockContent (..), CodeLanguage (..), FileSource (..), SyncedFrom (..), blockContentType, bookmarkBlock, bulletedListItemBlock, calloutBlock, codeBlock, dividerBlock, headingBlock, imageBlock, mkRichText, numberedListItemBlock, paragraphBlock, quoteBlock, textBlock, toDoBlock, toggleBlock, withChildren) import Notion.V1.Blocks (AppendBlockChildren (..), BlockObject (..), Position (..)) import Notion.V1.Blocks qualified as Blocks -import Notion.V1.Comments (CommentAttachment (..), CommentDisplayName (..), CommentObject (..), CreateComment (..)) +import Notion.V1.Comments (CommentAttachment (..), CommentAttachmentRequest (..), CommentContent (..), CommentDisplayName (..), CommentDisplayNameRequest (..), CommentResponse (..), CommentTarget (..), CreateComment (..)) import Notion.V1.Comments qualified as Comments -import Notion.V1.Common (Color (..), Cover (..), ExternalFile (..), Icon (..), Parent (..), UUID (..)) +import Notion.V1.Common (Color (..), Cover (..), CustomEmojiRef (..), ExternalFile (..), Icon (..), NoticonColor (..), Parent (..), UUID (..)) import Notion.V1.CustomEmojis (CustomEmoji (..)) import Notion.V1.DataSources (DataSourceObject (..)) import Notion.V1.DataSources qualified as DataSources @@ -30,6 +35,7 @@ ( ContentUpdate (..), CreatePage (..), MovePage (..), + MovePageParent (..), PageMarkdown (..), PageObject (..), ReplaceContentRequest (..), @@ -37,6 +43,7 @@ UpdateContentRequest (..), UpdatePage (..), UpdatePageMarkdown (..), + UpdatePageTemplate (..), mkCreatePage, mkUpdatePage, ) @@ -45,13 +52,19 @@ import Notion.V1.PropertyValue qualified as PV import Notion.V1.RichText (Annotations (..), Date (..), MentionContent (..), RichText (..), RichTextContent (..), TextContent (..), defaultAnnotations) import Notion.V1.RichText qualified as RT -import Notion.V1.Search (SearchRequest (..), SearchResult (..), dataSourceFilter, pageFilter, parseSearchResults) +import Notion.V1.Search (PageOrDataSource (..), SearchRequest (..), dataSourceFilter, pageFilter) import Notion.V1.Users (BotUser (..), UserObject (..), WorkspaceLimits (..)) -import Notion.V1.Views (CreateView (..), QueryView (..), UpdateView (..), ViewObject (..), ViewType (..)) +import Notion.V1.Views (Clearable (..), CreateView (..), UpdateView (..), ViewObject (..), ViewType (..)) +import Notion.V1.Views qualified as Views +import OAuthTests qualified +import ObjectFieldTests qualified +import RuntimeTests qualified import System.Environment qualified as Environment import Test.Tasty import Test.Tasty.HUnit +import ViewTests qualified import Web.HttpApiData (toQueryParam) +import WireFormatTests qualified main :: IO () main = do @@ -162,6 +175,16 @@ jsonSerializationTests, propertyValueTests, fileUploadTests, + CommentTests.tests, + AsyncTaskTests.tests, + MeetingNotesTests.tests, + WireFormatTests.tests, + ObjectFieldTests.tests, + RuntimeTests.tests, + OAuthTests.tests, + HelpersTests.tests, + ViewTests.tests, + DataSourceSearchTests.tests, basicIntegration, markdownE2E, pageE2E, @@ -211,8 +234,8 @@ inTrash = Just True, isLocked = Nothing, isArchived = Nothing, - icon = Nothing, - cover = Nothing, + icon = Unset, + cover = Unset, template = Nothing, eraseContent = Nothing } @@ -585,17 +608,16 @@ testBlockUpdateWithChildren :: Assertion testBlockUpdateWithChildren = do let block = toggleBlock (mkRichText "T") `withChildren` Vector.singleton (textBlock "C") - update = Blocks.BlockUpdate block - json = Aeson.toJSON update - case json of + update <- maybe (assertFailure "toggle blocks are updatable") (pure . Blocks.mkBlockUpdate) (Blocks.blockUpdateFromContent block) + case Aeson.toJSON update of Aeson.Object o -> do assertBool "should have 'toggle' key" (KeyMap.member "toggle" o) assertBool "should NOT have 'type' key" (not $ KeyMap.member "type" o) case KeyMap.lookup "toggle" o of Just (Aeson.Object inner) -> - assertBool "update should include 'children' key" (KeyMap.member "children" inner) + assertBool "update must not include 'children' key" (not $ KeyMap.member "children" inner) _ -> assertFailure "Expected toggle object in update" - _ -> assertFailure "Expected object from BlockUpdate ToJSON" + _ -> assertFailure "Expected object from BlockUpdatePayload ToJSON" testParseBlockContentWithChildren :: Assertion testParseBlockContentWithChildren = do @@ -622,13 +644,13 @@ testBlockUpdateSerialization :: Assertion testBlockUpdateSerialization = do - let update = Blocks.BlockUpdate (paragraphBlock (mkRichText "Updated")) + let update = Blocks.mkBlockUpdate (Blocks.UpdateParagraph (Blocks.ParagraphUpdate (Just (mkRichText "Updated")) Nothing Nothing)) json = Aeson.toJSON update case json of Aeson.Object o -> do assertBool "should have 'paragraph' key" (KeyMap.member "paragraph" o) assertBool "should NOT have 'type' key" (not $ KeyMap.member "type" o) - _ -> assertFailure "Expected object from BlockUpdate ToJSON" + _ -> assertFailure "Expected object from BlockUpdatePayload ToJSON" -- ===================================================================== -- JSON Serialization Tests (unit tests, no API token needed) @@ -811,7 +833,7 @@ testNativeIconRoundTrip :: Assertion testNativeIconRoundTrip = do - let icon = NativeIcon {iconName = "check", iconColor = Just "green"} + let icon = NativeIcon {iconName = "check", iconColor = Just NoticonGreen} json = Aeson.toJSON icon case json of Aeson.Object o -> do @@ -825,7 +847,7 @@ case Aeson.fromJSON json of Aeson.Success (NativeIcon n c) -> do assertEqual "name round-trip" "check" n - assertEqual "color round-trip" (Just "green") c + assertEqual "color round-trip" (Just NoticonGreen) c Aeson.Success _ -> assertFailure "Expected NativeIcon" Aeson.Error err -> assertFailure $ "Decode failed: " <> err @@ -836,22 +858,26 @@ case Aeson.eitherDecode payload of Right (NativeIcon n c) -> do assertEqual "name" "clipping" n - assertEqual "color" (Just "lightgray") c + assertEqual "color" (Just NoticonLightgray) c Right _ -> assertFailure "Expected NativeIcon" Left err -> assertFailure $ "Decode failed: " <> err testCustomEmojiIconRoundTrip :: Assertion testCustomEmojiIconRoundTrip = do - let icon = CustomEmojiIcon {customEmojiId = UUID "emoji-abc-123"} + let icon = CustomEmojiIcon {customEmoji = CustomEmojiRef (UUID "emoji-abc-123") Nothing Nothing} json = Aeson.toJSON icon case json of Aeson.Object o -> do assertEqual "type" (Just (Aeson.String "custom_emoji")) (KeyMap.lookup "type" o) - assertEqual "id" (Just (Aeson.String "emoji-abc-123")) (KeyMap.lookup "id" o) + assertEqual "no top-level id" Nothing (KeyMap.lookup "id" o) + assertEqual + "custom_emoji" + (Just (Aeson.object ["id" Aeson..= ("emoji-abc-123" :: Text.Text)])) + (KeyMap.lookup "custom_emoji" o) _ -> assertFailure "Expected JSON object" case Aeson.fromJSON json of - Aeson.Success (CustomEmojiIcon eid) -> - assertEqual "id round-trip" (UUID "emoji-abc-123") eid + Aeson.Success (CustomEmojiIcon ref) -> + assertEqual "id round-trip" (CustomEmojiRef (UUID "emoji-abc-123") Nothing Nothing) ref Aeson.Success _ -> assertFailure "Expected CustomEmojiIcon" Aeson.Error err -> assertFailure $ "Decode failed: " <> err @@ -871,7 +897,7 @@ testSerializeMovePage :: Assertion testSerializeMovePage = do - let req = MovePage {parent = PageParent {pageId = UUID "target-page"}, position = Nothing} + let req = MovePage {parent = MoveToPage (UUID "target-page")} json = Aeson.toJSON req case json of Aeson.Object o -> do @@ -891,8 +917,10 @@ filter = Nothing, sorts = Nothing, quickFilters = Nothing, + createDatabase_ = Nothing, configuration = Nothing, - position = Nothing + position = Nothing, + placement = Nothing } json = Aeson.toJSON req case json of @@ -911,9 +939,9 @@ let req = UpdateView { name = Just "Renamed View", - filter = Nothing, - sorts = Nothing, - quickFilters = Nothing, + filter = Unset, + sorts = Unset, + quickFilters = Unset, configuration = Nothing } json = Aeson.toJSON req @@ -929,7 +957,7 @@ testSerializeCreatePageMarkdown = do let req = CreatePage - { parent = PageParent {pageId = UUID "p-1"}, + { parent = Just (PageParent {pageId = UUID "p-1"}), properties = Map.empty, children = Nothing, markdown = Just "# Hello\n\nWorld", @@ -954,9 +982,9 @@ inTrash = Nothing, isLocked = Nothing, isArchived = Nothing, - icon = Nothing, - cover = Nothing, - template = Just (DefaultTemplate (Just "America/Chicago")), + icon = Unset, + cover = Unset, + template = Just (UpdateDefaultTemplate (Just "America/Chicago")), eraseContent = Just True } json = Aeson.toJSON req @@ -998,22 +1026,22 @@ testSearchPages Methods {search} = do let params = SearchRequest {query = Nothing, sort = Nothing, filter = Just pageFilter, startCursor = Nothing, pageSize = Just 3} result <- search params - let typed = parseSearchResults result - -- All results should be PageResult - Vector.forM_ typed $ \r -> + -- All results should be full or partial pages + Vector.forM_ (results result) $ \r -> case r of PageResult _ -> pure () - DataSourceResult _ -> assertFailure "Expected only page results with page filter" + PartialPageResult _ -> pure () + _ -> assertFailure "Expected only page results with page filter" testSearchDataSources :: Methods -> Assertion testSearchDataSources Methods {search} = do let params = SearchRequest {query = Nothing, sort = Nothing, filter = Just dataSourceFilter, startCursor = Nothing, pageSize = Just 3} result <- search params - let typed = parseSearchResults result - Vector.forM_ typed $ \r -> + Vector.forM_ (results result) $ \r -> case r of DataSourceResult _ -> pure () - PageResult _ -> assertFailure "Expected only data source results with data source filter" + PartialDataSourceResult _ -> pure () + _ -> assertFailure "Expected only data source results with data source filter" testListCustomEmojis :: Methods -> Assertion testListCustomEmojis Methods {listCustomEmojis} = do @@ -1154,7 +1182,7 @@ -- | Create page, add comments (page-level and block-level), list them. testCommentLifecycle :: Methods -> Text.Text -> Assertion -testCommentLifecycle methods@Methods {createComment, listComments, appendBlockChildren} parentPageId = do +testCommentLifecycle methods@Methods {createComment, listComments, appendBlockChildren, retrieveComment, updateComment, deleteComment} parentPageId = do -- Create a test page page <- createTestPage methods parentPageId "Comment Lifecycle E2E Test" let PageObject {id = pageId} = page @@ -1167,28 +1195,20 @@ -- Create a page-level comment let pageComment = - CreateComment - { parent = PageParent {pageId}, - richText = Vector.singleton (mkTypedRichText "This is a page-level comment from E2E tests."), - discussionId = Nothing, - attachments = Nothing, - displayName = Nothing - } + Comments.mkCreateComment + PageParent {pageId} + (CommentRichText (Vector.singleton (mkTypedRichText "This is a page-level comment from E2E tests."))) comment1 <- createComment pageComment - let CommentObject {id = comment1Id} = comment1 + let comment1Id = Comments.commentResponseId comment1 assertBool "Comment should have an ID" (show comment1Id /= "") -- Create a block-level comment (a discussion on a specific block) let blockComment = - CreateComment - { parent = BlockParent {blockId}, - richText = Vector.singleton (mkTypedRichText "This is a block-level comment from E2E tests."), - discussionId = Nothing, - attachments = Nothing, - displayName = Nothing - } + Comments.mkCreateComment + BlockParent {blockId} + (CommentRichText (Vector.singleton (mkTypedRichText "This is a block-level comment from E2E tests."))) comment2 <- createComment blockComment - let CommentObject {id = comment2Id} = comment2 + let comment2Id = Comments.commentResponseId comment2 assertBool "Block comment should have an ID" (show comment2Id /= "") -- List comments on the page @@ -1199,6 +1219,23 @@ blockComments <- listComments (Just blockId) Nothing Nothing assertBool "Should have at least 1 block comment" (not $ Vector.null (results blockComments)) + -- Retrieve a single comment + retrieved <- retrieveComment comment1Id + assertEqual "Retrieved comment id" comment1Id (Comments.commentResponseId retrieved) + + -- Edit the comment with Markdown + edited <- updateComment comment1Id (CommentMarkdown "Edited by **E2E** tests.") + case edited of + FullComment Comments.CommentObject {richText} -> + assertBool + "Edited comment text" + (any (\RichText {plainText} -> "Edited by" `Text.isInfixOf` plainText) richText) + PartialComment _ -> pure () + + -- Delete the block comment; listing afterwards must still succeed + _ <- deleteComment comment2Id + _ <- listComments (Just blockId) Nothing Nothing + -- Clean up trashPage methods pageId @@ -1212,7 +1249,7 @@ PageObject {id = pageBId} = pageB -- Move page A under page B - let moveReq = MovePage {parent = PageParent {pageId = pageBId}, position = Nothing} + let moveReq = MovePage {parent = MoveToPage pageBId} movedPage <- movePage pageAId moveReq let PageObject {id = movedId} = movedPage assertEqual "Moved page should have same ID" pageAId movedId @@ -1260,7 +1297,7 @@ testQueryDataSource :: Methods -> Text.Text -> Assertion testQueryDataSource methods@Methods {queryDataSource} dbIdText = do dsId <- getFirstDataSourceId methods dbIdText - let queryReq = DataSources.QueryDataSource {filter = Nothing, sorts = Nothing, startCursor = Nothing, pageSize = Just 5, inTrash = Nothing, filterProperties = Nothing} + let queryReq = DataSources.QueryDataSource {filter = Nothing, sorts = Nothing, startCursor = Nothing, pageSize = Just 5, inTrash = Nothing, filterProperties = Nothing, resultType = Nothing} result <- queryDataSource dsId queryReq -- Just verify the endpoint responds and returns valid structure assertBool "Query should return results list" (hasMore result || Vector.null (results result) || not (Vector.null (results result))) @@ -1299,7 +1336,7 @@ -- | Full view lifecycle: create, retrieve, update, list, query, delete. testViewLifecycle :: Methods -> Text.Text -> Assertion -testViewLifecycle methods@Methods {createView, retrieveView, updateView, listViews, queryView, deleteView} dbIdText = do +testViewLifecycle methods@Methods {createView, retrieveView, updateView, listViews, createViewQuery, getViewQueryResults, deleteViewQuery, deleteView} dbIdText = do dsId <- getFirstDataSourceId methods dbIdText -- Step 1: Create a table view @@ -1313,8 +1350,21 @@ filter = Nothing, sorts = Nothing, quickFilters = Nothing, - configuration = Nothing, - position = Nothing + createDatabase_ = Nothing, + configuration = + Just + ( Views.TableConfig + Views.TableViewConfig + { Views.properties = Unset, + Views.groupBy = Unset, + Views.subtasks = Unset, + Views.wrapCells = Just True, + Views.frozenColumnIndex = Nothing, + Views.showVerticalLines = Nothing + } + ), + position = Just Views.ViewPositionEnd, + placement = Nothing } view <- createView createReq let ViewObject {id = viewId, type_ = viewType, name = viewName} = view @@ -1327,14 +1377,19 @@ assertEqual "Retrieved view ID should match" viewId retrievedViewId let ViewObject {type_ = retrievedType} = retrieved assertEqual "Retrieved view type should be table" (Just TableView) retrievedType + let ViewObject {configuration = retrievedConfig} = retrieved + case retrievedConfig of + Just (Views.TableConfig Views.TableViewConfig {Views.wrapCells = wrap}) -> + assertEqual "Retrieved table configuration keeps wrap_cells" (Just True) wrap + other -> assertFailure ("Expected a typed table configuration, got " <> show other) -- Step 3: Update the view (rename) let updateReq = UpdateView { name = Just "E2E Test View (Renamed)", - filter = Nothing, - sorts = Nothing, - quickFilters = Nothing, + filter = Clear, + sorts = Unset, + quickFilters = Unset, configuration = Nothing } updated <- updateView viewId updateReq @@ -1346,9 +1401,14 @@ let viewIds = Vector.map (\(ViewObject {id = vid}) -> vid) (results viewList) assertBool "View list should contain our view" (viewId `Vector.elem` viewIds) - -- Step 5: Query the view (may fail if endpoint URL is different than expected) - -- The query view endpoint URL is not yet confirmed in the API docs. - -- We skip this step to avoid test failures from URL guessing. + -- Step 5: Query the view's rows through the view-query flow + Views.ViewQuery {Views.id = queryId, Views.totalCount = total, Views.results = firstPage} <- + createViewQuery viewId Views.CreateViewQuery {Views.pageSize = Just 10} + assertBool "first page is no larger than total_count" (fromIntegral (Vector.length firstPage) <= total) + List {results = page2} <- getViewQueryResults viewId queryId Nothing (Just 10) + assertBool "results page is no larger than total_count" (fromIntegral (Vector.length page2) <= total) + Views.DeletedViewQuery {Views.deleted = queryDeleted} <- deleteViewQuery viewId queryId + assertBool "query deleted" queryDeleted -- Step 6: Delete the view deleted <- deleteView viewId @@ -1474,7 +1534,8 @@ nextCursor = Just "cursor-1", hasMore = True, type_ = Nothing, - object = Nothing + object = Nothing, + requestStatus = Nothing } Just "cursor-1" -> pure $ @@ -1483,7 +1544,8 @@ nextCursor = Just "cursor-2", hasMore = True, type_ = Nothing, - object = Nothing + object = Nothing, + requestStatus = Nothing } _ -> pure $ @@ -1492,7 +1554,8 @@ nextCursor = Nothing, hasMore = False, type_ = Nothing, - object = Nothing + object = Nothing, + requestStatus = Nothing } PaginationResult {allResults, totalPages} <- paginateCollect mockFetch assertEqual "all results" (Vector.fromList [1, 2, 3, 4, 5, 6]) allResults @@ -1509,8 +1572,8 @@ properties = Just $ Map.fromList - [ ("OldColumn", Nothing), - ("NewColumn", Just (Props.TitleSchema {schemaId = "", schemaName = "NewColumn"})) + [ ("OldColumn", Props.RemoveProperty), + ("NewColumn", Props.SetPropertySchema (Props.TitleSchema {schemaId = "", schemaName = "NewColumn", schemaDescription = Nothing})) ], inTrash = Nothing, parent = Nothing @@ -1544,12 +1607,17 @@ testBlockContentMeetingNotes = do let json = "{\"type\":\"meeting_notes\",\"meeting_notes\":" - <> "{\"title\":\"Weekly Sync\",\"status\":\"scheduled\"," + <> "{\"title\":[{\"type\":\"text\",\"text\":{\"content\":\"Weekly Sync\",\"link\":null}," + <> "\"annotations\":{\"bold\":false,\"italic\":false,\"strikethrough\":false,\"underline\":false,\"code\":false,\"color\":\"default\"}," + <> "\"plain_text\":\"Weekly Sync\",\"href\":null}],\"status\":\"scheduled\"," <> "\"calendar_event\":null,\"recording\":null}}" case Aeson.eitherDecode json of Left err -> assertFailure $ "Failed to parse meeting_notes: " <> err Right (MeetingNotesBlock {meetingTitle}) -> - assertEqual "meetingTitle" "Weekly Sync" meetingTitle + assertEqual + "meetingTitle" + (Just (Vector.singleton "Weekly Sync")) + (fmap (Vector.map (\RichText {plainText} -> plainText)) meetingTitle) Right other -> assertFailure $ "Expected MeetingNotesBlock, got: " <> show other testBlockContentTemplate :: Assertion @@ -1642,28 +1710,10 @@ testSerializeCreateComment = do let req = CreateComment - { parent = PageParent {pageId = UUID "p-1"}, - richText = Vector.singleton (mkPlainRichText "Hello"), - discussionId = Nothing, - attachments = - Just - ( Vector.singleton - CommentAttachment - { name = Just "file.pdf", - type_ = Just "external", - category = Nothing, - external = Just (ExternalFile {url = "https://example.com/file.pdf"}), - file = Nothing - } - ), - displayName = - Just - CommentDisplayName - { type_ = "user", - emoji = Just "🎉", - displayName = Just "Bot", - resolvedName = Nothing - } + { target = CommentOnParent PageParent {pageId = UUID "p-1"}, + content = CommentRichText (Vector.singleton (mkPlainRichText "Hello")), + attachments = Just (Vector.singleton (CommentAttachmentRequest (UUID "fu-1"))), + displayName = Just (DisplayAsCustom "Sato Kenji") } json = Aeson.toJSON req case json of @@ -1706,8 +1756,8 @@ inTrash = Nothing, isLocked = Just True, isArchived = Just False, - icon = Nothing, - cover = Nothing, + icon = Unset, + cover = Unset, template = Nothing, eraseContent = Nothing } @@ -1796,7 +1846,7 @@ "{\"id\":\"abc\",\"type\":\"select\",\"select\":{\"id\":\"opt-1\",\"name\":\"Done\",\"color\":\"green\"}}" case Aeson.eitherDecode json of Left err -> assertFailure $ "Failed to parse SelectValue: " <> err - Right (PV.SelectValue pid (Just (PV.SelectOptionValue _ optName optColor))) -> do + Right (PV.SelectValue pid (Just (PV.SelectOptionValue _ optName optColor _))) -> do assertEqual "property id" "abc" pid assertEqual "option name" "Done" optName assertEqual "option color" (Just "green") optColor @@ -1847,7 +1897,7 @@ let json = "{\"id\":\"st\",\"type\":\"status\",\"status\":{\"id\":\"opt-1\",\"name\":\"In Progress\",\"color\":\"yellow\"}}" case Aeson.eitherDecode json of Left err -> assertFailure $ "Failed to parse StatusValue: " <> err - Right (PV.StatusValue pid (Just (PV.SelectOptionValue _ optName _))) -> do + Right (PV.StatusValue pid (Just (PV.SelectOptionValue _ optName _ _))) -> do assertEqual "property id" "st" pid assertEqual "status name" "In Progress" optName Right other -> assertFailure $ "Expected StatusValue, got: " <> show other @@ -1957,7 +2007,7 @@ testSmartSelectValue = do let pv = PV.selectValue "Done" case pv of - PV.SelectValue pid (Just (PV.SelectOptionValue _ optName _)) -> do + PV.SelectValue pid (Just (PV.SelectOptionValue _ optName _ _)) -> do assertEqual "schema id should be empty" "" pid assertEqual "name" "Done" optName _ -> assertFailure "Expected SelectValue" @@ -1980,10 +2030,10 @@ testPropertySchemaSelectRoundTrip = do let opts = Vector.fromList - [ Props.SelectOption {id = Just "opt-1", name = "Done", color = Just Props.Green}, - Props.SelectOption {id = Just "opt-2", name = "Todo", color = Just Props.Red} + [ Props.SelectOption {id = Just "opt-1", name = "Done", color = Just Props.Green, description = Nothing}, + Props.SelectOption {id = Just "opt-2", name = "Todo", color = Just Props.Red, description = Nothing} ] - schema = Props.SelectSchema {schemaId = "abc", schemaName = "Status", selectOptions = opts} + schema = Props.SelectSchema {schemaId = "abc", schemaName = "Status", schemaDescription = Nothing, selectOptions = opts} json = Aeson.toJSON schema case Aeson.fromJSON json of Aeson.Success decoded -> assertEqual "round-trip" schema decoded @@ -1991,7 +2041,7 @@ testPropertySchemaNumberRoundTrip :: Assertion testPropertySchemaNumberRoundTrip = do - let schema = Props.NumberSchema {schemaId = "n1", schemaName = "Price", numberFormat = Props.Dollar} + let schema = Props.NumberSchema {schemaId = "n1", schemaName = "Price", schemaDescription = Nothing, numberFormat = Props.Dollar} json = Aeson.toJSON schema case Aeson.fromJSON json of Aeson.Success decoded -> assertEqual "round-trip" schema decoded @@ -1999,7 +2049,7 @@ testPropertySchemaFormulaRoundTrip :: Assertion testPropertySchemaFormulaRoundTrip = do - let schema = Props.FormulaSchema {schemaId = "f1", schemaName = "Total", formulaExpression = "prop(\"Price\") * 2"} + let schema = Props.FormulaSchema {schemaId = "f1", schemaName = "Total", schemaDescription = Nothing, formulaExpression = "prop(\"Price\") * 2"} json = Aeson.toJSON schema case Aeson.fromJSON json of Aeson.Success decoded -> assertEqual "round-trip" schema decoded @@ -2007,8 +2057,8 @@ testPropertySchemaRelationRoundTrip :: Assertion testPropertySchemaRelationRoundTrip = do - let relType = Props.DualProperty {syncedPropertyId = "sp1", syncedPropertyName = "Related"} - schema = Props.RelationSchema {schemaId = "r1", schemaName = "Tasks", relationDataSourceId = UUID "ds-123", relationType = relType} + let relType = Props.DualProperty {syncedPropertyId = Just "sp1", syncedPropertyName = Just "Related"} + schema = Props.RelationSchema {schemaId = "r1", schemaName = "Tasks", schemaDescription = Nothing, relationDataSourceId = UUID "ds-123", relationDatabaseId = Nothing, relationType = relType} json = Aeson.toJSON schema case Aeson.fromJSON json of Aeson.Success decoded -> assertEqual "round-trip" schema decoded @@ -2020,7 +2070,9 @@ Props.RelationSchema { schemaId = "r1", schemaName = "Depends On", + schemaDescription = Nothing, relationDataSourceId = UUID "ds-123", + relationDatabaseId = Nothing, relationType = Props.SingleProperty } json = Aeson.toJSON schema @@ -2044,7 +2096,9 @@ Props.RelationSchema { schemaId = "r1", schemaName = "Depends On", + schemaDescription = Nothing, relationDataSourceId = UUID "ds-123", + relationDatabaseId = Nothing, relationType = Props.SingleProperty } case Aeson.fromJSON (Aeson.toJSON schema) of @@ -2055,15 +2109,15 @@ testPropertySchemaStatusRoundTrip = do let opts = Vector.fromList - [ Props.SelectOption {id = Just "s1", name = "Not Started", color = Just Props.Gray}, - Props.SelectOption {id = Just "s2", name = "Done", color = Just Props.Green} + [ Props.SelectOption {id = Just "s1", name = "Not Started", color = Just Props.Gray, description = Nothing}, + Props.SelectOption {id = Just "s2", name = "Done", color = Just Props.Green, description = Nothing} ] grps = Vector.fromList [ Props.StatusGroup {id = Just "g1", name = "To-do", color = Just Props.Gray, optionIds = Vector.fromList ["s1"]}, Props.StatusGroup {id = Just "g2", name = "Complete", color = Just Props.Green, optionIds = Vector.fromList ["s2"]} ] - schema = Props.StatusSchema {schemaId = "st1", schemaName = "Status", statusOptions = opts, statusGroups = grps} + schema = Props.StatusSchema {schemaId = "st1", schemaName = "Status", schemaDescription = Nothing, statusOptions = opts, statusGroups = grps} json = Aeson.toJSON schema case Aeson.fromJSON json of Aeson.Success decoded -> assertEqual "round-trip" schema decoded diff --git a/tasty/MeetingNotesTests.hs b/tasty/MeetingNotesTests.hs new file mode 100644 --- /dev/null +++ b/tasty/MeetingNotesTests.hs @@ -0,0 +1,204 @@ +-- | Meeting-notes create and query endpoints (EP-3). +module MeetingNotesTests (tests) where + +import Data.Aeson (Value, (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy qualified as LBS +import Data.Text (Text) +import Data.Vector qualified as Vector +import Notion.V1.Common (UUID (..)) +import Notion.V1.Filter (SortDirection (..)) +import Notion.V1.MeetingNotes +import Notion.V1.RichText (RichText (..)) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Meeting notes (EP-3)" + [ testCase "Decode full meeting note block" testDecodeFull, + testCase "Decode partial create response" testDecodePartial, + testCase "Unknown meeting-notes status is tolerated" testUnknownStatus, + testCase "Minimal payload decodes" testMinimalPayload, + testCase "CreateMeetingNote from file upload" testCreateFromFileUpload, + testCase "CreateMeetingNote from block has no parent" testCreateFromBlock, + testCase "Language codes" testLanguageCodes, + testCase "Empty query encodes to {}" testEmptyQuery, + testCase "Attendees filter matches the JS SDK test" testAttendeesFilter, + testCase "Nested combinators, title and date point" testNestedFilter, + testCase "Date range condition" testDateRange, + testCase "Sort and limit" testSortAndLimit, + testCase "Raw node passes through" testRawNode, + testCase "Decode query response" testDecodeQueryResponse + ] + +blockWithPayload :: LBS.ByteString -> LBS.ByteString +blockWithPayload payload = + "{\"object\":\"block\",\"id\":\"7e3f0a1b-0000-4000-8000-000000000101\",\"type\":\"meeting_notes\",\ + \\"meeting_notes\":" + <> payload + <> ",\"created_time\":\"2026-09-14T00:00:00.000Z\",\"last_edited_time\":\"2026-09-14T00:40:00.000Z\",\ + \\"created_by\":{\"object\":\"user\",\"id\":\"9a8b7c6d-0000-4000-8000-00000000000c\"},\ + \\"last_edited_by\":{\"object\":\"user\",\"id\":\"9a8b7c6d-0000-4000-8000-00000000000c\"},\ + \\"has_children\":true,\"in_trash\":false,\"archived\":false}" + +fullPayload :: LBS.ByteString +fullPayload = + "{\"title\":[{\"type\":\"text\",\"text\":{\"content\":\"Weekly sync\",\"link\":null},\ + \\"annotations\":{\"bold\":false,\"italic\":false,\"strikethrough\":false,\"underline\":false,\"code\":false,\"color\":\"default\"},\ + \\"plain_text\":\"Weekly sync\",\"href\":null}],\ + \\"status\":\"notes_ready\",\ + \\"children\":{\"summary_block_id\":\"7e3f0a1b-0000-4000-8000-000000000102\",\ + \\"notes_block_id\":\"7e3f0a1b-0000-4000-8000-000000000103\",\ + \\"transcript_block_id\":\"7e3f0a1b-0000-4000-8000-000000000104\"},\ + \\"calendar_event\":{\"start_time\":\"2026-09-14T09:00:00.000+09:00\",\"end_time\":\"2026-09-14T09:30:00.000+09:00\",\ + \\"attendees\":[\"9a8b7c6d-0000-4000-8000-00000000000c\"]},\ + \\"recording\":{\"start_time\":\"2026-09-14T09:01:00.000+09:00\"}}" + +-- | The meeting-note block fixture used by the create and query tests. +blockFixture :: LBS.ByteString +blockFixture = blockWithPayload fullPayload + +decodeContent :: LBS.ByteString -> IO MeetingNotesContent +decodeContent bs = case Aeson.eitherDecode bs of + Right (FullMeetingNote MeetingNoteBlock {meetingNotes}) -> pure meetingNotes + Right other -> assertFailure ("expected FullMeetingNote, got " <> show other) + Left err -> assertFailure err + +decodeValue :: LBS.ByteString -> IO Value +decodeValue bs = either (assertFailure . ("fixture: " <>)) pure (Aeson.eitherDecode bs) + +testDecodeFull :: Assertion +testDecodeFull = do + MeetingNotesContent {contentTitle, contentStatus, contentCalendarEvent} <- decodeContent blockFixture + contentStatus @?= Just NotesReady + fmap (fmap (\RichText {plainText} -> plainText) . Vector.toList) contentTitle @?= Just ["Weekly sync"] + fmap (\MeetingCalendarEvent {calendarAttendees} -> fmap Vector.length calendarAttendees) contentCalendarEvent + @?= Just (Just 1) + +testDecodePartial :: Assertion +testDecodePartial = + case Aeson.eitherDecode "{\"object\":\"block\",\"id\":\"7e3f0a1b-0000-4000-8000-000000000101\"}" of + Right (PartialMeetingNote bid) -> bid @?= UUID "7e3f0a1b-0000-4000-8000-000000000101" + Right other -> assertFailure ("expected PartialMeetingNote, got " <> show other) + Left err -> assertFailure err + +testUnknownStatus :: Assertion +testUnknownStatus = do + MeetingNotesContent {contentStatus = archiving} <- decodeContent (blockWithPayload "{\"status\":\"archiving\"}") + archiving @?= Just (UnknownMeetingNotesStatus "archiving") + MeetingNotesContent {contentStatus = failed} <- decodeContent (blockWithPayload "{\"status\":\"transcription_failed\"}") + failed @?= Just TranscriptionFailed + +testMinimalPayload :: Assertion +testMinimalPayload = do + content <- decodeContent (blockWithPayload "{}") + content @?= MeetingNotesContent Nothing Nothing Nothing Nothing Nothing + +testCreateFromFileUpload :: Assertion +testCreateFromFileUpload = do + let req = + CreateMeetingNote + { source = + FromFileUpload + (UUID "a02fc1d3-db8b-45c5-a222-27595b15aea7") + (UUID "c02fc1d3-db8b-45c5-a222-27595b15aea7"), + title = Just "Weekly sync", + language = Just LanguageEn, + kickoffSummary = Just True + } + expected <- + decodeValue + "{\"source\":{\"type\":\"file_upload\",\"file_upload_id\":\"a02fc1d3-db8b-45c5-a222-27595b15aea7\"},\ + \\"parent\":{\"type\":\"page_id\",\"page_id\":\"c02fc1d3-db8b-45c5-a222-27595b15aea7\"},\ + \\"title\":\"Weekly sync\",\"language\":\"en\",\"options\":{\"kickoff_summary\":true}}" + Aeson.toJSON req @?= expected + +testCreateFromBlock :: Assertion +testCreateFromBlock = do + expected <- decodeValue "{\"source\":{\"type\":\"block\",\"block_id\":\"b-1\"}}" + Aeson.toJSON (mkCreateMeetingNote (FromBlock (UUID "b-1"))) @?= expected + +testLanguageCodes :: Assertion +testLanguageCodes = + map Aeson.toJSON [LanguageZhCN, LanguageZhTW, LanguageNo, LanguageOther "tl"] + @?= map Aeson.String ["zh-CN", "zh-TW", "no", "tl"] + +-- | A value nested inside JSON objects, looked up by key path. +lookupPath :: [Aeson.Key] -> Value -> Maybe Value +lookupPath [] v = Just v +lookupPath (k : ks) (Aeson.Object o) = KeyMap.lookup k o >>= lookupPath ks +lookupPath _ _ = Nothing + +-- | The encoded condition of a property filter node. +conditionOf :: MeetingNotesPropertyFilter -> Maybe Value +conditionOf = lookupPath ["filter"] . Aeson.toJSON + +testEmptyQuery :: Assertion +testEmptyQuery = Aeson.toJSON emptyQueryMeetingNotes @?= Aeson.object [] + +testAttendeesFilter :: Assertion +testAttendeesFilter = do + let QueryMeetingNotes {sort, limit} = emptyQueryMeetingNotes + query = + QueryMeetingNotes + { filter = Just (mnAnd [mnAttendeesInclude (UUID "a1b2c3d4-e5f6-7890-abcd-ef1234567890")]), + sort, + limit + } + expected <- + decodeValue + "{\"filter\":{\"operator\":\"and\",\"filters\":[{\"property\":\"attendees\",\ + \\"filter\":{\"operator\":\"person_contains\",\"value\":[{\"type\":\"exact\",\ + \\"value\":{\"table\":\"notion_user\",\"id\":\"a1b2c3d4-e5f6-7890-abcd-ef1234567890\"}}]}}]}}" + Aeson.toJSON query @?= expected + +testNestedFilter :: Assertion +testNestedFilter = do + let datePoint = + MNProperty + ( MNCreatedTime + ( MNDateIsOnOrAfter + (MeetingNotesDatePoint MNExact (MNDatePointSpec (MeetingNotesDateSpec True "2026-09-01" (Just "09:30") (Just "Asia/Tokyo")))) + ) + ) + f = mnOr [mnTitleContains "standup", MNNested (mnAnd [datePoint, MNProperty (MNTitle MNTextIsNotEmpty)])] + title <- decodeValue "{\"property\":\"title\",\"filter\":{\"operator\":\"string_contains\",\"value\":{\"type\":\"exact\",\"value\":\"standup\"}}}" + spec <- decodeValue "{\"type\":\"datetime\",\"start_date\":\"2026-09-01\",\"start_time\":\"09:30\",\"time_zone\":\"Asia/Tokyo\"}" + notEmpty <- decodeValue "{\"property\":\"title\",\"filter\":{\"operator\":\"is_not_empty\"}}" + let nested = Aeson.object ["operator" .= ("and" :: Text), "filters" .= [Aeson.toJSON datePoint, notEmpty]] + Aeson.toJSON f @?= Aeson.object ["operator" .= ("or" :: Text), "filters" .= [title, nested]] + lookupPath ["filter", "value", "value"] (Aeson.toJSON datePoint) @?= Just spec + lookupPath ["filter", "operator"] (Aeson.toJSON datePoint) @?= Just (Aeson.String "date_is_on_or_after") + +testDateRange :: Assertion +testDateRange = do + relative <- decodeValue "{\"type\":\"relative\",\"value\":\"custom\",\"direction\":\"past\",\"unit\":\"week\",\"count\":2}" + (conditionOf (MNLastEditedTime (MNDateIsWithin (MeetingNotesDateRange MNRelative (MNDateRangeText "custom") (Just MNPast) (Just MNWeek) (Just 2)))) >>= lookupPath ["value"]) + @?= Just relative + -- mnCreatedWithinPast produces the shape Notion accepted in a live check + within <- decodeValue "{\"operator\":\"date_is_within\",\"value\":{\"type\":\"relative\",\"value\":\"custom\",\"direction\":\"past\",\"unit\":\"year\",\"count\":1}}" + lookupPath ["filter"] (Aeson.toJSON (mnCreatedWithinPast 1 MNYear)) @?= Just within + exact <- decodeValue "{\"type\":\"exact\",\"value\":{\"type\":\"daterange\",\"start_date\":\"2026-09-01\"}}" + (conditionOf (MNLastEditedTime (MNDateIsWithin (MeetingNotesDateRange MNExact (MNDateRangeSpec "2026-09-01" Nothing) Nothing Nothing Nothing))) >>= lookupPath ["value"]) + @?= Just exact + +testSortAndLimit :: Assertion +testSortAndLimit = do + expected <- decodeValue "{\"sort\":[{\"property\":\"created_time\",\"direction\":\"descending\"}],\"limit\":10}" + Aeson.toJSON (QueryMeetingNotes Nothing (Just [MeetingNotesSort MNPropCreatedTime Descending]) (Just 10)) @?= expected + +testRawNode :: Assertion +testRawNode = do + let raw = Aeson.object ["property" .= ("title" :: Text)] + lookupPath ["filters"] (Aeson.toJSON (mnAnd [MNRawNode raw])) @?= Just (Aeson.toJSON [raw]) + +testDecodeQueryResponse :: Assertion +testDecodeQueryResponse = + case Aeson.eitherDecode ("{\"results\":[" <> blockFixture <> "],\"has_more\":false}") of + Right QueryMeetingNotesResponse {results, hasMore} -> do + Vector.length results @?= 1 + hasMore @?= False + Left err -> assertFailure err diff --git a/tasty/OAuthTests.hs b/tasty/OAuthTests.hs new file mode 100644 --- /dev/null +++ b/tasty/OAuthTests.hs @@ -0,0 +1,91 @@ +-- | Tests for the OAuth endpoints. +module OAuthTests (tests) where + +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy.Char8 qualified as L8 +import Data.IORef (readIORef) +import FakeNotion +import Notion.V1 (defaultClientConfig) +import Notion.V1.OAuth +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "OAuth" + [ testCase "basicAuthorization encodes client_id:client_secret" $ + basicAuthorization credentials @?= "Basic Y2xpZW50OnNlY3JldA==", + testCase "authorization_code request encodes" $ do + let grant = AuthorizationCodeGrant "code-123" (Just "https://example.com/callback") Nothing + Aeson.toJSON (AuthorizationCode grant) + @?= Aeson.object + [ "grant_type" Aeson..= ("authorization_code" :: String), + "code" Aeson..= ("code-123" :: String), + "redirect_uri" Aeson..= ("https://example.com/callback" :: String) + ] + Aeson.toJSON (AuthorizationCode grant {externalAccount = Just (ExternalAccount "acct-1" "Tanaka Hanako")}) + @?= Aeson.object + [ "grant_type" Aeson..= ("authorization_code" :: String), + "code" Aeson..= ("code-123" :: String), + "redirect_uri" Aeson..= ("https://example.com/callback" :: String), + "external_account" Aeson..= Aeson.object ["key" Aeson..= ("acct-1" :: String), "name" Aeson..= ("Tanaka Hanako" :: String)] + ], + testCase "refresh_token request encodes" $ + Aeson.toJSON (RefreshToken "nrt_abc") + @?= Aeson.object ["grant_type" Aeson..= ("refresh_token" :: String), "refresh_token" Aeson..= ("nrt_abc" :: String)], + testCase "token response with person owner decodes" $ do + OAuthTokenResponse {owner, refreshToken} <- decodeOrFail (tokenJson personOwner) + refreshToken @?= Just "nrt_tanaka_refresh" + case owner of + OAuthUserOwner OAuthOwnerUser {email, name} -> do + email @?= Just "hanako@example.com" + name @?= Just "Tanaka Hanako" + other -> assertFailure ("expected a user owner, got " <> show other), + testCase "partial user owner and workspace owner decode" $ do + OAuthTokenResponse {owner = partial} <- + decodeOrFail (tokenJson "{\"type\":\"user\",\"user\":{\"id\":\"0e1d2c3b-4a59-4687-b7a6-958473625140\",\"object\":\"user\"}}") + case partial of + OAuthUserOwner OAuthOwnerUser {email, type_} -> do + email @?= Nothing + type_ @?= Nothing + other -> assertFailure ("expected a user owner, got " <> show other) + OAuthTokenResponse {owner = workspace} <- decodeOrFail (tokenJson "{\"type\":\"workspace\",\"workspace\":true}") + workspace @?= OAuthWorkspaceOwner + OAuthTokenResponse {owner = team} <- decodeOrFail (tokenJson "{\"type\":\"team\"}") + case team of + UnknownOAuthOwner _ -> pure () + other -> assertFailure ("expected UnknownOAuthOwner, got " <> show other), + testCase "introspect response decodes" $ do + r1 <- decodeOrFail "{\"active\":true,\"scope\":\"read_content\",\"iat\":1757890000,\"request_id\":\"r-1\"}" + r1 @?= OAuthIntrospectResponse True (Just "read_content") (Just 1757890000) (Just "r-1") + r2 <- decodeOrFail "{\"active\":false}" + r2 @?= OAuthIntrospectResponse False Nothing Nothing Nothing, + testCase "createOAuthToken sends Basic auth to POST /oauth/token" $ do + (env, recorded) <- fakeClientEnv [jsonReply 200 (tokenJson personOwner)] + let oauth = makeOAuthMethodsWith defaultClientConfig env credentials + _ <- createOAuthToken oauth (RefreshToken "nrt_tanaka_refresh") + readIORef recorded >>= \case + [r@Recorded {method, path}] -> do + method @?= "POST" + path @?= "/oauth/token" + lookupRecordedHeader "Authorization" r @?= Just "Basic Y2xpZW50OnNlY3JldA==" + length [() | ("Authorization", _) <- headers r] @?= 1 + rs -> assertFailure ("expected one request, got " <> show (length rs)) + ] + +credentials :: OAuthCredentials +credentials = OAuthCredentials {clientId = "client", clientSecret = "secret"} + +decodeOrFail :: (Aeson.FromJSON a) => L8.ByteString -> IO a +decodeOrFail bytes = either (assertFailure . ("decode failed: " <>)) pure (Aeson.eitherDecode bytes) + +personOwner :: L8.ByteString +personOwner = + "{\"type\":\"user\",\"user\":{\"type\":\"person\",\"person\":{\"email\":\"hanako@example.com\"},\"name\":\"Tanaka Hanako\",\"avatar_url\":null,\"id\":\"0e1d2c3b-4a59-4687-b7a6-958473625140\",\"object\":\"user\"}}" + +tokenJson :: L8.ByteString -> L8.ByteString +tokenJson owner = + "{\"access_token\":\"secret_tanaka_access\",\"token_type\":\"bearer\",\"refresh_token\":\"nrt_tanaka_refresh\",\"bot_id\":\"2f8e6d4c-1b3a-4c5d-8e7f-9a0b1c2d3e4f\",\"workspace_icon\":null,\"workspace_name\":\"Tanaka Hanako's Workspace\",\"workspace_id\":\"7a6b5c4d-3e2f-4a1b-9c8d-7e6f5a4b3c2d\",\"owner\":" + <> owner + <> ",\"duplicated_template_id\":null,\"request_id\":\"5d4c3b2a-1f0e-4d9c-8b7a-6f5e4d3c2b1a\"}" diff --git a/tasty/ObjectFieldTests.hs b/tasty/ObjectFieldTests.hs new file mode 100644 --- /dev/null +++ b/tasty/ObjectFieldTests.hs @@ -0,0 +1,499 @@ +-- | Object field gap tests: pages, blocks, property values, mentions, users, +-- file uploads and webhooks. Fixtures are transcribed from the official Notion +-- JS SDK types. +module ObjectFieldTests (tests) where + +import Control.Exception (Exception, throwIO, try) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (parseEither) +import Data.ByteString.Char8 qualified as B8 +import Data.ByteString.Lazy qualified as LBS +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Map qualified as Map +import Data.Text (Text) +import Data.Text.Encoding qualified as TE +import Data.Vector qualified as Vector +import Network.HTTP.Client qualified as HTTP +import Notion.V1 (Methods (..), makeMethods) +import Notion.V1.BlockContent + ( BlockContent (..), + BlockUpdateContent (..), + MediaSourceUpdate (..), + MediaUpdate (..), + TableUpdate (..), + ToDoUpdate (..), + blockUpdateFromContent, + mkBlockUpdate, + parseBlockContent, + trashBlockUpdate, + ) +import Notion.V1.Clearable (Clearable (..)) +import Notion.V1.Common (CustomEmojiRef (..), Icon (..), NoticonColor (..), ObjectType (..), UUID (..)) +import Notion.V1.FileUploads qualified as FU +import Notion.V1.Pages + ( CreatePage (..), + InsertContentRequest (..), + InsertPosition (..), + MovePage (..), + MovePageParent (..), + PageMarkdown (..), + PropertyItemList (..), + PropertyItemResponse (..), + UpdatePage (..), + UpdatePageMarkdown (..), + UpdatePageTemplate (..), + mkUpdatePage, + ) +import Notion.V1.PropertyValue + ( Place (..), + PropertyValue (..), + RollupResult (..), + SelectOptionValue (..), + VerificationResult (..), + VerificationState (..), + unverifiedValue, + ) +import Notion.V1.RichText (LinkMentionValue (..), MentionContent (..), RichText (..), RichTextContent (..)) +import Notion.V1.Users (GroupObject (..), PeopleEntry (..), UserObject (..), UserType (..), UserValue (..)) +import Notion.V1.Webhooks + ( EntityType (..), + EventType (..), + PropertyAction (..), + UpdatedPropertySchema (..), + ViewField (..), + WebhookBlockRef (..), + WebhookEntity (..), + WebhookEvent (..), + WebhookEventData (..), + WebhookParent (..), + WebhookParentType (..), + WebhookRefType (..), + ) +import Servant.Client qualified as Client +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Object Field Gaps" + [ testGroup "Page and block requests" pageBlockRequestTests, + testGroup "Property values and mentions" propertyValueMentionTests, + testGroup "Users, file uploads, and object types" userFileUploadObjectTypeTests, + testGroup "Webhooks" webhookTests + ] + +------------------------------------------------------------------------------ +-- Helpers + +-- | Decode a JSON literal or fail the test with aeson's message. Fixtures are +-- 'Text' so that non-ASCII content is encoded as UTF-8. +decodeOrFail :: (Aeson.FromJSON a) => Text -> IO a +decodeOrFail t = + either (assertFailure . ("decode failed: " <>)) pure (Aeson.eitherDecode (LBS.fromStrict (TE.encodeUtf8 t))) + +-- | Decode a JSON literal as a generic value. +value :: Text -> IO Aeson.Value +value = decodeOrFail + +-- | Assert that a value encodes to exactly the given JSON. +encodesTo :: (Aeson.ToJSON a) => a -> Text -> Assertion +encodesTo x expected = do + e <- value expected + Aeson.toJSON x @?= e + +data RequestCaptured = RequestCaptured + deriving stock (Show) + +instance Exception RequestCaptured + +-- | Run a 'Methods' call and capture the HTTP request it builds, aborting +-- before any network I/O happens. +captureRequest :: (Methods -> IO a) -> IO HTTP.Request +captureRequest call = do + ref <- newIORef Nothing + manager <- HTTP.newManager HTTP.defaultManagerSettings + let env0 = Client.mkClientEnv manager (Client.BaseUrl Client.Https "api.notion.com" 443 "/v1") + env = + env0 + { Client.makeClientRequest = \burl req -> do + built <- Client.defaultMakeClientRequest burl req + writeIORef ref (Just built) + throwIO RequestCaptured + } + _ <- try @RequestCaptured (call (makeMethods env "secret_test_token")) + readIORef ref >>= maybe (assertFailure "no request was built") pure + +------------------------------------------------------------------------------ +-- Milestone 1: page and block requests + +emptyCreatePage :: CreatePage +emptyCreatePage = + CreatePage + { parent = Nothing, + properties = Map.empty, + children = Nothing, + markdown = Nothing, + icon = Nothing, + cover = Nothing, + template = Nothing, + position = Nothing + } + +trashOnlyUpdatePage :: UpdatePage +trashOnlyUpdatePage = + let UpdatePage {..} = mkUpdatePage Map.empty + in UpdatePage {inTrash = Just True, ..} + +pageBlockRequestTests :: [TestTree] +pageBlockRequestTests = + [ testCase "CreatePage without parent or properties omits both keys" $ do + let CreatePage {..} = emptyCreatePage + CreatePage {markdown = Just "# こんにちは", ..} `encodesTo` "{\"markdown\":\"# こんにちは\"}", + testCase "UpdatePage with only in_trash encodes exactly that key" $ + trashOnlyUpdatePage `encodesTo` "{\"in_trash\":true}", + testCase "UpdatePage clears icon and cover with null" $ do + let UpdatePage {..} = mkUpdatePage Map.empty + UpdatePage {icon = Clear, cover = Clear, ..} `encodesTo` "{\"icon\":null,\"cover\":null}", + testCase "UpdatePageTemplate by ID has no none variant" $ + UpdateTemplateById (UUID "tpl-1") Nothing `encodesTo` "{\"type\":\"template_id\",\"template_id\":\"tpl-1\"}", + testCase "MovePage to a data source has no position" $ + MovePage {parent = MoveToDataSource (UUID "ds-1")} + `encodesTo` "{\"parent\":{\"type\":\"data_source_id\",\"data_source_id\":\"ds-1\"}}", + testCase "insert_content at start encodes position" $ + InsertContent (InsertContentRequest "- item" Nothing (Just InsertAtStart)) + `encodesTo` "{\"type\":\"insert_content\",\"insert_content\":{\"content\":\"- item\",\"position\":{\"type\":\"start\"}}}", + testCase "createPageFiltered sends filter_properties as query parameters" $ do + req <- captureRequest $ \m -> createPageFiltered m ["title", "Xy12"] emptyCreatePage + assertBool + ("query string: " <> B8.unpack (HTTP.queryString req)) + ("filter_properties=title&filter_properties=Xy12" `B8.isInfixOf` HTTP.queryString req) + HTTP.method req @?= "POST", + testCase "updatePageFiltered sends filter_properties as query parameters" $ do + req <- captureRequest $ \m -> updatePageFiltered m (UUID "p-1") ["title"] trashOnlyUpdatePage + assertBool + ("query string: " <> B8.unpack (HTTP.queryString req)) + ("filter_properties=title" `B8.isInfixOf` HTTP.queryString req) + HTTP.method req @?= "PATCH", + testCase "to_do update with only checked" $ + mkBlockUpdate (UpdateToDo (ToDoUpdate Nothing (Just True) Nothing)) + `encodesTo` "{\"to_do\":{\"checked\":true}}", + testCase "table update carries only header flags" $ + mkBlockUpdate (UpdateTable (TableUpdate (Just True) Nothing)) + `encodesTo` "{\"table\":{\"has_column_header\":true}}", + testCase "blockUpdateFromContent drops table_width and children" $ do + let table = TableBlock 3 True False (Vector.singleton (TableRowBlock Vector.empty)) + case blockUpdateFromContent table of + Just c -> mkBlockUpdate c `encodesTo` "{\"table\":{\"has_column_header\":true,\"has_row_header\":false}}" + Nothing -> assertFailure "tables are updatable", + testCase "trashBlockUpdate encodes in_trash only" $ + trashBlockUpdate `encodesTo` "{\"in_trash\":true}", + testCase "image update via file upload" $ + mkBlockUpdate (UpdateImage (MediaUpdate Nothing (Just (UpdateFileUploadSource (UUID "fu-1"))))) + `encodesTo` "{\"image\":{\"file_upload\":{\"id\":\"fu-1\"}}}", + testCase "blockUpdateFromContent rejects child pages" $ + blockUpdateFromContent (ChildPageBlock "x") @?= Nothing, + testCase "audio block decodes caption" $ do + empty <- value "{\"type\":\"external\",\"external\":{\"url\":\"https://example.com/a.mp3\"},\"caption\":[]}" + case parseEither (parseBlockContent "audio") empty of + Right AudioBlock {caption} -> Vector.length caption @?= 0 + other -> assertFailure ("expected AudioBlock, got " <> show other) + one <- + value + "{\"type\":\"external\",\"external\":{\"url\":\"https://example.com/a.mp3\"},\"caption\":[{\"type\":\"text\",\"text\":{\"content\":\"録音\",\"link\":null},\"annotations\":{\"bold\":false,\"italic\":false,\"strikethrough\":false,\"underline\":false,\"code\":false,\"color\":\"default\"},\"plain_text\":\"録音\",\"href\":null}]}" + case parseEither (parseBlockContent "audio") one of + Right AudioBlock {caption} -> Vector.length caption @?= 1 + other -> assertFailure ("expected AudioBlock, got " <> show other), + testCase "embed block decodes caption" $ do + v <- value "{\"url\":\"https://example.com\",\"caption\":[]}" + case parseEither (parseBlockContent "embed") v of + Right EmbedBlock {url} -> url @?= "https://example.com" + other -> assertFailure ("expected EmbedBlock, got " <> show other), + testCase "unsupported block keeps block_type" $ do + v <- value "{\"block_type\":\"form\"}" + parseEither (parseBlockContent "unsupported") v @?= Right (UnsupportedBlock (Just "form")) + ] + +------------------------------------------------------------------------------ +-- Milestone 2: property values and mentions + +-- | A rich-text item wrapping the given mention object. +mentionRichText :: Text -> Text +mentionRichText mention = + "{\"type\":\"mention\",\"mention\":" + <> mention + <> ",\"annotations\":{\"bold\":false,\"italic\":false,\"strikethrough\":false,\"underline\":false,\"code\":false,\"color\":\"default\"},\"plain_text\":\"@\",\"href\":null}" + +-- | Decode a rich-text mention fixture and return its mention. +decodeMention :: Text -> IO MentionContent +decodeMention mention = do + rt <- decodeOrFail (mentionRichText mention) + case rt of + RichText {content = MentionContentWrapper m} -> pure m + other -> assertFailure ("expected a mention, got " <> show other) + +propertyValueMentionTests :: [TestTree] +propertyValueMentionTests = + [ testCase "select option with description encodes" $ + SelectValue "" (Just (SelectOptionValue Nothing "急ぎ" Nothing (Just "今日中"))) + `encodesTo` "{\"select\":{\"name\":\"急ぎ\",\"description\":\"今日中\"}}", + testCase "people with partial user, full user and group decodes" $ do + pv <- + decodeOrFail + "{\"id\":\"p1\",\"type\":\"people\",\"people\":[{\"object\":\"user\",\"id\":\"u1\"},{\"object\":\"user\",\"id\":\"u2\",\"type\":\"person\",\"name\":\"Tanaka Hanako\",\"avatar_url\":null,\"person\":{\"email\":\"hanako@example.com\"}},{\"object\":\"group\",\"id\":\"g1\",\"name\":\"Design Team\"}]}" + case pv of + PeopleValue "p1" entries -> case Vector.toList entries of + [PersonEntry (PartialUser (UUID "u1")), PersonEntry (FullUser UserObject {name}), GroupEntry GroupObject {name = groupName}] -> do + name @?= Just "Tanaka Hanako" + groupName @?= Just "Design Team" + other -> assertFailure ("unexpected entries: " <> show other) + other -> assertFailure ("expected PeopleValue, got " <> show other), + testCase "group people entry encodes" $ + GroupEntry (GroupObject (UUID "g1") (Just "Design Team")) + `encodesTo` "{\"object\":\"group\",\"id\":\"g1\",\"name\":\"Design Team\"}", + testCase "place decodes" $ do + pv <- + decodeOrFail + "{\"id\":\"p2\",\"type\":\"place\",\"place\":{\"lat\":35.6812,\"lon\":139.7671,\"name\":\"東京駅\",\"address\":null,\"google_place_id\":\"abc\"}}" + case pv of + PlaceValue _ (Just Place {lat, name, googlePlaceId}) -> do + lat @?= 35.6812 + name @?= Just "東京駅" + googlePlaceId @?= Just "abc" + other -> assertFailure ("expected PlaceValue, got " <> show other), + testCase "verification decodes state, date and verifier" $ do + pv <- + decodeOrFail + "{\"id\":\"p3\",\"type\":\"verification\",\"verification\":{\"state\":\"expired\",\"date\":{\"start\":\"2026-01-01\",\"end\":null,\"time_zone\":null},\"verified_by\":{\"object\":\"user\",\"id\":\"u3\"}}}" + case pv of + VerificationValue _ (Just VerificationResult {state, verifiedBy}) -> do + state @?= Expired + verifiedBy @?= Just (PartialUser (UUID "u3")) + other -> assertFailure ("expected VerificationValue, got " <> show other) + unknown <- decodeOrFail "{\"id\":\"p4\",\"type\":\"verification\",\"verification\":{\"state\":\"pending_review\",\"date\":null,\"verified_by\":null}}" + case unknown of + VerificationValue _ (Just VerificationResult {state}) -> state @?= UnknownVerificationState "pending_review" + other -> assertFailure ("expected VerificationValue, got " <> show other), + testCase "unverifiedValue encodes the request shape" $ + unverifiedValue `encodesTo` "{\"verification\":{\"state\":\"unverified\"}}", + testCase "rollup array decodes typed property values" $ do + pv <- + decodeOrFail + "{\"id\":\"p5\",\"type\":\"rollup\",\"rollup\":{\"type\":\"array\",\"function\":\"show_original\",\"array\":[{\"type\":\"number\",\"number\":3},{\"type\":\"title\",\"title\":[]}]}}" + case pv of + RollupValue _ (RollupArrayResult values _) -> case Vector.toList values of + [NumberValue "" (Just 3), TitleValue "" _] -> pure () + other -> assertFailure ("unexpected rollup values: " <> show other) + other -> assertFailure ("expected RollupValue, got " <> show other), + testCase "unknown property type decodes to UnknownPropertyValue" $ do + pv <- decodeOrFail "{\"id\":\"p6\",\"type\":\"hologram\",\"hologram\":{\"x\":1}}" + case pv of + UnknownPropertyValue "p6" "hologram" _ -> pv `encodesTo` "{\"hologram\":{\"x\":1}}" + other -> assertFailure ("expected UnknownPropertyValue, got " <> show other), + testCase "paginated rollup property item decodes next_url and summary" $ do + r <- + decodeOrFail + "{\"object\":\"list\",\"type\":\"property_item\",\"results\":[],\"next_cursor\":null,\"has_more\":false,\"property_item\":{\"id\":\"r1\",\"type\":\"rollup\",\"next_url\":\"https://api.notion.com/v1/pages/x/properties/r1?start_cursor=abc\",\"rollup\":{\"type\":\"number\",\"number\":7,\"function\":\"count\"}}}" + case r of + PaginatedPropertyItems PropertyItemList {propertyType, propertyId, nextUrl, rollup} -> do + propertyType @?= "rollup" + propertyId @?= "r1" + nextUrl @?= Just "https://api.notion.com/v1/pages/x/properties/r1?start_cursor=abc" + case rollup of + Just (RollupNumberResult (Just 7) _) -> pure () + other -> assertFailure ("unexpected rollup: " <> show other) + other -> assertFailure ("expected PaginatedPropertyItems, got " <> show other), + testCase "link_mention decodes" $ do + m <- decodeMention "{\"type\":\"link_mention\",\"link_mention\":{\"href\":\"https://github.com\",\"title\":\"GitHub\",\"padding_top\":12}}" + case m of + LinkMention LinkMentionValue {href, title, paddingTop} -> do + href @?= "https://github.com" + title @?= Just "GitHub" + paddingTop @?= Just 12 + other -> assertFailure ("expected LinkMention, got " <> show other), + testCase "custom_emoji mention decodes and re-encodes" $ do + m <- decodeMention "{\"type\":\"custom_emoji\",\"custom_emoji\":{\"id\":\"e1\",\"name\":\"bufo\",\"url\":\"https://example.com/bufo.png\"}}" + m @?= CustomEmojiMention (CustomEmojiRef (UUID "e1") (Just "bufo") (Just "https://example.com/bufo.png")) + m `encodesTo` "{\"type\":\"custom_emoji\",\"custom_emoji\":{\"id\":\"e1\",\"name\":\"bufo\",\"url\":\"https://example.com/bufo.png\"}}", + testCase "user mention keeps the full user" $ do + m <- decodeMention "{\"type\":\"user\",\"user\":{\"object\":\"user\",\"id\":\"u9\",\"type\":\"person\",\"name\":\"Sato Kenji\",\"avatar_url\":null,\"person\":{}}}" + case m of + UserMention (FullUser UserObject {name}) -> name @?= Just "Sato Kenji" + other -> assertFailure ("expected a full user mention, got " <> show other) + partial <- decodeMention "{\"type\":\"user\",\"user\":{\"object\":\"user\",\"id\":\"u10\"}}" + partial @?= UserMention (PartialUser (UUID "u10")) + ] + +------------------------------------------------------------------------------ +-- Milestone 3: users, file uploads, icons and object types + +userFileUploadObjectTypeTests :: [TestTree] +userFileUploadObjectTypeTests = + [ testCase "custom emoji icon keeps name and url" $ do + let fixture = "{\"type\":\"custom_emoji\",\"custom_emoji\":{\"id\":\"e2\",\"name\":\"sakura\",\"url\":\"https://example.com/sakura.png\"}}" + i <- decodeOrFail fixture + i @?= CustomEmojiIcon (CustomEmojiRef (UUID "e2") (Just "sakura") (Just "https://example.com/sakura.png")) + i `encodesTo` fixture, + testCase "native icon with an unknown color" $ do + i <- decodeOrFail "{\"type\":\"icon\",\"icon\":{\"name\":\"pizza\",\"color\":\"teal\"}}" + i @?= NativeIcon "pizza" (Just (UnknownNoticonColor "teal")), + testCase "ObjectType new and unknown values" $ do + let known = + [ (FileUploadObjectType, "file_upload"), + (PageMarkdownObjectType, "page_markdown"), + (AsyncTaskObjectType, "async_task"), + (GroupObjectType, "group"), + (DataSource, "data_source") + ] + mapM_ + ( \(ot, str) -> do + decoded <- decodeOrFail ("\"" <> str <> "\"") + decoded @?= ot + Aeson.toJSON ot @?= Aeson.String str + ) + known + unknown <- decodeOrFail "\"meeting_room\"" + unknown @?= UnknownObjectType "meeting_room", + testCase "PageMarkdown decodes object, with or without the key" $ do + md <- decodeOrFail "{\"object\":\"page_markdown\",\"id\":\"p1\",\"markdown\":\"# hi\",\"truncated\":false,\"unknown_block_ids\":[]}" + let PageMarkdown {object} = md + object @?= PageMarkdownObjectType + legacy <- decodeOrFail "{\"id\":\"p1\",\"markdown\":\"# hi\",\"truncated\":false,\"unknown_block_ids\":[]}" + let PageMarkdown {object = legacyObject} = legacy + legacyObject @?= PageMarkdownObjectType, + testCase "file upload with URLs and an agent creator" $ do + fu <- + decodeOrFail + "{\"object\":\"file_upload\",\"id\":\"fu1\",\"created_time\":\"2026-09-14T10:00:00.000Z\",\"last_edited_time\":\"2026-09-14T10:00:00.000Z\",\"created_by\":{\"id\":\"a1\",\"type\":\"agent\"},\"in_trash\":false,\"archived\":false,\"expiry_time\":null,\"status\":\"pending\",\"filename\":null,\"content_type\":null,\"content_length\":null,\"upload_url\":\"https://api.notion.com/v1/file_uploads/fu1/send\",\"complete_url\":\"https://api.notion.com/v1/file_uploads/fu1/complete\"}" + let FU.FileUploadObject {createdBy, uploadUrl, completeUrl} = fu + createdBy @?= FU.FileUploadCreator (UUID "a1") FU.CreatorAgent + uploadUrl @?= Just "https://api.notion.com/v1/file_uploads/fu1/send" + completeUrl @?= Just "https://api.notion.com/v1/file_uploads/fu1/complete", + testCase "CreateFileUpload encodes a typed mode" $ + case Aeson.toJSON (FU.mkMultiPartUpload "動画.mp4" 3 Nothing) of + Aeson.Object o -> KeyMap.lookup "mode" o @?= Just (Aeson.String "multi_part") + other -> assertFailure ("expected object, got " <> show other), + testCase "bot user with an empty bot object decodes" $ do + u <- decodeOrFail "{\"object\":\"user\",\"id\":\"b1\",\"type\":\"bot\",\"name\":\"Kaizen Bot\",\"avatar_url\":null,\"bot\":{}}" + let UserObject {type_} = u + type_ @?= Bot + ] + +------------------------------------------------------------------------------ +-- Milestone 4: webhooks + +-- | Decode a webhook event built from a shared base payload plus the given +-- @type@, @entity@ and (optionally) @data@ JSON fragments. +decodeEvent :: Text -> Text -> Maybe Text -> IO WebhookEvent +decodeEvent eventType entity mData = + decodeOrFail $ + "{\"id\":\"evt-1\",\"timestamp\":\"2026-09-14T10:00:00.000Z\",\"workspace_id\":\"ws-1\",\"workspace_name\":\"Yamada Lab\",\"subscription_id\":\"sub-1\",\"integration_id\":\"int-1\",\"authors\":[{\"id\":\"u1\",\"type\":\"person\"}],\"attempt_number\":1,\"api_version\":\"2026-03-11\",\"type\":\"" + <> eventType + <> "\",\"entity\":" + <> entity + <> maybe "" (",\"data\":" <>) mData + <> "}" + +webhookTests :: [TestTree] +webhookTests = + [ testCase "file_upload.upload_failed" $ do + e <- + decodeEvent + "file_upload.upload_failed" + "{\"id\":\"fu-1\",\"type\":\"file_upload\"}" + (Just "{\"file_import_result\":{\"type\":\"error\",\"imported_time\":\"2026-09-14T10:00:00.000Z\",\"error\":{\"type\":\"download_error\",\"code\":\"timeout\",\"message\":\"Download timed out\",\"parameter\":null,\"status_code\":504}}}") + let WebhookEvent {type_, entity = WebhookEntity {type_ = entityType}, workspaceName, apiVersion, data_} = e + type_ @?= FileUploadUploadFailed + entityType @?= FileUploadEntity + workspaceName @?= Just "Yamada Lab" + apiVersion @?= Just "2026-03-11" + case data_ of + Just (FileUploadFailedData FU.FileImportError {errorCode, errorStatusCode}) -> do + errorCode @?= "timeout" + errorStatusCode @?= Just 504 + other -> assertFailure ("expected FileUploadFailedData, got " <> show other), + testCase "file_upload.created has no data" $ do + e <- decodeEvent "file_upload.created" "{\"id\":\"fu-1\",\"type\":\"file_upload\"}" Nothing + let WebhookEvent {type_, data_} = e + type_ @?= FileUploadCreated + case data_ of + Nothing -> pure () + other -> assertFailure ("expected no data, got " <> show other), + testCase "page.transcription_block.transcript_deleted" $ do + e <- + decodeEvent + "page.transcription_block.transcript_deleted" + "{\"id\":\"b1\",\"type\":\"page\"}" + (Just "{\"target\":{\"id\":\"b1\",\"type\":\"block\"},\"transcript_id\":null}") + let WebhookEvent {type_, data_} = e + type_ @?= PageTranscriptBlockTranscriptDeleted + case data_ of + Just (TranscriptDeletedData ref tid) -> do + ref @?= WebhookBlockRef (UUID "b1") WebhookRefBlock + tid @?= Nothing + other -> assertFailure ("expected TranscriptDeletedData, got " <> show other), + testCase "database.content_updated on a linked database block" $ do + e <- + decodeEvent + "database.content_updated" + "{\"id\":\"d1\",\"type\":\"block\"}" + (Just "{\"parent\":{\"id\":\"p1\",\"type\":\"page\"},\"updated_blocks\":[{\"id\":\"b2\",\"type\":\"block\"}]}") + let WebhookEvent {entity = WebhookEntity {type_ = entityType}, data_} = e + entityType @?= BlockEntity + case data_ of + Just (ContentUpdatedData WebhookParent {type_ = parentType} refs) -> do + parentType @?= WebhookParentPage + Vector.toList refs @?= [WebhookBlockRef (UUID "b2") WebhookRefBlock] + other -> assertFailure ("expected ContentUpdatedData, got " <> show other), + testCase "data_source.schema_updated" $ do + e <- + decodeEvent + "data_source.schema_updated" + "{\"id\":\"ds1\",\"type\":\"data_source\"}" + (Just "{\"parent\":{\"id\":\"db1\",\"type\":\"database\",\"data_source_id\":\"ds1\"},\"updated_properties\":[{\"id\":\"abc\",\"name\":null,\"action\":\"deleted\"}]}") + case e of + WebhookEvent {data_ = Just (SchemaUpdatedData WebhookParent {dataSourceId} props)} -> do + dataSourceId @?= Just (UUID "ds1") + Vector.toList props @?= [UpdatedPropertySchema "abc" Nothing PropertyDeleted] + other -> assertFailure ("expected SchemaUpdatedData, got " <> show other), + testCase "page.properties_updated" $ do + e <- + decodeEvent + "page.properties_updated" + "{\"id\":\"p1\",\"type\":\"page\"}" + (Just "{\"parent\":{\"id\":\"s1\",\"type\":\"space\"},\"updated_properties\":[\"title\",\"xyz\"]}") + case e of + WebhookEvent {data_ = Just (PagePropertiesUpdatedData WebhookParent {type_ = parentType} props)} -> do + parentType @?= WebhookParentSpace + Vector.toList props @?= ["title", "xyz"] + other -> assertFailure ("expected PagePropertiesUpdatedData, got " <> show other), + testCase "view.updated" $ do + e <- + decodeEvent + "view.updated" + "{\"id\":\"v1\",\"type\":\"view\"}" + (Just "{\"parent\":{\"id\":\"db1\",\"type\":\"database\"},\"updated_fields\":[\"filter\",\"sorts\"]}") + case e of + WebhookEvent {data_ = Just (ViewUpdatedData _ fields)} -> Vector.toList fields @?= [ViewFieldFilter, ViewFieldSorts] + other -> assertFailure ("expected ViewUpdatedData, got " <> show other), + testCase "comment.created" $ do + e <- + decodeEvent + "comment.created" + "{\"id\":\"c1\",\"type\":\"comment\"}" + (Just "{\"parent\":{\"id\":\"p1\",\"type\":\"page\"},\"page_id\":\"p1\"}") + case e of + WebhookEvent {data_ = Just (CommentEventData ref pid)} -> do + ref @?= WebhookBlockRef (UUID "p1") WebhookRefPage + pid @?= UUID "p1" + other -> assertFailure ("expected CommentEventData, got " <> show other), + testCase "mismatched data falls back to RawEventData" $ do + e <- decodeEvent "page.created" "{\"id\":\"p1\",\"type\":\"page\"}" (Just "{\"unexpected\":true}") + case e of + WebhookEvent {data_ = Just (RawEventData raw)} -> raw `encodesTo` "{\"unexpected\":true}" + other -> assertFailure ("expected RawEventData, got " <> show other), + testCase "typed event data re-encodes to the wire shape" $ + ContentUpdatedData (WebhookParent (UUID "p1") WebhookParentPage Nothing) (Vector.singleton (WebhookBlockRef (UUID "b2") WebhookRefBlock)) + `encodesTo` "{\"parent\":{\"id\":\"p1\",\"type\":\"page\"},\"updated_blocks\":[{\"id\":\"b2\",\"type\":\"block\"}]}" + ] diff --git a/tasty/RuntimeTests.hs b/tasty/RuntimeTests.hs new file mode 100644 --- /dev/null +++ b/tasty/RuntimeTests.hs @@ -0,0 +1,318 @@ +-- | Tests for the client runtime: configuration, errors and retries. +module RuntimeTests (tests) where + +import Control.Exception (SomeException, fromException, throwIO, toException, try) +import Data.Aeson qualified as Aeson +import Data.ByteString qualified as BS +import Data.ByteString.Lazy.Char8 qualified as L8 +import Data.IORef (modifyIORef', newIORef, readIORef) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..), secondsToDiffTime) +import FakeNotion +import Network.HTTP.Client qualified as HTTP +import Network.HTTP.Types qualified as HTTP +import Notion.V1 +import Notion.V1.Client (applyTimeout) +import Notion.V1.Common (UUID (..)) +import Notion.V1.Error +import Notion.V1.ListOf (IncompleteReason (..), ListOf (..), RequestStatus (..), RequestStatusType (..)) +import Notion.V1.Retry (canRetry, parseRetryAfter, retryDelay, validateRequestPath) +import Notion.V1.Search (SearchRequest (..)) +import Servant.Client (ClientEnv (..), ClientError (..)) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Runtime" + [ testGroup "Configuration" configurationTests, + testGroup "Errors" errorTests, + testGroup "Retry policy" retryPolicyTests, + testGroup "Retry loop" retryLoopTests + ] + +-- | A bot user fixture (made-up name). +userJson :: L8.ByteString +userJson = + "{\"object\":\"user\",\"id\":\"6f1c2b9e-4d3a-4e8f-9b7c-2a1d0e5f3c4b\",\"name\":\"Sato Kenji Bot\",\"avatar_url\":null,\"type\":\"bot\",\"bot\":{\"owner\":{\"type\":\"workspace\",\"workspace\":true},\"workspace_name\":\"Sato Kenji's Workspace\"}}" + +-- | Run one call against a fake that answers with the user fixture. +singleRequest :: (ClientEnv -> Methods) -> IO Recorded +singleRequest mk = do + (env, recorded) <- fakeClientEnv [jsonReply 200 userJson] + _ <- retrieveMyUser (mk env) + readIORef recorded >>= \case + [r] -> pure r + rs -> assertFailure ("expected one request, got " <> show (length rs)) + +configurationTests :: [TestTree] +configurationTests = + [ testCase "makeMethods sends default Notion-Version, Bearer token and User-Agent" $ do + r <- singleRequest (`makeMethods` "secret_tanaka") + lookupRecordedHeader "Authorization" r @?= Just "Bearer secret_tanaka" + lookupRecordedHeader "Notion-Version" r @?= Just "2026-03-11" + case lookupRecordedHeader "User-Agent" r of + Just ua -> assertBool ("User-Agent: " <> show ua) ("notion-client-haskell/" `BS.isPrefixOf` ua) + Nothing -> assertFailure "no User-Agent header" + path r @?= "/users/me", + testCase "makeMethodsWithEnv honors a configured Notion-Version" $ do + r <- singleRequest (\env -> makeMethodsWithEnv defaultClientConfig {notionVersion = "2025-09-03"} env "secret_tanaka") + lookupRecordedHeader "Notion-Version" r @?= Just "2025-09-03", + testCase "applyTimeout sets responseTimeout" $ do + -- ResponseTimeout has no Eq instance; compare its Show output. + show (HTTP.responseTimeout (applyTimeoutFor (Just 5))) + @?= show (HTTP.responseTimeoutMicro 5000000) + show (HTTP.responseTimeout (applyTimeoutFor Nothing)) + @?= show HTTP.responseTimeoutDefault, + testCase "standardHeaders match what Methods sends" $ do + r <- singleRequest (`makeMethods` "secret_tanaka") + (env, _) <- fakeClientEnv [] + let context = requestContextFor legacyClientConfig env "secret_tanaka" + sent = [(n, v) | (n, v) <- headers r, n `elem` ["Authorization", "Notion-Version", "User-Agent"]] + standardHeaders context @?= sent + contextBaseUrl context @?= fakeBaseUrl + ] + where + applyTimeoutFor t = applyTimeout defaultClientConfig {timeout = t} HTTP.defaultRequest + +allCodeStrings :: [Text] +allCodeStrings = + [ "unauthorized", + "restricted_resource", + "object_not_found", + "rate_limited", + "invalid_json", + "invalid_request_url", + "invalid_request", + "invalid_beta", + "validation_error", + "conflict_error", + "internal_server_error", + "service_overload", + "service_unavailable", + "gateway_timeout" + ] + +notFoundBody :: Bool -> L8.ByteString +notFoundBody withRequestId = + "{\"object\":\"error\",\"status\":404,\"code\":\"object_not_found\",\"message\":\"Could not find page with ID: 5c6a2821-6bb1-4a7e-b6e1-c50111515c3d.\"" + <> (if withRequestId then ",\"request_id\":\"b1e0a4c2-7f3d-4e21-9a55-1c2d3e4f5a6b\"" else "") + <> ",\"additional_data\":{\"integration_name\":\"Tanaka Hanako Integration\"}}" + +notFoundHeaders :: [(HTTP.HeaderName, BS.ByteString)] +notFoundHeaders = + [("Content-Type", "application/json"), ("x-notion-request-id", "req-header-1"), ("cf-ray", "8a1b2c3d4e5f-NRT")] + +validationBody :: L8.ByteString +validationBody = + "{\"object\":\"error\",\"status\":400,\"code\":\"validation_error\",\"message\":\"body failed validation.\"}" + +errorTests :: [TestTree] +errorTests = + [ testCase "APIErrorCode round-trips all 14 codes" $ do + length allCodeStrings @?= 14 + mapM_ (\t -> apiErrorCodeText (parseAPIErrorCode t) @?= t) allCodeStrings + assertBool "all 14 are known" (all (not . isUnknown . parseAPIErrorCode) allCodeStrings) + parseAPIErrorCode "brand_new_code" @?= UnknownErrorCode "brand_new_code", + testCase "buildRequestError parses a Notion error with headers" $ + case buildRequestError 404 notFoundHeaders (notFoundBody True) of + Right NotionError {code, requestId, additionalData, response} -> do + code @?= ObjectNotFound + requestId @?= Just "b1e0a4c2-7f3d-4e21-9a55-1c2d3e4f5a6b" + additionalData @?= Just (Aeson.object ["integration_name" Aeson..= ("Tanaka Hanako Integration" :: Text)]) + fmap rayId response @?= Just (Just "8a1b2c3d4e5f-NRT") + fmap httpStatus response @?= Just 404 + Left e -> assertFailure ("expected NotionError, got " <> show e), + testCase "request_id falls back to the x-notion-request-id header" $ + case buildRequestError 404 notFoundHeaders (notFoundBody False) of + Right NotionError {requestId} -> requestId @?= Just "req-header-1" + Left e -> assertFailure ("expected NotionError, got " <> show e), + testCase "Cloudflare HTML 403 becomes UnknownHTTPResponseError" $ + case buildRequestError 403 [("content-type", "text/html"), ("cf-ray", "8a1b2c3d4e5f-NRT")] "blocked" of + Left e -> + unknownResponseMessage e + @?= "Request to Notion API failed with status: 403. The response was returned by Notion's edge proxy before reaching the Notion API (content-type: text/html). This may mean the request was blocked by a network security rule. Cloudflare Ray ID: 8a1b2c3d4e5f-NRT. Include this ID when contacting Notion support." + Right e -> assertFailure ("expected UnknownHTTPResponseError, got " <> show e), + testCase "non-JSON 502 without cf-ray has the short message" $ + case buildRequestError 502 [("content-type", "text/plain")] "Bad Gateway" of + Left e -> unknownResponseMessage e @?= "Request to Notion API failed with status: 502" + Right e -> assertFailure ("expected UnknownHTTPResponseError, got " <> show e), + testCase "timeouts become RequestTimeoutError" $ do + let timeoutErr = ConnectionError (toException (HTTP.HttpExceptionRequest HTTP.defaultRequest HTTP.ResponseTimeout)) + fromExceptionOf (fromClientError timeoutErr) @?= Just RequestTimeoutError, + testCase "makeMethods throws a typed NotionError" $ do + (env, _) <- fakeClientEnv [FakeReply 400 [("Content-Type", "application/json"), ("x-notion-request-id", "req-9")] validationBody] + result <- try @NotionError (retrieveMyUser (makeMethodsWithEnv defaultClientConfig {retryOptions = noRetries} env "secret_tanaka")) + case result of + Left NotionError {code, requestId, response} -> do + code @?= ValidationError + requestId @?= Just "req-9" + fmap httpStatus response @?= Just 400 + Right _ -> assertFailure "expected a NotionError", + testCase "ListOf decodes request_status" $ do + let listWith extra = + "{\"object\":\"list\",\"results\":[],\"next_cursor\":null,\"has_more\":false,\"type\":\"page_or_data_source\",\"page_or_data_source\":{}" + <> extra + <> "}" + decodeStatus :: L8.ByteString -> Either String (Maybe RequestStatus) + decodeStatus bytes = (\List {requestStatus} -> requestStatus) <$> (Aeson.eitherDecode bytes :: Either String (ListOf Aeson.Value)) + decodeStatus (listWith ",\"request_status\":{\"type\":\"incomplete\",\"incomplete_reason\":\"query_result_limit_reached\"}") + @?= Right (Just (RequestStatus RequestIncomplete (Just QueryResultLimitReached))) + decodeStatus (listWith "") @?= Right Nothing + decodeStatus (listWith ",\"request_status\":{\"type\":\"partial\"}") + @?= Right (Just (RequestStatus (UnknownRequestStatusType "partial") Nothing)) + ] + where + isUnknown = \case + UnknownErrorCode _ -> True + _ -> False + fromExceptionOf :: SomeException -> Maybe RequestTimeoutError + fromExceptionOf = fromException + +------------------------------------------------------------------------------ +-- Retries + +retryPolicyTests :: [TestTree] +retryPolicyTests = + [ testCase "canRetry follows the JS SDK rules" $ do + canRetry HTTP.methodPost RateLimited @?= True + canRetry HTTP.methodPost ServiceOverload @?= True + canRetry HTTP.methodPost InternalServerError @?= False + canRetry HTTP.methodGet InternalServerError @?= True + canRetry HTTP.methodDelete ServiceUnavailable @?= True + canRetry HTTP.methodPatch ServiceUnavailable @?= False + canRetry HTTP.methodGet GatewayTimeout @?= False + canRetry HTTP.methodGet (UnknownErrorCode "x") @?= False + canRetry HTTP.methodGet ObjectNotFound @?= False, + testCase "parseRetryAfter reads seconds and HTTP dates" $ do + let now = UTCTime (fromGregorian 2015 10 21) (secondsToDiffTime (7 * 3600 + 27 * 60 + 30)) + parseRetryAfter now "120" @?= Just 120 + parseRetryAfter now "0" @?= Just 0 + parseRetryAfter now " 7" @?= Just 7 + parseRetryAfter now "1.5" @?= Just 1 + parseRetryAfter now "Wed, 21 Oct 2015 07:28:00 GMT" @?= Just 30 + parseRetryAfter now "Wed, 21 Oct 2015 07:00:00 GMT" @?= Just 0 + parseRetryAfter now "soon" @?= Nothing + parseRetryAfter now "" @?= Nothing, + testCase "retryDelay uses back-off with jitter and caps retry-after" $ do + retryDelay defaultRetryOptions 0 0 Nothing @?= 0.5 + retryDelay defaultRetryOptions 1 0.5 Nothing @?= 2 + retryDelay defaultRetryOptions 10 0.9 Nothing @?= 60 + retryDelay defaultRetryOptions 0 0 (Just 120) @?= 60 + retryDelay defaultRetryOptions 0 0 (Just 5) @?= 5, + testCase "validateRequestPath rejects path traversal" $ do + validateRequestPath "/pages/5c6a28216bb14a7eb6e1c50111515c3d" @?= Right () + validateRequestPath "/pages/.." @?= Left (InvalidPathParameterError "/pages/..") + validateRequestPath "/pages/%2E%2E" @?= Left (InvalidPathParameterError "/pages/%2E%2E") + validateRequestPath "/pages/%252e%252e" @?= Right () + ] + +-- | Retries with millisecond delays so the tests run quickly. +fastRetryConfig :: ClientConfig +fastRetryConfig = + defaultClientConfig {retryOptions = defaultRetryOptions {initialRetryDelay = 0.001, maxRetryDelay = 0.01}} + +errorReply :: Int -> Text -> FakeReply +errorReply status code = + jsonReply status $ + "{\"object\":\"error\",\"status\":" + <> L8.pack (show status) + <> ",\"code\":\"" + <> L8.pack (Text.unpack code) + <> "\",\"message\":\"scripted failure\"}" + +rateLimitedReply :: FakeReply +rateLimitedReply = + FakeReply + 429 + [("Content-Type", "application/json"), ("Retry-After", "0")] + "{\"object\":\"error\",\"status\":429,\"code\":\"rate_limited\",\"message\":\"You have been rate limited. Please try again in a few minutes.\"}" + +emptyListJson :: L8.ByteString +emptyListJson = "{\"object\":\"list\",\"results\":[],\"next_cursor\":null,\"has_more\":false}" + +emptySearch :: SearchRequest +emptySearch = SearchRequest {query = Nothing, sort = Nothing, filter = Nothing, startCursor = Nothing, pageSize = Nothing} + +-- | Run a call against a scripted fake and return the result and request count. +runScripted :: ClientConfig -> [FakeReply] -> (Methods -> IO a) -> IO (Either SomeException a, Int) +runScripted config script call = do + (env, recorded) <- fakeClientEnv script + result <- try (call (makeMethodsWithEnv config env "secret_tanaka")) + n <- length <$> readIORef recorded + pure (result, n) + +expectCode :: APIErrorCode -> Either SomeException a -> Assertion +expectCode expected = \case + Left ex | Just NotionError {code} <- fromException ex -> code @?= expected + Left ex -> assertFailure ("expected NotionError, got " <> show ex) + Right _ -> assertFailure "expected a failure" + +retryLoopTests :: [TestTree] +retryLoopTests = + [ testCase "GET retried after 429 then succeeds" $ do + (result, n) <- runScripted fastRetryConfig [rateLimitedReply, jsonReply 200 userJson] retrieveMyUser + either (assertFailure . show) (const (pure ())) result + n @?= 2, + testCase "POST retried after 529" $ do + (result, n) <- runScripted fastRetryConfig [errorReply 529 "service_overload", jsonReply 200 emptyListJson] (`search` emptySearch) + either (assertFailure . show) (const (pure ())) result + n @?= 2, + testCase "POST not retried on 500" $ do + (result, n) <- runScripted fastRetryConfig [errorReply 500 "internal_server_error", jsonReply 200 emptyListJson] (`search` emptySearch) + expectCode InternalServerError result + n @?= 1, + testCase "GET retried on 503 until maxRetries then throws" $ do + (result, n) <- runScripted fastRetryConfig (replicate 3 (errorReply 503 "service_unavailable")) retrieveMyUser + expectCode ServiceUnavailable result + n @?= 3, + testCase "noRetries disables retries" $ do + (result, n) <- runScripted defaultClientConfig {retryOptions = noRetries} [rateLimitedReply, jsonReply 200 userJson] retrieveMyUser + expectCode RateLimited result + n @?= 1, + testCase "withRetries wraps a plain IO action" $ do + calls <- newIORef (0 :: Int) + let failWith status = do + modifyIORef' calls (+ 1) + count <- readIORef calls + if count == 1 + then throwIO (notionErrorFromResponse status [("Retry-After", "0")] (rateLimitedBodyFor status)) + else pure ("ok" :: Text) + r <- withRetries fastRetryConfig HTTP.methodPost "/sessions" (failWith HTTP.status429) + r @?= "ok" + readIORef calls >>= (@?= 2) + calls2 <- newIORef (0 :: Int) + let alwaysFail = modifyIORef' calls2 (+ 1) >> throwIO (notionErrorFromResponse HTTP.status500 [] (rateLimitedBodyFor HTTP.status500)) + r2 <- try @NotionError (withRetries fastRetryConfig HTTP.methodPost "/sessions" (alwaysFail :: IO Text)) + either (\NotionError {code} -> code @?= InternalServerError) (const (assertFailure "expected failure")) r2 + readIORef calls2 >>= (@?= 1), + testCase "HTML 429 is not retried" $ do + (result, n) <- runScripted fastRetryConfig [FakeReply 429 [("Content-Type", "text/html")] "", jsonReply 200 userJson] retrieveMyUser + case result of + Left ex | Just (_ :: UnknownHTTPResponseError) <- fromException ex -> pure () + other -> assertFailure ("expected UnknownHTTPResponseError, got " <> either show (const "success") other) + n @?= 1, + testCase "logger sees retry lines" $ do + logged <- newIORef [] + let config = fastRetryConfig {logger = Just (\_ msg _ -> modifyIORef' logged (<> [msg])), logLevel = LogDebug} + (result, _) <- runScripted config [rateLimitedReply, jsonReply 200 userJson] retrieveMyUser + either (assertFailure . show) (const (pure ())) result + messages <- readIORef logged + Prelude.filter (`elem` ["request start", "request fail", "retrying request", "request success"]) messages + @?= ["request start", "request fail", "retrying request", "request success"], + testCase "path traversal rejected before sending" $ do + (result, n) <- runScripted fastRetryConfig [jsonReply 200 userJson] (`retrievePage` UUID "..") + case result of + Left ex | Just (_ :: InvalidPathParameterError) <- fromException ex -> pure () + other -> assertFailure ("expected InvalidPathParameterError, got " <> either show (const "success") other) + n @?= 0 + ] + where + rateLimitedBodyFor status = + let HTTP.Status {HTTP.statusCode = c} = status + codeText :: L8.ByteString + codeText = if c == 429 then "rate_limited" else "internal_server_error" + in "{\"object\":\"error\",\"status\":" <> L8.pack (show c) <> ",\"code\":\"" <> codeText <> "\",\"message\":\"scripted failure\"}" diff --git a/tasty/ViewTests.hs b/tasty/ViewTests.hs new file mode 100644 --- /dev/null +++ b/tasty/ViewTests.hs @@ -0,0 +1,496 @@ +-- | View queries and typed view configuration (EP-4). +module ViewTests (tests) where + +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy.Char8 qualified as L8 +import Data.IORef (readIORef) +import Data.Map.Strict qualified as Map +import Data.Vector qualified as Vector +import FakeNotion +import Notion.V1 (makeMethods) +import Notion.V1.Common (Parent (..), UUID (..)) +import Notion.V1.Filter +import Notion.V1.ListOf (ListOf (..)) +import Notion.V1.ViewQueries (queryAllViewPages) +import Notion.V1.Views +import Test.Tasty +import Test.Tasty.HUnit +import Prelude hiding (id) + +tests :: TestTree +tests = + testGroup + "Views (EP-4)" + [ viewQueryTests, + filterSortTests, + viewObjectTests, + viewRequestTests, + viewConfigTests + ] + +-- --------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------- + +decodeOrFail :: (Aeson.FromJSON a) => L8.ByteString -> IO a +decodeOrFail bytes = either (assertFailure . ("decode failed: " <>)) pure (Aeson.eitherDecode bytes) + +jsonValue :: L8.ByteString -> Aeson.Value +jsonValue bytes = either error (\v -> v) (Aeson.eitherDecode bytes) + +-- --------------------------------------------------------------------- +-- View queries +-- --------------------------------------------------------------------- + +viewQueryTests :: TestTree +viewQueryTests = + testGroup + "View queries" + [ testCase "decode ViewQuery (create response)" testDecodeViewQuery, + testCase "decode view query results list" testDecodeResults, + testCase "decode DeletedViewQuery" testDecodeDeleted, + testCase "encode CreateViewQuery" testEncodeCreateViewQuery, + testCase "queryAllViewPages follows cursors and deletes the query" testQueryAllViewPages + ] + +viewQueryFixture :: L8.ByteString +viewQueryFixture = + "{\"object\":\"view_query\",\"id\":\"7f1c2a9e-3b4d-4e5f-8a6b-1c2d3e4f5a6b\",\ + \\"view_id\":\"2b3c4d5e-6f70-4812-9a3b-4c5d6e7f8091\",\"expires_at\":\"2026-09-14T19:15:00.000Z\",\ + \\"total_count\":3,\"results\":[{\"object\":\"page\",\"id\":\"11111111-2222-4333-8444-555555555555\"},\ + \{\"object\":\"page\",\"id\":\"66666666-7777-4888-9999-aaaaaaaaaaaa\"}],\ + \\"next_cursor\":\"66666666-7777-4888-9999-aaaaaaaaaaaa\",\"has_more\":true}" + +resultsFixture :: L8.ByteString +resultsFixture = + "{\"object\":\"list\",\"next_cursor\":null,\"has_more\":false,\ + \\"results\":[{\"object\":\"page\",\"id\":\"bbbbbbbb-cccc-4ddd-8eee-ffffffffffff\"}],\ + \\"type\":\"page\",\"page\":{}}" + +deletedFixture :: L8.ByteString +deletedFixture = "{\"object\":\"view_query\",\"id\":\"7f1c2a9e-3b4d-4e5f-8a6b-1c2d3e4f5a6b\",\"deleted\":true}" + +testDecodeViewQuery :: Assertion +testDecodeViewQuery = do + ViewQuery {totalCount, results, hasMore, nextCursor, requestStatus} <- decodeOrFail viewQueryFixture + totalCount @?= 3 + Vector.length results @?= 2 + hasMore @?= True + nextCursor @?= Just "66666666-7777-4888-9999-aaaaaaaaaaaa" + requestStatus @?= Nothing + +testDecodeResults :: Assertion +testDecodeResults = do + List {results, hasMore} <- decodeOrFail resultsFixture :: IO (ListOf PartialPageObject) + map (\PartialPageObject {id} -> id) (Vector.toList results) @?= [UUID "bbbbbbbb-cccc-4ddd-8eee-ffffffffffff"] + hasMore @?= False + +testDecodeDeleted :: Assertion +testDecodeDeleted = do + DeletedViewQuery {deleted} <- decodeOrFail deletedFixture + deleted @?= True + +testEncodeCreateViewQuery :: Assertion +testEncodeCreateViewQuery = do + Aeson.toJSON CreateViewQuery {pageSize = Just 50} @?= jsonValue "{\"page_size\":50}" + Aeson.toJSON CreateViewQuery {pageSize = Nothing} @?= jsonValue "{}" + +testQueryAllViewPages :: Assertion +testQueryAllViewPages = do + (env, recorded) <- + fakeClientEnv + [ jsonReply 200 viewQueryFixture, + jsonReply 200 resultsFixture, + jsonReply 200 deletedFixture + ] + let methods = makeMethods env "secret_test" + pages <- queryAllViewPages methods "2b3c4d5e-6f70-4812-9a3b-4c5d6e7f8091" (Just 2) + map (\PartialPageObject {id} -> id) (Vector.toList pages) + @?= [ UUID "11111111-2222-4333-8444-555555555555", + UUID "66666666-7777-4888-9999-aaaaaaaaaaaa", + UUID "bbbbbbbb-cccc-4ddd-8eee-ffffffffffff" + ] + reqs <- readIORef recorded + map (\Recorded {method, path} -> (method, path)) reqs + @?= [ ("POST", "/views/2b3c4d5e-6f70-4812-9a3b-4c5d6e7f8091/queries"), + ("GET", "/views/2b3c4d5e-6f70-4812-9a3b-4c5d6e7f8091/queries/7f1c2a9e-3b4d-4e5f-8a6b-1c2d3e4f5a6b"), + ("DELETE", "/views/2b3c4d5e-6f70-4812-9a3b-4c5d6e7f8091/queries/7f1c2a9e-3b4d-4e5f-8a6b-1c2d3e4f5a6b") + ] + +-- --------------------------------------------------------------------- +-- Filters and sorts +-- --------------------------------------------------------------------- + +filterSortTests :: TestTree +filterSortTests = + testGroup + "Filters and sorts" + [ testCase "Filter values round-trip through JSON" testFilterRoundTrip, + testCase "Sort values round-trip through JSON" testSortRoundTrip, + testCase "array-valued select filter survives as ViewFilter" testArrayFilterPreserved + ] + +sampleFilters :: [Filter] +sampleFilters = + [ And + [ PropertyFilter "Name" (TitleCondition (TextContains "Tanaka")), + Or + [ PropertyFilter "Notes" (RichTextCondition TextIsEmpty), + PropertyFilter "Phone" (PhoneNumberCondition (TextStartsWith "+81")) + ] + ], + TimestampFilter FilterLastEditedTime DateNextWeek, + TimestampFilter FilterCreatedTime (DateOnOrAfter "2026-09-01"), + PropertyFilter "Estimate" (NumberCondition (NumGreaterThanOrEqualTo 2.5)), + PropertyFilter "Done" (CheckboxCondition (CheckboxDoesNotEqual True)), + PropertyFilter "Priority" (SelectCondition (SelectEquals "High")), + PropertyFilter "Tags" (MultiSelectCondition MultiSelectIsNotEmpty), + PropertyFilter "Due" (DateCondition DatePastMonth), + PropertyFilter "Owner" (PeopleCondition (PeopleContains "u1u1u1u1-0000-4000-8000-000000000004")), + PropertyFilter "Attachments" (FilesCondition FilesIsEmpty), + PropertyFilter "Project" (RelationCondition (RelationDoesNotContain "p1")), + PropertyFilter "Stage" (StatusCondition (StatusEquals "In progress")), + PropertyFilter "Rollup" (RollupCondition (RollupAny (RichTextCondition (TextContains "Sato")))), + PropertyFilter "Rollup count" (RollupCondition (RollupNumber (NumLessThan 10))), + PropertyFilter "Score" (FormulaCondition (FormulaNumber (NumGreaterThan 3))), + PropertyFilter "Created" (CreatedTimeCondition DateThisYear), + PropertyFilter "Author" (CreatedByCondition PeopleIsEmpty), + PropertyFilter "Edited" (LastEditedTimeCondition (DateBefore "2026-01-01")), + PropertyFilter "Editor" (LastEditedByCondition (PeopleDoesNotContain "u2")), + PropertyFilter "Site" (UrlCondition (TextEndsWith ".jp")), + PropertyFilter "Email" (EmailCondition (TextEquals "hanako@example.com")) + ] + +testFilterRoundTrip :: Assertion +testFilterRoundTrip = + mapM_ (\f -> Aeson.fromJSON (Aeson.toJSON f) @?= Aeson.Success f) sampleFilters + +testSortRoundTrip :: Assertion +testSortRoundTrip = + mapM_ + (\s -> Aeson.fromJSON (Aeson.toJSON s) @?= Aeson.Success s) + [PropertySort "Due" Ascending, TimestampSort FilterLastEditedTime Descending] + +testArrayFilterPreserved :: Assertion +testArrayFilterPreserved = do + let raw = jsonValue "{\"property\":\"Status\",\"select\":{\"does_not_equal\":[\"Done\",\"Archive\"]}}" + case Aeson.fromJSON raw :: Aeson.Result ViewFilter of + Aeson.Success vf -> Aeson.toJSON vf @?= raw + Aeson.Error err -> assertFailure err + +-- --------------------------------------------------------------------- +-- View object +-- --------------------------------------------------------------------- + +viewObjectTests :: TestTree +viewObjectTests = + testGroup + "View object" + [ testCase "decode a board view with typed filter, sorts and quick filters" testDecodeViewObject, + testCase "unknown view type decodes as UnknownViewType" testUnknownViewType + ] + +viewObjectFixture :: L8.ByteString +viewObjectFixture = + "{\"object\":\"view\",\"id\":\"2b3c4d5e-6f70-4812-9a3b-4c5d6e7f8091\",\ + \\"parent\":{\"type\":\"database_id\",\"database_id\":\"d1d1d1d1-0000-4000-8000-000000000002\"},\ + \\"name\":\"Tanaka Hanako's tasks\",\"type\":\"board\",\ + \\"created_time\":\"2026-09-01T09:00:00.000Z\",\"last_edited_time\":\"2026-09-02T10:30:00.000+00:00\",\ + \\"url\":\"https://www.notion.so/d1d1d1d1000040008000000000000002?v=2b3c4d5e6f7048129a3b4c5d6e7f8091\",\ + \\"data_source_id\":\"e5e5e5e5-0000-4000-8000-000000000003\",\ + \\"created_by\":{\"object\":\"user\",\"id\":\"u1u1u1u1-0000-4000-8000-000000000004\"},\ + \\"last_edited_by\":{\"object\":\"user\",\"id\":\"u1u1u1u1-0000-4000-8000-000000000004\"},\ + \\"filter\":{\"and\":[{\"property\":\"Assignee\",\"people\":{\"contains\":\"u1u1u1u1-0000-4000-8000-000000000004\"}},\ + \{\"timestamp\":\"created_time\",\"created_time\":{\"past_month\":{}}}]},\ + \\"sorts\":[{\"timestamp\":\"created_time\",\"direction\":\"descending\"},{\"property\":\"Due\",\"direction\":\"ascending\"}],\ + \\"quick_filters\":{\"Priority\":{\"select\":{\"equals\":\"High\"}}},\ + \\"configuration\":{\"type\":\"board\",\"group_by\":{\"type\":\"status\",\"property_id\":\"a%3Bc\",\ + \\"group_by\":\"group\",\"sort\":{\"type\":\"manual\"},\"property_name\":\"Status\"}}}" + +testDecodeViewObject :: Assertion +testDecodeViewObject = do + ViewObject {parent, type_, filter = viewFilter, sorts, quickFilters} <- decodeOrFail viewObjectFixture + case parent of + Just (DatabaseParent {}) -> pure () + other -> assertFailure ("expected DatabaseParent, got " <> show other) + type_ @?= Just BoardView + viewFilter + @?= Just + ( ViewFilter + ( And + [ PropertyFilter "Assignee" (PeopleCondition (PeopleContains "u1u1u1u1-0000-4000-8000-000000000004")), + TimestampFilter FilterCreatedTime DatePastMonth + ] + ) + ) + fmap Vector.toList sorts + @?= Just [ViewSort (TimestampSort FilterCreatedTime Descending), ViewSort (PropertySort "Due" Ascending)] + quickFilters @?= Just (Map.fromList [("Priority", QuickFilter (SelectCondition (SelectEquals "High")))]) + +testUnknownViewType :: Assertion +testUnknownViewType = do + ViewObject {type_} <- + decodeOrFail "{\"object\":\"view\",\"id\":\"2b3c4d5e-6f70-4812-9a3b-4c5d6e7f8091\",\"type\":\"wiki_board\"}" + type_ @?= Just (UnknownViewType "wiki_board") + +-- --------------------------------------------------------------------- +-- View requests +-- --------------------------------------------------------------------- + +viewRequestTests :: TestTree +viewRequestTests = + testGroup + "View requests" + [ testCase "UpdateView clears, sets and removes quick filters" testUpdateViewClear, + testCase "UpdateView with nothing set encodes to {}" testUpdateViewEmpty, + testCase "CreateView position after_view" testCreateViewPosition, + testCase "CreateView dashboard widget placement" testCreateViewPlacement, + testCase "CreateView create_database" testCreateViewCreateDatabase + ] + +baseCreateView :: ViewID -> Maybe ViewPosition -> Maybe WidgetPlacement -> Maybe CreateDatabaseForView -> CreateView +baseCreateView dashboard position placement createDatabase = + CreateView + { dataSourceId = "ds-1", + name = "Sato Kenji's board", + type_ = BoardView, + databaseId = Nothing, + viewId = if dashboard == "" then Nothing else Just dashboard, + filter = Nothing, + sorts = Nothing, + quickFilters = Nothing, + createDatabase_ = createDatabase, + configuration = Nothing, + position = position, + placement = placement + } + +objectKey :: Aeson.Key -> Aeson.Value -> Maybe Aeson.Value +objectKey k = \case + Aeson.Object o -> KeyMap.lookup k o + _ -> Nothing + +testUpdateViewClear :: Assertion +testUpdateViewClear = + Aeson.toJSON + UpdateView + { name = Nothing, + filter = Clear, + sorts = Set (Vector.fromList [ViewPropertySort {property = "Due", direction = Descending}]), + quickFilters = + Set + ( Map.fromList + [ ("Priority", Nothing), + ("Status", Just (QuickFilter (StatusCondition (StatusEquals "In progress")))) + ] + ), + configuration = Nothing + } + @?= jsonValue + "{\"filter\":null,\"sorts\":[{\"property\":\"Due\",\"direction\":\"descending\"}],\ + \\"quick_filters\":{\"Priority\":null,\"Status\":{\"status\":{\"equals\":\"In progress\"}}}}" + +testUpdateViewEmpty :: Assertion +testUpdateViewEmpty = + Aeson.toJSON UpdateView {name = Nothing, filter = Unset, sorts = Unset, quickFilters = Unset, configuration = Nothing} + @?= jsonValue "{}" + +testCreateViewPosition :: Assertion +testCreateViewPosition = + objectKey "position" (Aeson.toJSON (baseCreateView "" (Just (ViewPositionAfterView "view-9")) Nothing Nothing)) + @?= Just (jsonValue "{\"type\":\"after_view\",\"view_id\":\"view-9\"}") + +testCreateViewPlacement :: Assertion +testCreateViewPlacement = do + let json = Aeson.toJSON (baseCreateView "dash-1" Nothing (Just (ExistingRow 0)) Nothing) + objectKey "view_id" json @?= Just (Aeson.String "dash-1") + objectKey "placement" json @?= Just (jsonValue "{\"type\":\"existing_row\",\"row_index\":0}") + +testCreateViewCreateDatabase :: Assertion +testCreateViewCreateDatabase = do + let json = Aeson.toJSON (baseCreateView "" Nothing Nothing (Just (CreateDatabaseForView "page-1" (Just "block-1")))) + objectKey "create_database" json + @?= Just + ( jsonValue + "{\"parent\":{\"type\":\"page_id\",\"page_id\":\"page-1\"},\ + \\"position\":{\"type\":\"after_block\",\"block_id\":\"block-1\"}}" + ) + objectKey "create_database_" json @?= Nothing + +-- --------------------------------------------------------------------- +-- View configuration +-- --------------------------------------------------------------------- + +viewConfigTests :: TestTree +viewConfigTests = + testGroup + "View configuration" + [ testCase "table configuration round-trips" (roundTrip tableFixture isTable), + testCase "board configuration round-trips" (roundTrip boardFixture isBoard), + testCase "calendar configuration round-trips" (roundTrip calendarFixture isCalendar), + testCase "timeline configuration round-trips" (roundTrip timelineFixture isTimeline), + testCase "gallery configuration round-trips" (roundTrip galleryFixture isGallery), + testCase "list configuration round-trips" (roundTrip listFixture isList), + testCase "chart configuration round-trips" (roundTrip chartFixture isChart), + testCase "number chart configuration round-trips" (roundTrip numberChartFixture isChart), + testCase "map configuration round-trips" (roundTrip mapFixture isMap), + testCase "form configuration round-trips" (roundTrip formFixture isForm), + testCase "dashboard configuration round-trips" (roundTrip dashboardFixture isDashboard), + testCase "map_by_property_name is decoded and dropped" testMapResponseOnly, + testCase "response-only property_name is decoded and dropped" testResponseOnlyStripped, + testCase "unknown configuration type is preserved" testUnknownConfig, + testCase "unknown enum value is preserved" testUnknownEnum, + testCase "formula group-by round-trips" testFormulaGroupBy, + testCase "UpdateView can clear a configuration field" testClearConfigField + ] + +-- | Decode a fixture, check its constructor, and re-encode it to the identical JSON value. +roundTrip :: L8.ByteString -> (ViewConfig -> Bool) -> Assertion +roundTrip fixture expected = do + config <- decodeOrFail fixture + assertBool ("unexpected constructor: " <> show config) (expected config) + Aeson.toJSON config @?= jsonValue fixture + +isTable, isBoard, isCalendar, isTimeline, isGallery, isList, isChart, isMap, isForm, isDashboard :: ViewConfig -> Bool +-- The table and board checks also require a typed (not unknown) group-by. +isTable = \case TableConfig TableViewConfig {groupBy = Set (DateGroupBy {})} -> True; _ -> False +isBoard = \case BoardConfig BoardViewConfig {groupBy = SelectGroupBy {}} -> True; _ -> False +isCalendar = \case CalendarConfig {} -> True; _ -> False +isTimeline = \case TimelineConfig {} -> True; _ -> False +isGallery = \case GalleryConfig {} -> True; _ -> False +isList = \case ListConfig {} -> True; _ -> False +isChart = \case ChartConfig ChartViewConfig {xAxis = x} -> case x of Set UnknownGroupBy {} -> False; _ -> True; _ -> False +isMap = \case MapConfig {} -> True; _ -> False +isForm = \case FormConfig {} -> True; _ -> False +isDashboard = \case DashboardConfig DashboardViewConfig {rows} -> Vector.length rows == 1; _ -> False + +tableFixture :: L8.ByteString +tableFixture = + "{\"type\":\"table\",\"properties\":[{\"property_id\":\"title\",\"visible\":true,\"width\":280,\"wrap\":false},\ + \{\"property_id\":\"d%3Aue\",\"date_format\":\"year_month_day\",\"time_format\":\"24_hour\"}],\ + \\"group_by\":{\"type\":\"date\",\"property_id\":\"d%3Aue\",\"group_by\":\"week\",\"sort\":{\"type\":\"ascending\"},\"start_day_of_week\":1},\ + \\"subtasks\":{\"property_id\":\"r%3Bx\",\"display_mode\":\"flattened\",\"filter_scope\":\"parents_and_subitems\"},\ + \\"wrap_cells\":true,\"frozen_column_index\":1,\"show_vertical_lines\":false}" + +boardFixture :: L8.ByteString +boardFixture = + "{\"type\":\"board\",\"group_by\":{\"type\":\"multi_select\",\"property_id\":\"t%3Ag\",\"sort\":{\"type\":\"manual\"},\"hide_empty_groups\":true},\ + \\"sub_group_by\":null,\"properties\":[{\"property_id\":\"title\",\"card_property_width_mode\":\"full_line\"}],\ + \\"cover\":{\"type\":\"property\",\"property_id\":\"f%3Ail\"},\"cover_size\":\"medium\",\"cover_aspect\":\"cover\",\"card_layout\":\"compact\"}" + +calendarFixture :: L8.ByteString +calendarFixture = "{\"type\":\"calendar\",\"date_property_id\":\"d%3Aue\",\"view_range\":\"week\",\"show_weekends\":false}" + +timelineFixture :: L8.ByteString +timelineFixture = + "{\"type\":\"timeline\",\"date_property_id\":\"d%3Aue\",\"end_date_property_id\":null,\"show_table\":true,\ + \\"table_properties\":[{\"property_id\":\"title\"}],\"preference\":{\"zoom_level\":\"5_years\",\"center_timestamp\":1789000000000},\ + \\"arrows_by\":{\"property_id\":null},\"color_by\":false}" + +galleryFixture :: L8.ByteString +galleryFixture = "{\"type\":\"gallery\",\"cover\":{\"type\":\"page_cover\"},\"cover_size\":\"large\",\"card_layout\":\"list\"}" + +listFixture :: L8.ByteString +listFixture = "{\"type\":\"list\",\"properties\":[{\"property_id\":\"title\",\"visible\":true,\"status_show_as\":\"checkbox\"}]}" + +chartFixture :: L8.ByteString +chartFixture = + "{\"type\":\"chart\",\"chart_type\":\"column\",\ + \\"x_axis\":{\"type\":\"select\",\"property_id\":\"s%3Bq\",\"sort\":{\"type\":\"manual\"}},\ + \\"y_axis\":{\"aggregator\":\"sum\",\"property_id\":\"n%3Aum\"},\"sort\":\"y_descending\",\"color_theme\":\"colorful\",\ + \\"height\":\"extra_large\",\"legend_position\":\"bottom\",\"show_data_labels\":true,\"axis_labels\":\"both\",\ + \\"grid_lines\":\"horizontal\",\"group_style\":\"side_by_side\",\"y_axis_min\":0,\"y_axis_max\":null,\"stack_by\":null,\ + \\"reference_lines\":[{\"id\":\"line-1\",\"value\":75.5,\"label\":\"Target\",\"color\":\"lightgray\",\"dash_style\":\"dash\"}],\ + \\"caption\":null,\"color_by_value\":false}" + +numberChartFixture :: L8.ByteString +numberChartFixture = "{\"type\":\"chart\",\"chart_type\":\"number\",\"value\":{\"aggregator\":\"count\"},\"hide_title\":true}" + +mapFixture :: L8.ByteString +mapFixture = "{\"type\":\"map\",\"height\":\"large\",\"map_by\":\"l%3Boc\",\"properties\":[{\"property_id\":\"title\"}]}" + +formFixture :: L8.ByteString +formFixture = + "{\"type\":\"form\",\"is_form_closed\":false,\"anonymous_submissions\":true,\"submission_permissions\":\"read_and_write\"}" + +dashboardFixture :: L8.ByteString +dashboardFixture = + "{\"type\":\"dashboard\",\"rows\":[{\"id\":\"row-1\",\"widgets\":[\ + \{\"id\":\"w-1\",\"view_id\":\"2b3c4d5e-6f70-4812-9a3b-4c5d6e7f8091\",\"width\":6,\"row_index\":0},\ + \{\"id\":\"w-2\",\"view_id\":\"9a8b7c6d-5e4f-4321-8fed-cba987654321\",\"width\":6,\"row_index\":0}],\"height\":320}]}" + +testMapResponseOnly :: Assertion +testMapResponseOnly = do + config <- decodeOrFail "{\"type\":\"map\",\"map_by\":\"l%3Boc\",\"map_by_property_name\":\"Office\"}" + case config of + MapConfig MapViewConfig {mapByPropertyName} -> mapByPropertyName @?= Just "Office" + other -> assertFailure ("expected a map configuration, got " <> show other) + Aeson.toJSON config @?= jsonValue "{\"type\":\"map\",\"map_by\":\"l%3Boc\"}" + +testResponseOnlyStripped :: Assertion +testResponseOnlyStripped = do + ViewObject {configuration} <- decodeOrFail viewObjectFixture + case configuration of + Just config@(BoardConfig BoardViewConfig {groupBy = StatusGroupBy StatusGroupByConfig {propertyName, groupBy}}) -> do + propertyName @?= Just "Status" + groupBy @?= GroupByStatusGroup + (objectKey "group_by" (Aeson.toJSON config) >>= objectKey "property_name") @?= Nothing + (objectKey "group_by" (Aeson.toJSON config) >>= objectKey "type") @?= Just (Aeson.String "status") + other -> assertFailure ("expected a status-grouped board, got " <> show other) + +testUnknownConfig :: Assertion +testUnknownConfig = do + let raw = "{\"type\":\"kanban_3d\",\"depth\":3}" + config <- decodeOrFail raw + case config of + UnknownViewConfig {} -> pure () + other -> assertFailure ("expected UnknownViewConfig, got " <> show other) + Aeson.toJSON config @?= jsonValue raw + +testUnknownEnum :: Assertion +testUnknownEnum = do + let raw = "{\"type\":\"list\",\"properties\":[{\"property_id\":\"title\",\"date_format\":\"iso_week\"}]}" + config <- decodeOrFail raw + case config of + ListConfig ListViewConfig {properties = Set props} -> + map (\ViewPropertyConfig {dateFormat} -> dateFormat) (Vector.toList props) @?= [Just (UnknownDateFormat "iso_week")] + other -> assertFailure ("expected a list configuration, got " <> show other) + Aeson.toJSON config @?= jsonValue raw + +testFormulaGroupBy :: Assertion +testFormulaGroupBy = do + let raw = + "{\"type\":\"board\",\"group_by\":{\"type\":\"formula\",\"property_id\":\"fx\",\"group_by\":{\"type\":\"number\",\ + \\"sort\":{\"type\":\"descending\"},\"range_start\":0,\"range_end\":100,\"range_size\":10}}}" + config <- decodeOrFail raw + case config of + BoardConfig BoardViewConfig {groupBy = FormulaGroupBy FormulaGroupByConfig {groupBy = FormulaNumberGroup {}}} -> pure () + other -> assertFailure ("expected a formula number group-by, got " <> show other) + Aeson.toJSON config @?= jsonValue raw + +testClearConfigField :: Assertion +testClearConfigField = + objectKey + "configuration" + ( Aeson.toJSON + UpdateView + { name = Nothing, + filter = Unset, + sorts = Unset, + quickFilters = Unset, + configuration = + Just + ( TableConfig + TableViewConfig + { properties = Unset, + groupBy = Clear, + subtasks = Unset, + wrapCells = Nothing, + frozenColumnIndex = Nothing, + showVerticalLines = Nothing + } + ) + } + ) + @?= Just (jsonValue "{\"type\":\"table\",\"group_by\":null}") diff --git a/tasty/WireFormatTests.hs b/tasty/WireFormatTests.hs new file mode 100644 --- /dev/null +++ b/tasty/WireFormatTests.hs @@ -0,0 +1,344 @@ +-- | Wire-format regression tests: JSON fixtures transcribed from the official +-- Notion JS SDK types, and requests captured before they reach the network. +module WireFormatTests (tests) where + +import Control.Exception (Exception, throwIO, try) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Char8 qualified as B8 +import Data.ByteString.Lazy.Char8 qualified as L8 +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Text qualified as Text +import Data.Vector qualified as Vector +import Network.HTTP.Client qualified as HTTP +import Notion.V1 (Methods (..), makeMethods) +import Notion.V1.BlockContent + ( BlockContent (..), + CodeLanguage (..), + MeetingCalendarEvent (..), + MeetingNotesChildren (..), + MeetingNotesStatus (..), + ) +import Notion.V1.Blocks (BlockObject (..)) +import Notion.V1.Common (Color (..), CustomEmojiRef (..), Icon (..), Parent (..), UUID (..)) +import Notion.V1.DataSources qualified as DataSources +import Notion.V1.Databases qualified as Databases +import Notion.V1.Pages (PagePosition (..)) +import Notion.V1.Properties (NumberFormat (..)) +import Notion.V1.PropertyValue (FormulaResult (..), PropertyValue (..), UniqueIdResult (..)) +import Notion.V1.RichText (Annotations (..), MentionContent (..), RichText (..), RichTextContent (..)) +import Notion.V1.Users (BotUser (..), PersonUser (..), UserObject (..), UserOwner (..)) +import Notion.V1.Webhooks (WebhookEvent (..), computeSignature, verifySignature) +import Servant.Client qualified as Client +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "WireFormat" + [ testGroup "Common and rich text" commonTests, + testGroup "Blocks, users and property values" blockUserPropertyTests, + testGroup "Request encoding" requestEncodingTests, + testGroup "Webhooks" webhookTests + ] + +-- | Decode a lazy ByteString literal or fail the test with aeson's message. +decodeOrFail :: (Aeson.FromJSON a) => L8.ByteString -> IO a +decodeOrFail bytes = either (assertFailure . ("decode failed: " <>)) pure (Aeson.eitherDecode bytes) + +-- | A text rich-text item with the given annotation color. +richTextWithColor :: L8.ByteString -> L8.ByteString +richTextWithColor color = + "{\"type\":\"text\",\"text\":{\"content\":\"Hello\",\"link\":null},\"annotations\":{\"bold\":false,\"italic\":false,\"strikethrough\":false,\"underline\":false,\"code\":false,\"color\":\"" + <> color + <> "\"},\"plain_text\":\"Hello\",\"href\":null}" + +------------------------------------------------------------------------------ +-- Common and rich text + +commonTests :: [TestTree] +commonTests = + [ testCase "Color default_background decodes and round-trips" $ do + c <- decodeOrFail "\"default_background\"" + c @?= DefaultBackground + Aeson.encode DefaultBackground @?= "\"default_background\"", + testCase "Color unknown value falls back to UnknownColor" $ do + c <- decodeOrFail "\"ultraviolet_background\"" + c @?= UnknownColor "ultraviolet_background" + Aeson.encode c @?= "\"ultraviolet_background\"", + testCase "RichText with default_background annotation decodes" $ do + rt <- decodeOrFail (richTextWithColor "default_background") :: IO RichText + let RichText {annotations = Annotations {color = c}} = rt + c @?= DefaultBackground, + testCase "Parent agent_id decodes to AgentParent" $ do + p <- decodeOrFail "{\"type\":\"agent_id\",\"agent_id\":\"aaaaaaaa-0000-4000-8000-000000000001\"}" + case p of + AgentParent aid -> aid @?= UUID "aaaaaaaa-0000-4000-8000-000000000001" + other -> assertFailure ("expected AgentParent, got " <> show other), + testCase "Parent unknown type falls back to UnknownParent" $ do + p <- decodeOrFail "{\"type\":\"team_id\",\"team_id\":\"x\"}" + case p of + UnknownParent v -> v @?= Aeson.object ["type" Aeson..= ("team_id" :: String), "team_id" Aeson..= ("x" :: String)] + other -> assertFailure ("expected UnknownParent, got " <> show other), + testCase "Custom emoji icon decodes nested object" $ do + i <- decodeOrFail "{\"type\":\"custom_emoji\",\"custom_emoji\":{\"id\":\"bbbbbbbb-0000-4000-8000-000000000002\",\"name\":\"sakura\",\"url\":\"https://example.com/sakura.png\"}}" + i @?= CustomEmojiIcon (CustomEmojiRef (UUID "bbbbbbbb-0000-4000-8000-000000000002") (Just "sakura") (Just "https://example.com/sakura.png")), + testCase "Custom emoji icon encodes nested object" $ + Aeson.toJSON (CustomEmojiIcon (CustomEmojiRef (UUID "bbbbbbbb-0000-4000-8000-000000000002") Nothing Nothing)) + @?= Aeson.object + [ "type" Aeson..= ("custom_emoji" :: String), + "custom_emoji" Aeson..= Aeson.object ["id" Aeson..= ("bbbbbbbb-0000-4000-8000-000000000002" :: String)] + ], + testCase "Unknown icon type falls back to UnknownIcon" $ do + i <- decodeOrFail "{\"type\":\"sticker\",\"sticker\":{}}" + case i of + UnknownIcon _ -> pure () + other -> assertFailure ("expected UnknownIcon, got " <> show other), + testCase "Unknown mention type falls back to UnknownMention" $ do + let mention = "{\"type\":\"future_mention\",\"future_mention\":{\"href\":\"https://example.com\",\"title\":\"Example\"}}" + fixture = + "{\"type\":\"mention\",\"mention\":" + <> mention + <> ",\"annotations\":{\"bold\":false,\"italic\":false,\"strikethrough\":false,\"underline\":false,\"code\":false,\"color\":\"default\"},\"plain_text\":\"Example\",\"href\":\"https://example.com\"}" + rt <- decodeOrFail fixture :: IO RichText + expected <- decodeOrFail mention :: IO Aeson.Value + case rt of + RichText {content = MentionContentWrapper m@(UnknownMention _)} -> Aeson.toJSON m @?= expected + other -> assertFailure ("expected UnknownMention, got " <> show other), + testCase "Unknown mention decodes directly as MentionContent" $ do + m <- decodeOrFail "{\"type\":\"future_emoji\",\"future_emoji\":{\"id\":\"bbbbbbbb-0000-4000-8000-000000000002\",\"name\":\"sakura\",\"url\":\"https://example.com/sakura.png\"}}" + case m of + UnknownMention _ -> pure () + other -> assertFailure ("expected UnknownMention, got " <> show other) + ] + +------------------------------------------------------------------------------ +-- Blocks, users and property values + +newCodeLanguages :: [CodeLanguage] +newCodeLanguages = + [ Abc, + Agda, + AsciiArt, + Assembly, + Bnf, + Coq, + Dhall, + Ebnf, + Hcl, + Idris, + LlvmIr, + Mathematica, + NotionFormula, + PureScript, + Racket, + Smalltalk, + Solidity, + Toml + ] + +-- | A meeting-notes (or deprecated transcription) block object fixture. +meetingNotesBlockObject :: L8.ByteString -> L8.ByteString +meetingNotesBlockObject blockType = + "{\"object\":\"block\",\"id\":\"dddddddd-0000-4000-8000-000000000004\"," + <> "\"parent\":{\"type\":\"page_id\",\"page_id\":\"eeeeeeee-0000-4000-8000-000000000005\"}," + <> "\"created_time\":\"2026-09-01T10:00:00.000Z\",\"last_edited_time\":\"2026-09-01T11:00:00.000Z\"," + <> "\"created_by\":{\"object\":\"user\",\"id\":\"cccccccc-0000-4000-8000-000000000003\"}," + <> "\"last_edited_by\":{\"object\":\"user\",\"id\":\"cccccccc-0000-4000-8000-000000000003\"}," + <> "\"has_children\":true,\"in_trash\":false,\"archived\":false," + <> "\"type\":\"" + <> blockType + <> "\",\"" + <> blockType + <> "\":{\"title\":[" + <> richTextWithColor "default" + <> "],\"status\":\"notes_ready\"," + <> "\"children\":{\"summary_block_id\":\"11111111-0000-4000-8000-000000000011\"," + <> "\"notes_block_id\":\"22222222-0000-4000-8000-000000000022\"," + <> "\"transcript_block_id\":\"33333333-0000-4000-8000-000000000033\"}," + <> "\"calendar_event\":{\"start_time\":\"2026-09-01T10:00:00.000Z\",\"end_time\":\"2026-09-01T10:30:00.000Z\"," + <> "\"attendees\":[\"cccccccc-0000-4000-8000-000000000003\"]}," + <> "\"recording\":{\"start_time\":\"2026-09-01T10:01:00.000Z\",\"end_time\":\"2026-09-01T10:29:00.000Z\"}}}" + +assertMeetingNotes :: BlockContent -> Assertion +assertMeetingNotes = \case + MeetingNotesBlock {meetingTitle, meetingStatus, calendarEvent, meetingChildren} -> do + fmap (Vector.map (\RichText {plainText} -> plainText)) meetingTitle @?= Just (Vector.singleton "Hello") + meetingStatus @?= Just NotesReady + (meetingChildren >>= \MeetingNotesChildren {summaryBlockId} -> summaryBlockId) + @?= Just (UUID "11111111-0000-4000-8000-000000000011") + (calendarEvent >>= \MeetingCalendarEvent {calendarAttendees} -> calendarAttendees) + @?= Just (Vector.singleton (UUID "cccccccc-0000-4000-8000-000000000003")) + other -> assertFailure ("expected MeetingNotesBlock, got " <> show other) + +blockUserPropertyTests :: [TestTree] +blockUserPropertyTests = + [ testCase "Code block with toml language decodes" $ do + b <- decodeOrFail "{\"type\":\"code\",\"code\":{\"rich_text\":[],\"caption\":[],\"language\":\"toml\"}}" + case b of + CodeBlock {language} -> language @?= Toml + other -> assertFailure ("expected CodeBlock, got " <> show other), + testCase "All 18 new code languages round-trip" $ do + length newCodeLanguages @?= 18 + mapM_ (\l -> Aeson.fromJSON (Aeson.toJSON l) @?= Aeson.Success l) newCodeLanguages, + testCase "Unknown code language falls back to OtherLanguage" $ do + l <- decodeOrFail "\"brainfuck\"" + l @?= OtherLanguage "brainfuck" + Aeson.encode l @?= "\"brainfuck\"", + testCase "Meeting notes block object decodes" $ do + BlockObject {content, type_} <- decodeOrFail (meetingNotesBlockObject "meeting_notes") + type_ @?= "meeting_notes" + assertMeetingNotes content, + testCase "Deprecated transcription block decodes as meeting notes" $ do + BlockObject {content, type_} <- decodeOrFail (meetingNotesBlockObject "transcription") + type_ @?= "transcription" + assertMeetingNotes content, + testCase "Person user without email decodes" $ do + UserObject {person} <- + decodeOrFail "{\"object\":\"user\",\"id\":\"cccccccc-0000-4000-8000-000000000003\",\"name\":\"Tanaka Hanako\",\"avatar_url\":null,\"type\":\"person\",\"person\":{}}" + case person of + Just PersonUser {email} -> email @?= Nothing + Nothing -> assertFailure "expected a person object", + testCase "Bot user owned by a user object decodes" $ do + UserObject {bot} <- + decodeOrFail + "{\"object\":\"user\",\"id\":\"ffffffff-0000-4000-8000-000000000007\",\"name\":\"Sakura Bot\",\"avatar_url\":null,\"type\":\"bot\",\"bot\":{\"owner\":{\"type\":\"user\",\"user\":{\"object\":\"user\",\"id\":\"cccccccc-0000-4000-8000-000000000003\",\"name\":\"Sato Kenji\",\"avatar_url\":null,\"type\":\"person\",\"person\":{\"email\":\"sato.kenji@example.com\"}}},\"workspace_name\":\"Sakura Studio\",\"workspace_id\":\"ws-1\",\"workspace_limits\":{\"max_file_upload_size_in_bytes\":5368709120}}}" + case bot of + Just BotUser {owner = Just UserOwner {type_, user}} -> do + type_ @?= "user" + user @?= UUID "cccccccc-0000-4000-8000-000000000003" + other -> assertFailure ("expected a user-owned bot, got " <> show other), + testCase "Unknown number format falls back to OtherNumberFormat" $ do + f <- decodeOrFail "\"kenyan_shilling\"" + f @?= OtherNumberFormat "kenyan_shilling", + testCase "Unique ID with null number decodes" $ do + v <- decodeOrFail "{\"id\":\"a%3Db\",\"type\":\"unique_id\",\"unique_id\":{\"prefix\":\"TASK\",\"number\":null}}" + case v of + UniqueIdValue _ UniqueIdResult {number, prefix} -> do + number @?= Nothing + prefix @?= Just "TASK" + other -> assertFailure ("expected UniqueIdValue, got " <> show other), + testCase "Formula unsupported result decodes" $ do + v <- decodeOrFail "{\"id\":\"f%3Dx\",\"type\":\"formula\",\"formula\":{\"type\":\"unsupported\",\"unsupported\":{}}}" + case v of + FormulaValue _ FormulaUnsupportedResult -> pure () + other -> assertFailure ("expected an unsupported formula, got " <> show other) + ] + +------------------------------------------------------------------------------ +-- Request encoding + +data RequestCaptured = RequestCaptured deriving stock (Show) + +instance Exception RequestCaptured + +-- | Run a 'Methods' call and capture the HTTP request it builds, aborting +-- before any network I/O happens. +captureRequest :: (Methods -> IO a) -> IO HTTP.Request +captureRequest call = do + ref <- newIORef Nothing + manager <- HTTP.newManager HTTP.defaultManagerSettings + let env0 = Client.mkClientEnv manager (Client.BaseUrl Client.Https "api.notion.com" 443 "/v1") + env = + env0 + { Client.makeClientRequest = \burl req -> do + built <- Client.defaultMakeClientRequest burl req + writeIORef ref (Just built) + throwIO RequestCaptured + } + _ <- try @RequestCaptured (call (makeMethods env "secret_test_token")) + readIORef ref >>= maybe (assertFailure "no request was built") pure + +-- | Assert the captured query request carries filter_properties in the URL only. +assertFilterPropertiesInQuery :: HTTP.Request -> Assertion +assertFilterPropertiesInQuery req = do + assertBool + ("query string: " <> B8.unpack (HTTP.queryString req)) + ("filter_properties=title&filter_properties=Xy12" `B8.isInfixOf` HTTP.queryString req) + assertBool ("path: " <> B8.unpack (HTTP.path req)) ("/query" `B8.isSuffixOf` HTTP.path req) + case HTTP.requestBody req of + HTTP.RequestBodyLBS lbs -> case Aeson.decode lbs of + Just (Aeson.Object o) -> do + KeyMap.lookup "filter_properties" o @?= Nothing + KeyMap.lookup "page_size" o @?= Just (Aeson.Number 5) + _ -> assertFailure ("body is not a JSON object: " <> L8.unpack lbs) + _ -> assertFailure "expected a lazy ByteString request body" + +requestEncodingTests :: [TestTree] +requestEncodingTests = + [ testCase "queryDataSource sends filter_properties as repeated query parameters" $ do + req <- + captureRequest $ \m -> + queryDataSource + m + (UUID "dddddddd-0000-4000-8000-000000000008") + DataSources.QueryDataSource + { filter = Nothing, + sorts = Nothing, + startCursor = Nothing, + pageSize = Just 5, + inTrash = Nothing, + filterProperties = Just ["title", "Xy12"], + resultType = Nothing + } + assertFilterPropertiesInQuery req, + testCase "queryDatabase sends filter_properties as repeated query parameters" $ do + req <- + captureRequest $ \m -> + queryDatabase + m + (UUID "dddddddd-0000-4000-8000-000000000009") + Databases.QueryDatabase + { filter = Nothing, + sorts = Nothing, + startCursor = Nothing, + pageSize = Just 5, + filterProperties = Just ["title", "Xy12"] + } + assertFilterPropertiesInQuery req, + testCase "QueryDataSource JSON omits filter_properties" $ + case Aeson.toJSON + DataSources.QueryDataSource + { filter = Nothing, + sorts = Nothing, + startCursor = Nothing, + pageSize = Nothing, + inTrash = Nothing, + filterProperties = Just ["title"], + resultType = Nothing + } of + Aeson.Object o -> KeyMap.lookup "filter_properties" o @?= Nothing + other -> assertFailure ("expected object, got " <> show other), + testCase "CreatePage position encodes page_start, page_end and after_block" $ do + Aeson.toJSON PageStart @?= Aeson.object ["type" Aeson..= ("page_start" :: String)] + Aeson.toJSON PageEnd @?= Aeson.object ["type" Aeson..= ("page_end" :: String)] + Aeson.toJSON (PageAfterBlock (UUID "b1")) + @?= Aeson.object + [ "type" Aeson..= ("after_block" :: String), + "after_block" Aeson..= Aeson.object ["id" Aeson..= ("b1" :: String)] + ] + ] + +------------------------------------------------------------------------------ +-- Webhooks + +webhookTests :: [TestTree] +webhookTests = + [ testCase "WebhookEvent without accessible_by decodes" $ do + WebhookEvent {accessibleBy} <- + decodeOrFail + "{\"id\":\"ffffffff-0000-4000-8000-000000000006\",\"timestamp\":\"2026-09-01T12:00:00.000Z\",\"workspace_id\":\"ws-1\",\"workspace_name\":\"Sakura Studio\",\"subscription_id\":\"sub-1\",\"integration_id\":\"int-1\",\"type\":\"page.created\",\"authors\":[{\"id\":\"cccccccc-0000-4000-8000-000000000003\",\"type\":\"person\"}],\"attempt_number\":1,\"api_version\":\"2026-03-11\",\"entity\":{\"id\":\"eeeeeeee-0000-4000-8000-000000000005\",\"type\":\"page\"},\"data\":{\"parent\":{\"id\":\"space-1\",\"type\":\"space\"}}}" + assertBool "accessibleBy is empty" (Vector.null accessibleBy), + testCase "verifySignature accepts uppercase hex" $ do + let body = B8.pack "{\"a\":1}" + sig = computeSignature "tok" body + verifySignature "tok" body sig @?= True + verifySignature "tok" body ("sha256=" <> Text.toUpper (Text.drop 7 sig)) @?= True, + testCase "verifySignature rejects malformed signatures" $ do + let body = B8.pack "{\"a\":1}" + sig = computeSignature "tok" body + verifySignature "tok" body (Text.drop 7 sig) @?= False + verifySignature "tok" body "sha256=abc" @?= False + verifySignature "tok" body ("sha256=" <> Text.replicate 64 "z") @?= False + ]