firebase-hs 0.2.0.0 → 0.3.0.0

raw patch · 13 files changed

+2214/−1457 lines, 13 filesdep −mtldep −stmdep ~aesondep ~basedep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies removed: mtl, stm

Dependency ranges changed: aeson, base, containers, crypton, http-client, http-client-tls, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +117/−1
• README.md +62/−222
• firebase-hs.cabal +44/−34
• src/Firebase/Auth.hs +222/−102
• src/Firebase/Auth/Internal.hs +88/−0
• src/Firebase/Auth/Types.hs +78/−26
• src/Firebase/Auth/WAI.hs +48/−57
• src/Firebase/Firestore.hs +224/−190
• src/Firebase/Firestore/Internal.hs +317/−84
• src/Firebase/Firestore/Query.hs +28/−13
• src/Firebase/Firestore/Types.hs +143/−17
• src/Firebase/Servant.hs +28/−50
• test/Main.hs +815/−661

@@ -1,10 +1,126 @@ # Changelog +## 0.3.0.0++### Fixed+- Percent-encode every caller-supplied URL component. Project IDs, collection+  paths, document IDs, and `updateMask` field paths were interpolated raw, so+  a value containing `?`, `#`, `%`, `&`, a space, or any non-ASCII character+  produced a malformed request or injected query parameters. Subcollection+  `/` separators are preserved; the segments between them are encoded.+- `FirestoreValue` covers every type Firestore stores. `bytesValue`,+  `referenceValue`, and `geoPointValue` had no representation, so a document+  containing any of them failed to decode outright and `getDocument` returned+  `InvalidResponse` for data Firestore considers perfectly valid.+- Non-finite doubles travel in proto3 JSON's string spellings. `DoubleValue`+  holding NaN or an infinity previously encoded as `null` or `"+inf"`, which+  Firestore rejects, and a stored `"NaN"`, `"Infinity"`, or `"-Infinity"`+  failed to decode, making any document that held one unreadable.+- `runQuery` posts to the queried collection's parent resource, so a+  subcollection path (`users/abc/posts`) now queries that subcollection.+  The full path used to be sent as the `from` collection ID, which+  Firestore rejects; only top-level collections were queryable.+- A query result whose document fails to decode is reported as+  `InvalidResponse` instead of being silently dropped, which misreported+  what the query matched.+- `integerValue` strings outside the `Int64` range are rejected. The digits+  were read straight into `Int64`, so an out-of-range value silently+  wrapped instead of failing.+- `{"doubleValue": null}` is rejected. The null previously fell through to+  aeson's `Double` parser, which reads JSON null as NaN.+- A cache refresh no longer overwrites a newer key set installed by a+  concurrent verification.+- `runQuery` and `runQueryInTransaction` classify their error responses.+  Firestore's streaming endpoints frame an error as a single-element JSON+  array, which the parser did not read, so a query that failed with an+  error response surfaced as `NetworkError "HTTP <status>"` instead of+  `DocumentNotFound`, `PermissionDenied`, `TransactionAborted`, or a+  specific API error.+- A query stream that fails after emitting some results reports the error+  instead of returning the partial page as a success. The trailing error+  entry was dropped, so a truncated result set looked complete.+- `TimestampValue` encodes at most nanosecond precision. A `UTCTime`+  carrying sub-nanosecond digits formatted to more than the nine fractional+  digits Firestore accepts, which it rejects on write.++### Breaking Changes+- Firestore operations take a single `Firestore` handle in place of the+  `Manager -> AccessToken -> ProjectId` prefix every one of them repeated.+  Build it with `newFirestore`, and refresh an expiring token with+  `withToken` rather than rebuilding the connection pool.+- `FirebaseUser` gained fields, so positional construction no longer+  compiles. Pattern matches on `fuUid`, `fuEmail`, and `fuName` are+  unaffected.+- `commitTransaction` and the `runTransaction` callback take the new opaque+  `Write` type in place of raw `Aeson.Value`, with `mkUpdateWrite` and+  `mkDeleteWrite` constructing it. Hand-assembled write JSON no longer+  typechecks.+- `Firebase.Firestore.Internal.queryUrl` is replaced by `runQueryUrl`, which+  takes the queried collection so it can address the parent resource.+- `KeyCache` is now backed by `IORef` rather than `TVar`, and `Firebase.Auth`+  re-exports it as an abstract type. Construct it with `newKeyCache` or+  `newTlsKeyCache`.+- Dropped the `stm` dependency: the cache is a single reference with no+  composed transactions, which `atomicModifyIORef'` covers.+- Dropped the `mtl` dependency from the `servant` flag. `Firebase.Servant`+  now builds its 401 on the `Handler` newtype and `transformers`, which does+  not depend on which `MonadError` re-export a given servant version ships.+- `Firebase.Servant` no longer exports `extractBearerToken` or+  `authErrorToBody`. Both were duplicates of the `Firebase.Auth.WAI`+  versions; use `Firebase.Auth.Internal.bearerToken` and+  `Firebase.Auth.authErrorMessage`.+- A response body that is JSON but not shaped like a Firestore error now+  reports `NetworkError "HTTP <status>"` instead of+  `FirestoreApiError status "" "unknown error"`.++### Added+- `getDocumentInTransaction` and `runQueryInTransaction` read inside a+  transaction. The reads see the transaction's snapshot and Firestore+  verifies at commit that nothing they read has changed, which is what makes+  `runTransaction` a transaction rather than an atomic batch write; reads+  without the transaction ID never did either.+- Token claims are no longer discarded. `FirebaseUser` now carries+  `fuEmailVerified`, `fuPicture`, `fuAuthTime`, `fuSignInProvider`, and+  `fuCustomClaims`, with `hasClaim` and `lookupClaim` to read them. Custom+  claims are how Firebase expresses roles, so without them a verified token+  could establish identity but not authorize anything.+- 401 responses from the WAI middleware and the Servant handler carry the+  `WWW-Authenticate: Bearer` challenge RFC 6750 requires.+- `listDocuments` lists a collection. `collectionUrl` had described itself as+  "used for listing" since the first release with nothing to use it.+- `BytesValue`, `ReferenceValue`, `GeoPointValue`, and the `GeoPoint` type.+- `mkUpdateWrite` and `mkDeleteWrite` build the writes `commitTransaction`+  and `runTransaction` expect. `mkUpdateWrite` was referenced by the README+  and Haddock but never existed, leaving no supported way to construct a+  write.+- `Firebase.Auth.Internal`: base64url padding and bearer-token extraction,+  shared by the verifier and both web integrations.+- `authErrorMessage` renders an `AuthError` as a client-safe body.+- `documentResourceName`, the percent-encoding helpers,+  `splitCollectionPath`, `documentInTransactionUrl`, and the pure response+  decoders (`decodeBody`, `decodeDocumentList`, `decodeQueryResults`,+  `decodeTransactionId`) are exported from `Firebase.Firestore.Internal`.++### Changed+- Bearer scheme names are matched case-insensitively, as RFC 7235 requires.+- Network calls catch only `HttpException`. Anything else, asynchronous+  cancellation in particular, propagates instead of surfacing as a+  `KeyFetchError` or `NetworkError` result.+- Widened bounds: `http-client-tls < 0.5` (resolves the Stackage report in+  issue #1), `containers < 0.9`, `aeson < 2.4`, `time < 1.17`,+  `crypton < 2`. Lowered `base` to `>= 4.18`, admitting GHC 9.6.+- `http-client >= 0.7.13`, the first release whose `Show Request` redacts+  the `Authorization` header. An `HttpException` rendered into+  `NetworkError` text therefore never carries the access token.+- CI builds the `wai` and `servant` modules, which no job previously+  compiled, and adds a GHC compatibility matrix, an sdist build, and an+  ASCII-only source check.+ ## 0.2.0.0  ### Breaking Changes - Replaced `jose` JWT backend with direct `crypton` RS256 verification-- Dropped `jose`, `lens`, `memory` dependencies — significantly lighter dependency tree+- Dropped `jose`, `lens`, `memory` dependencies for a significantly lighter dependency tree - `JWKSet` (from jose) replaced with internal `JwkSet`/`JwkKey` types in `Firebase.Auth.Types` - License changed from MIT to BSD-3-Clause 

@@ -1,40 +1,36 @@-<div align="center">-<h1>firebase-hs</h1>-<p><strong>Firebase for Haskell</strong></p>-<p>Auth verification, Firestore CRUD, structured queries, atomic transactions, and a Servant auth combinator.</p>-<p><a href="#quick-start">Quick Start</a> · <a href="#firestore">Firestore</a> · <a href="#servant">Servant</a> · <a href="#api-reference">API Reference</a></p>-<p>+# firebase-hs  [![CI](https://github.com/Gondola-Bros-Entertainment/firebase-hs/actions/workflows/ci.yml/badge.svg)](https://github.com/Gondola-Bros-Entertainment/firebase-hs/actions/workflows/ci.yml) [![Hackage](https://img.shields.io/hackage/v/firebase-hs.svg)](https://hackage.haskell.org/package/firebase-hs)-![Haskell](https://img.shields.io/badge/haskell-GHC%209.8-purple)-![License](https://img.shields.io/badge/license-BSD--3--Clause-blue)--</p>-</div>-------## What is firebase-hs?--A pure Haskell library for Firebase services:+[![License](https://img.shields.io/badge/license-BSD--3--Clause-blue)](LICENSE) -- **Auth** — JWT verification against Google's public JWKs using crypton for RS256, with automatic key caching-- **Firestore** — CRUD operations, structured queries, and atomic transactions via the REST API-- **Servant** — One-liner auth combinator for Servant servers (optional flag)+Firebase for Haskell: ----+- **Auth**: Firebase ID token (JWT) verification against Google's public+  keys, with RS256 via crypton and automatic key caching+- **Firestore**: CRUD, structured queries, and atomic transactions over the+  REST API+- **WAI / Servant**: auth middleware and an auth combinator, each behind an+  optional cabal flag -## Quick Start+Full API documentation lives on+[Hackage](https://hackage.haskell.org/package/firebase-hs). -Add to your `.cabal` file:+## Install  ```cabal build-depends: firebase-hs ``` -### Verify a Token+The web integrations are off by default; enable the ones you use: +```bash+cabal build -f wai      # Firebase.Auth.WAI+cabal build -f servant  # Firebase.Servant+```++## Auth+ ```haskell import Firebase.Auth @@ -48,144 +44,71 @@     Right user -> putStrLn ("UID: " ++ show (fuUid user)) ``` ------## Auth+Build one `KeyCache` at startup and share it across threads; keys refresh+automatically per Google's `Cache-Control` header. -### Verification Rules+A token is accepted only if every one of these holds:  | Check | Rule | |-------|------|-| **Algorithm** | RS256 only |-| **Signature** | Must match a Google public key |-| **Issuer** | `https://securetoken.google.com/<projectId>` |-| **Audience** | Must equal your Firebase project ID |-| **Expiry** | `exp` must be in the future (within clock skew) |-| **Issued at** | `iat` must be in the past (within clock skew) |-| **Subject** | `sub` must be non-empty (becomes the Firebase UID) |--### Key Caching--Keys are fetched lazily on first verification, cached per Google's `Cache-Control: max-age`, and refreshed automatically. Thread-safe via STM.+| Algorithm | RS256 only |+| Signature | Must match a Google public key |+| Issuer | `https://securetoken.google.com/<projectId>` |+| Audience | Must equal your Firebase project ID |+| Expiry / issued-at | `exp` in the future, `iat` in the past, within clock skew |+| Subject | `sub` non-empty (becomes the Firebase UID) | -### Error Handling+Roles live in custom claims, set by the Admin SDK's `setCustomUserClaims`:  ```haskell-case result of-  Left (KeyFetchError msg) -> logError "Network issue" msg-  Left InvalidSignature    -> respond 401 "Invalid token"-  Left TokenExpired        -> respond 401 "Token expired"-  Left (InvalidClaims msg) -> respond 401 ("Bad claims: " <> msg)-  Left (MalformedToken _)  -> respond 400 "Malformed token"-  Right user               -> handleAuthenticated user+if hasClaim "admin" user then handleAdmin user else refuse ``` ----- ## Firestore -### CRUD Operations- ```haskell+import qualified Data.Map.Strict as Map import Firebase.Firestore  main :: IO () main = do-  mgr <- newTlsManager-  let pid = ProjectId "my-project"-      tok = AccessToken "ya29..."--  -- Create-  let fields = Map.fromList [("name", StringValue "Alice"), ("age", IntegerValue 30)]-  _ <- createDocument mgr tok pid (CollectionPath "users") (DocumentId "alice") fields+  fs <- newFirestore (ProjectId "my-project") (AccessToken "ya29...") -  -- Read   let path = DocumentPath (CollectionPath "users") (DocumentId "alice")-  doc <- getDocument mgr tok pid path--  -- Update specific fields-  let updates = Map.fromList [("age", IntegerValue 31)]-  _ <- updateDocument mgr tok pid path ["age"] updates--  -- Delete-  _ <- deleteDocument mgr tok pid path-  pure ()+  _ <- createDocument fs (CollectionPath "users") (DocumentId "alice")+         (Map.fromList [("name", StringValue "Alice"), ("age", IntegerValue 30)])+  _ <- updateDocument fs path ["age"] (Map.fromList [("age", IntegerValue 31)])+  doc <- getDocument fs path+  print doc ``` -### Structured Queries+Build one `Firestore` handle and share it; it holds a pooled connection+manager. Access tokens expire, so swap in a fresh one with `withToken`+rather than rebuilding the handle. -Build queries with a pure DSL and `(&)` composition:+Queries compose with `(&)`; subcollections are addressed by path:  ```haskell import Data.Function ((&)) -let q = query (CollectionPath "users")-      & where_ (fieldFilter "age" OpGreaterThan (IntegerValue 18))-      & orderBy "age" Ascending-      & limit 10--result <- runQuery mgr tok pid q-```--Composite filters for complex conditions:--```haskell-let q = query (CollectionPath "users")-      & where_ (compositeAnd-          [ fieldFilter "age" OpGreaterThan (IntegerValue 18)-          , fieldFilter "active" OpEqual (BoolValue True)-          ])-```--### Atomic Transactions--Read-then-write operations that succeed or fail atomically:--```haskell-result <- runTransaction mgr tok pid ReadWrite $ \txnId -> runExceptT $ do-  -- Reads within the transaction see a consistent snapshot-  d <- ExceptT $ getDocument mgr tok pid userPath-  let newBalance = computeNewBalance (docFields d)-  pure [mkUpdateWrite userPath newBalance]-```--Retry aborted transactions:--```haskell--- First attempt-result <- beginTransaction mgr tok pid ReadWrite-case result of-  Left (TransactionAborted _) ->-    -- Retry with the failed transaction ID for priority-    beginTransaction mgr tok pid (RetryWith txnId)+result <- runQuery fs $+  query (CollectionPath "users")+    & where_ (fieldFilter "age" OpGreaterThan (IntegerValue 18))+    & orderBy "age" Ascending+    & limit 10 ``` -### Firestore Value Types--Values mirror Firestore's tagged wire format:+Transactions read with the transaction ID and return the writes to commit.+On any failure the transaction is rolled back, and losing a contention race+surfaces as `TransactionAborted`:  ```haskell-data FirestoreValue-  = NullValue | BoolValue !Bool | IntegerValue !Int64-  | DoubleValue !Double | StringValue !Text | TimestampValue !UTCTime-  | ArrayValue ![FirestoreValue] | MapValue !(Map Text FirestoreValue)-```--Note: integers are encoded as JSON strings (`{"integerValue":"42"}`), not numbers. The JSON instances handle this transparently.-------## WAI Middleware--Protect any WAI-based server (Warp, Scotty, Yesod, Spock) with Firebase auth. Enable with the `wai` cabal flag:--```bash-cabal build -f wai+result <- runTransaction fs ReadWrite $ \txnId -> runExceptT $ do+  doc <- ExceptT (getDocumentInTransaction fs txnId path)+  pure [mkUpdateWrite (fsProject fs) path (applyDebit 100 (docFields doc))] ``` -### Simple Gate--Reject unauthenticated requests before they reach your app:+## WAI  ```haskell import Firebase.Auth (newTlsKeyCache, defaultFirebaseConfig)@@ -196,35 +119,14 @@ main = do   cache <- newTlsKeyCache   let cfg = defaultFirebaseConfig "my-project-id"-  run 3000 $ requireAuth cache cfg myApp-```--### With User Propagation--Store the authenticated user in the WAI vault for downstream handlers:--```haskell-import Firebase.Auth.WAI (firebaseAuth, lookupFirebaseUser)--main = run 3000 $ firebaseAuth cache cfg myApp--myHandler req respond = case lookupFirebaseUser req of-  Just user -> respond (ok200 ("Hello, " <> fuUid user))-  Nothing   -> respond (err500 "unreachable")+  run 3000 (requireAuth cache cfg myApp) ``` ----+`firebaseAuth` additionally stores the verified `FirebaseUser` in the+request vault for `lookupFirebaseUser` to read downstream.  ## Servant -Enable with the `servant` cabal flag:--```bash-cabal build -f servant-```--One-liner auth for any Servant server:- ```haskell import Firebase.Auth (newTlsKeyCache, defaultFirebaseConfig) import Firebase.Servant (firebaseAuthHandler)@@ -238,74 +140,12 @@   runSettings defaultSettings (serveWithContext api ctx server) ``` -The handler extracts the Bearer token, verifies it against Google's keys, and injects a `FirebaseUser` into your endpoint — or returns 401 with a descriptive error.-------## API Reference--### Auth--```haskell-verifyIdToken       :: Manager -> FirebaseConfig -> ByteString -> IO (Either AuthError FirebaseUser)-newKeyCache         :: Manager -> IO KeyCache-newTlsKeyCache      :: IO KeyCache-verifyIdTokenCached :: KeyCache -> FirebaseConfig -> ByteString -> IO (Either AuthError FirebaseUser)-parseCacheMaxAge    :: ResponseHeaders -> Maybe Int-```--### Firestore--```haskell-getDocument    :: Manager -> AccessToken -> ProjectId -> DocumentPath -> IO (Either FirestoreError Document)-createDocument :: Manager -> AccessToken -> ProjectId -> CollectionPath -> DocumentId -> Map Text FirestoreValue -> IO (Either FirestoreError Document)-updateDocument :: Manager -> AccessToken -> ProjectId -> DocumentPath -> [Text] -> Map Text FirestoreValue -> IO (Either FirestoreError Document)-deleteDocument :: Manager -> AccessToken -> ProjectId -> DocumentPath -> IO (Either FirestoreError ())-runQuery       :: Manager -> AccessToken -> ProjectId -> StructuredQuery -> IO (Either FirestoreError [Document])-```--### Transactions--```haskell-beginTransaction    :: Manager -> AccessToken -> ProjectId -> TransactionMode -> IO (Either FirestoreError TransactionId)-commitTransaction   :: Manager -> AccessToken -> ProjectId -> TransactionId -> [Value] -> IO (Either FirestoreError ())-rollbackTransaction :: Manager -> AccessToken -> ProjectId -> TransactionId -> IO (Either FirestoreError ())-runTransaction      :: Manager -> AccessToken -> ProjectId -> TransactionMode -> (TransactionId -> IO (Either FirestoreError [Value])) -> IO (Either FirestoreError ())-```--### WAI Middleware--```haskell-requireAuth        :: KeyCache -> FirebaseConfig -> Middleware-firebaseAuth       :: KeyCache -> FirebaseConfig -> Middleware-lookupFirebaseUser :: Request -> Maybe FirebaseUser-```--### Servant--```haskell-firebaseAuthHandler :: KeyCache -> FirebaseConfig -> AuthHandler Request FirebaseUser-extractBearerToken  :: Request -> Maybe ByteString-authErrorToBody     :: AuthError -> LBS.ByteString-```--Full Haddock documentation is available on [Hackage](https://hackage.haskell.org/package/firebase-hs).-------## Build & Test+## Build and Test  ```bash-cabal build                              # Build library-cabal test                               # Run all tests (46 pure tests)-cabal build --ghc-options="-Werror"      # Warnings as errors-cabal build -f wai                       # Build with WAI middleware-cabal build -f servant                   # Build with Servant combinator-cabal haddock                            # Generate docs+cabal build all -f wai -f servant --enable-tests --ghc-options="-Werror"+cabal test ``` ------<p align="center">-  <sub>BSD-3-Clause License · <a href="https://github.com/Gondola-Bros-Entertainment">Gondola Bros Entertainment</a></sub>-</p>+BSD-3-Clause. Maintained by+[Gondola Bros Entertainment](https://github.com/Gondola-Bros-Entertainment).

@@ -1,16 +1,17 @@ cabal-version:      3.0 name:               firebase-hs-version:            0.2.0.0+version:            0.3.0.0 synopsis:           Firebase Auth, Firestore, and Servant integration for Haskell description:   Firebase Authentication (JWT verification), Firestore REST API client   (CRUD, queries, transactions), and optional WAI middleware and Servant   auth combinator. Verify ID tokens against Google's public keys, read and   write Firestore documents, and protect any Haskell web server with Firebase-  auth — all from pure, composable Haskell.+  auth, all from pure, composable Haskell.  license:            BSD-3-Clause license-file:       LICENSE+copyright:          2026 Gondola Bros Entertainment author:             Devon Tomlin maintainer:         devon.tomlin@novavero.ai homepage:           https://github.com/Gondola-Bros-Entertainment/firebase-hs@@ -18,7 +19,7 @@ category:           Web, Authentication, Database stability:          experimental build-type:         Simple-tested-with:        GHC == 9.8.4+tested-with:        GHC ==9.6.* || ==9.8.* || ==9.10.* || ==9.12.* extra-doc-files:     CHANGELOG.md     README.md@@ -33,9 +34,27 @@   default:     False   manual:      True +common warnings+  ghc-options:+    -Wall+    -Wcompat+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wredundant-constraints++common extensions+  default-language: Haskell2010+  default-extensions:+    LambdaCase+    OverloadedStrings+    StrictData+    TupleSections+ library+  import:           warnings, extensions   exposed-modules:     Firebase.Auth+    Firebase.Auth.Internal     Firebase.Auth.Types     Firebase.Firestore     Firebase.Firestore.Internal@@ -43,19 +62,18 @@     Firebase.Firestore.Types    build-depends:-      base              >= 4.19 && < 5-    , aeson             >= 2.0  && < 2.3-    , base64-bytestring >= 1.2  && < 1.3-    , bytestring        >= 0.11 && < 0.13-    , containers        >= 0.6  && < 0.8-    , crypton           >= 0.31 && < 1.2-    , http-client       >= 0.7  && < 0.8-    , http-client-tls   >= 0.3  && < 0.4-    , http-types        >= 0.12 && < 0.13-    , stm               >= 2.5  && < 2.7-    , text              >= 1.2  && < 2.2-    , time              >= 1.12 && < 1.15-    , transformers      >= 0.5  && < 0.7+      base              >= 4.18   && < 5+    , aeson             >= 2.0    && < 2.4+    , base64-bytestring >= 1.2    && < 1.3+    , bytestring        >= 0.11   && < 0.13+    , containers        >= 0.6    && < 0.9+    , crypton           >= 0.31   && < 2+    , http-client       >= 0.7.13 && < 0.8+    , http-client-tls   >= 0.3    && < 0.5+    , http-types        >= 0.12   && < 0.13+    , text              >= 1.2    && < 2.2+    , time              >= 1.12   && < 1.17+    , transformers      >= 0.5    && < 0.7    if flag(wai)     exposed-modules: Firebase.Auth.WAI@@ -66,34 +84,26 @@   if flag(servant)     exposed-modules: Firebase.Servant     build-depends:-        mtl              >= 2.2 && < 2.4-      , servant-server   >= 0.19 && < 0.21+        servant-server   >= 0.19 && < 0.21       , wai              >= 3.2 && < 3.3    hs-source-dirs:   src-  default-language:  Haskell2010-  ghc-options:-    -Wall-    -Wcompat-    -Wincomplete-record-updates-    -Wincomplete-uni-patterns  test-suite firebase-hs-test+  import:           warnings, extensions   type:             exitcode-stdio-1.0   main-is:          Main.hs   hs-source-dirs:   test   build-depends:-      base             >= 4.19 && < 5-    , aeson            >= 2.0  && < 2.3-    , bytestring       >= 0.11 && < 0.13-    , containers       >= 0.6  && < 0.8+      base             >= 4.18   && < 5+    , aeson            >= 2.0    && < 2.4+    , bytestring       >= 0.11   && < 0.13+    , containers       >= 0.6    && < 0.9     , firebase-hs-    , http-client      >= 0.7  && < 0.8-    , http-types       >= 0.12 && < 0.13-    , text             >= 1.2  && < 2.2-    , time             >= 1.12 && < 1.15-  default-language:  Haskell2010-  ghc-options:       -Wall -Wcompat+    , http-client      >= 0.7.13 && < 0.8+    , http-types       >= 0.12   && < 0.13+    , text             >= 1.2    && < 2.2+    , time             >= 1.12   && < 1.17  source-repository head   type:     git

@@ -1,11 +1,6 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StrictData #-}- -- | -- Module      : Firebase.Auth -- Description : Firebase ID token verification--- License     : BSD-3-Clause -- -- Verify Firebase Authentication ID tokens (JWTs) against Google's -- public keys using crypton for RS256 signature verification.@@ -27,36 +22,59 @@     verifyIdToken,      -- * Cached verification+    KeyCache,     newKeyCache,     newTlsKeyCache,     verifyIdTokenCached, +    -- * Configuration+    FirebaseConfig (..),+    defaultFirebaseConfig,++    -- * Authenticated user+    FirebaseUser (..),+    lookupClaim,+    hasClaim,++    -- * Errors+    AuthError (..),+    authErrorMessage,+     -- * Utilities     parseCacheMaxAge,--    -- * Re-exports-    module Firebase.Auth.Types,   ) where -import Control.Concurrent.STM (atomically, newTVarIO, readTVarIO, writeTVar)-import Control.Exception (SomeException, evaluate, try)+import Control.Exception (try)+import Control.Monad (guard) import Crypto.Hash.Algorithms (SHA256 (..)) import Crypto.PubKey.RSA.PKCS15 (verify) import Crypto.PubKey.RSA.Types (PublicKey)-import Data.Aeson (FromJSON (..), (.:), (.:?))+import Data.Aeson (FromJSON (..), (.!=), (.:), (.:?)) import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Aeson.Types as Aeson+import Data.Bifunctor (first) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as LBS+import Data.IORef (atomicModifyIORef', newIORef, readIORef)+import Data.List (find)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Data.Time (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Firebase.Auth.Internal (padBase64Url) import Firebase.Auth.Types import Network.HTTP.Client-  ( Manager,+  ( HttpException,+    Manager,     Response,     httpLbs,     parseRequest,@@ -87,8 +105,13 @@     jpAud :: !(Maybe Text),     jpExp :: !(Maybe Integer),     jpIat :: !(Maybe Integer),+    jpAuthTime :: !(Maybe Integer),     jpEmail :: !(Maybe Text),-    jpName :: !(Maybe Text)+    jpEmailVerified :: !Bool,+    jpName :: !(Maybe Text),+    jpPicture :: !(Maybe Text),+    jpSignInProvider :: !(Maybe Text),+    jpCustomClaims :: !(Map Text Aeson.Value)   }  instance FromJSON JwtPayload where@@ -99,9 +122,67 @@       <*> o .:? "aud"       <*> o .:? "exp"       <*> o .:? "iat"+      <*> o .:? "auth_time"       <*> o .:? "email"+      <*> o .:? "email_verified" .!= False       <*> o .:? "name"+      <*> o .:? "picture"+      <*> parseSignInProvider o+      <*> pure (customClaims o) +-- | Read @firebase.sign_in_provider@ out of the nested Firebase claim.+parseSignInProvider :: Aeson.Object -> Aeson.Parser (Maybe Text)+parseSignInProvider o =+  o .:? "firebase"+    >>= maybe (pure Nothing) (Aeson.withObject "firebase" (.:? "sign_in_provider"))++-- | Claim names Firebase reserves, which @setCustomUserClaims@ may not set.+--+-- Everything outside this set is a custom claim and is surfaced as one.+reservedClaims :: Set Text+reservedClaims =+  Set.fromList+    [ "acr",+      "amr",+      "at_hash",+      "aud",+      "auth_time",+      "azp",+      "c_hash",+      "cnf",+      "exp",+      "email",+      "email_verified",+      "firebase",+      "iat",+      "iss",+      "jti",+      "name",+      "nbf",+      "nonce",+      "phone_number",+      "picture",+      "sub",+      "user_id"+    ]++-- | Every claim outside 'reservedClaims'.+customClaims :: Aeson.Object -> Map Text Aeson.Value+customClaims payload =+  Map.fromList+    [ (name, value)+    | (key, value) <- KM.toList payload,+      let name = Key.toText key,+      not (Set.member name reservedClaims)+    ]++-- | The three dot-separated parts of a compact JWT, still base64url-encoded.+data JwtParts = JwtParts+  { jwtHeaderPart :: !BS.ByteString,+    jwtPayloadPart :: !BS.ByteString,+    jwtSignaturePart :: !BS.ByteString+  }+ -- --------------------------------------------------------------------------- -- Constants -- ---------------------------------------------------------------------------@@ -110,6 +191,7 @@ googleJwkUrl =   "https://www.googleapis.com/service_accounts/v1/jwk/securetoken@system.gserviceaccount.com" +-- | Cache lifetime assumed when Google's response carries no @max-age@. defaultCacheDurationSeconds :: NominalDiffTime defaultCacheDurationSeconds = 3600 @@ -119,6 +201,14 @@ expectedAlgorithm :: Text expectedAlgorithm = "RS256" +-- | The @Cache-Control@ directive carrying a response's lifetime in seconds.+maxAgeDirective :: BS.ByteString+maxAgeDirective = "max-age="++-- | The separator between the three parts of a compact JWT.+jwtPartSeparator :: Char+jwtPartSeparator = '.'+ -- --------------------------------------------------------------------------- -- One-shot verification -- ---------------------------------------------------------------------------@@ -133,20 +223,21 @@   BS.ByteString ->   IO (Either AuthError FirebaseUser) verifyIdToken mgr config token = do-  keysResult <- fetchGoogleKeys mgr-  case keysResult of-    Left err -> pure (Left err)-    Right (jwks, _expiry) -> verifyWithKeys jwks config token+  fetched <- fetchGoogleKeys mgr+  either (pure . Left) (verifyWithKeys config token . fst) fetched  -- --------------------------------------------------------------------------- -- Cached verification -- ---------------------------------------------------------------------------  -- | Create a key cache backed by the given HTTP manager.+--+-- The cache starts empty and expired, so the first verification fetches+-- Google's keys. newKeyCache :: Manager -> IO KeyCache newKeyCache mgr = do   epoch <- getCurrentTime-  ref <- newTVarIO (JwkSet [], epoch)+  ref <- newIORef (JwkSet [], epoch)   pure KeyCache {kcKeysRef = ref, kcManager = mgr}  -- | Create a key cache with a fresh TLS-enabled HTTP manager.@@ -163,112 +254,136 @@   BS.ByteString ->   IO (Either AuthError FirebaseUser) verifyIdTokenCached cache config token = do+  keys <- currentKeys cache+  either (pure . Left) (verifyWithKeys config token) keys++-- | The cached key set, refetching first if it has expired.+currentKeys :: KeyCache -> IO (Either AuthError JwkSet)+currentKeys cache = do   now <- getCurrentTime-  (jwks, expiry) <- readTVarIO (kcKeysRef cache)-  keysResult <--    if now >= expiry-      then do-        result <- fetchGoogleKeys (kcManager cache)-        case result of-          Left err -> pure (Left err)-          Right (newKeys, newExpiry) -> do-            atomically $ writeTVar (kcKeysRef cache) (newKeys, newExpiry)-            pure (Right newKeys)-      else pure (Right jwks)-  case keysResult of-    Left err -> pure (Left err)-    Right keys -> verifyWithKeys keys config token+  (keys, expiry) <- readIORef (kcKeysRef cache)+  if now < expiry+    then pure (Right keys)+    else refreshKeys cache +-- | Fetch a fresh key set and install it in the cache.+refreshKeys :: KeyCache -> IO (Either AuthError JwkSet)+refreshKeys cache = do+  fetched <- fetchGoogleKeys (kcManager cache)+  traverse install fetched+  where+    install entry = do+      atomicModifyIORef' (kcKeysRef cache) (\cached -> (laterExpiring cached entry, ()))+      pure (fst entry)++-- | Of two cache entries, the one that stays valid longer.+--+-- Concurrent verifications can each refresh on expiry; keeping the later+-- expiry stops a slow response from displacing a newer key set.+laterExpiring :: (JwkSet, UTCTime) -> (JwkSet, UTCTime) -> (JwkSet, UTCTime)+laterExpiring cached fetched+  | snd fetched > snd cached = fetched+  | otherwise = cached+ -- --------------------------------------------------------------------------- -- Key fetching -- --------------------------------------------------------------------------- +-- | Fetch Google's current public keys.+--+-- Only 'HttpException' becomes a 'KeyFetchError': anything else+-- (asynchronous cancellation, for instance) is not a fetch result and+-- propagates. fetchGoogleKeys :: Manager -> IO (Either AuthError (JwkSet, UTCTime)) fetchGoogleKeys mgr = do   req <- parseRequest googleJwkUrl-  respResult <- try (httpLbs req mgr) :: IO (Either SomeException (Response LBS.ByteString))-  case respResult of+  fetched <- try (httpLbs req mgr) :: IO (Either HttpException (Response LBS.ByteString))+  case fetched of     Left err -> pure (Left (KeyFetchError (T.pack (show err))))     Right resp -> do       now <- getCurrentTime-      let body = responseBody resp-          maxAge = parseCacheMaxAge (responseHeaders resp)-          duration = maybe defaultCacheDurationSeconds fromIntegral maxAge-          expiry = addUTCTime duration now-      case Aeson.eitherDecode body of-        Left err -> pure (Left (KeyFetchError (T.pack err)))-        Right jwks -> do-          !_ <- evaluate jwks-          pure (Right (jwks, expiry))+      pure (fmap (,cacheExpiry now resp) (decodeKeys (responseBody resp))) +-- | When a key response stops being usable, per its @Cache-Control@ header.+cacheExpiry :: UTCTime -> Response LBS.ByteString -> UTCTime+cacheExpiry now resp = addUTCTime duration now+  where+    duration =+      maybe defaultCacheDurationSeconds fromIntegral $+        parseCacheMaxAge (responseHeaders resp)++decodeKeys :: LBS.ByteString -> Either AuthError JwkSet+decodeKeys = first (KeyFetchError . T.pack) . Aeson.eitherDecode+ -- | Parse the @max-age@ directive from a @Cache-Control@ response header. --+-- Yields 'Nothing' when the directive is absent, unparseable, or+-- non-positive, leaving the caller to apply its own default.+-- -- >>> parseCacheMaxAge [("cache-control", "public, max-age=19845, must-revalidate")] -- Just 19845 parseCacheMaxAge :: ResponseHeaders -> Maybe Int parseCacheMaxAge headers = do-  cc <- lookup hCacheControl headers-  let (_before, rest) = BS.breakSubstring "max-age=" cc-  if BS.null rest-    then Nothing-    else do-      let numPart = BS.drop maxAgePrefixLen rest-      case BS8.readInt numPart of-        Just (n, _) | n > 0 -> Just n-        _ -> Nothing-  where-    maxAgePrefixLen :: Int-    maxAgePrefixLen = 8+  cacheControl <- lookup hCacheControl headers+  let (_before, fromDirective) = BS.breakSubstring maxAgeDirective cacheControl+  (seconds, _rest) <- BS8.readInt (BS.drop (BS.length maxAgeDirective) fromDirective)+  seconds <$ guard (seconds > 0)  -- --------------------------------------------------------------------------- -- JWT verification -- --------------------------------------------------------------------------- +-- | Verify a token against a key set. Reads the clock, then decides purely. verifyWithKeys ::-  JwkSet ->   FirebaseConfig ->   BS.ByteString ->+  JwkSet ->   IO (Either AuthError FirebaseUser)-verifyWithKeys jwks config tokenBytes = do+verifyWithKeys config tokenBytes jwks = do   now <- getCurrentTime-  pure $ do-    (headerB64, payloadB64, sigBytes, header, payload) <- parseCompactJwt tokenBytes-    validateAlgorithm header-    pubKey <- findKeyByKid (jhKid header) jwks-    verifySignature pubKey (headerB64 <> "." <> payloadB64) sigBytes-    validateClaims config now payload-    extractUser payload+  pure (validateToken config now jwks tokenBytes) +validateToken ::+  FirebaseConfig ->+  UTCTime ->+  JwkSet ->+  BS.ByteString ->+  Either AuthError FirebaseUser+validateToken config now jwks tokenBytes = do+  parts <- splitCompactJwt tokenBytes+  header <- decodeSegment "header" (jwtHeaderPart parts) >>= decodeJson "header"+  payload <- decodeSegment "payload" (jwtPayloadPart parts) >>= decodeJson "payload"+  signature <- decodeSegment "signature" (jwtSignaturePart parts)+  validateAlgorithm header+  pubKey <- findKeyByKid (jhKid header) jwks+  verifySignature pubKey (signedData parts) signature+  validateClaims config now payload+  extractUser payload++-- | The bytes a JWT signature covers: the header and payload, as sent.+signedData :: JwtParts -> BS.ByteString+signedData parts =+  jwtHeaderPart parts <> BS8.singleton jwtPartSeparator <> jwtPayloadPart parts+ -- --------------------------------------------------------------------------- -- JWT parsing -- --------------------------------------------------------------------------- -parseCompactJwt ::-  BS.ByteString ->-  Either AuthError (BS.ByteString, BS.ByteString, BS.ByteString, JwtHeader, JwtPayload)-parseCompactJwt token =-  case BS8.split '.' token of-    [headerB64, payloadB64, sigB64] -> do-      headerBytes <- decodeSegment "header" headerB64-      payloadBytes <- decodeSegment "payload" payloadB64-      sigBytes <- decodeSegment "signature" sigB64-      header <- decodeJson "header" headerBytes-      payload <- decodeJson "payload" payloadBytes-      Right (headerB64, payloadB64, sigBytes, header, payload)+splitCompactJwt :: BS.ByteString -> Either AuthError JwtParts+splitCompactJwt token =+  case BS8.split jwtPartSeparator token of+    [header, payload, signature] -> Right (JwtParts header payload signature)     _ -> Left (MalformedToken "expected 3 dot-separated parts")  decodeSegment :: Text -> BS.ByteString -> Either AuthError BS.ByteString-decodeSegment label input =-  case B64URL.decode (padBase64Url input) of-    Left err -> Left (MalformedToken (label <> ": " <> T.pack err))-    Right bs -> Right bs+decodeSegment label = first (malformed label) . B64URL.decode . padBase64Url  decodeJson :: (FromJSON a) => Text -> BS.ByteString -> Either AuthError a-decodeJson label bytes =-  case Aeson.eitherDecodeStrict bytes of-    Left err -> Left (MalformedToken (label <> ": " <> T.pack err))-    Right val -> Right val+decodeJson label = first (malformed label) . Aeson.eitherDecodeStrict +malformed :: Text -> String -> AuthError+malformed label detail = MalformedToken (label <> ": " <> T.pack detail)+ -- --------------------------------------------------------------------------- -- Signature verification -- ---------------------------------------------------------------------------@@ -280,13 +395,11 @@  findKeyByKid :: Text -> JwkSet -> Either AuthError PublicKey findKeyByKid kid (JwkSet keys) =-  case filter (\k -> jkKid k == kid) keys of-    (matched : _) -> Right (jkKey matched)-    [] -> Left InvalidSignature+  maybe (Left InvalidSignature) (Right . jkKey) (find ((== kid) . jkKid) keys)  verifySignature :: PublicKey -> BS.ByteString -> BS.ByteString -> Either AuthError ()-verifySignature pubKey signedData sigBytes-  | verify (Just SHA256) pubKey signedData sigBytes = Right ()+verifySignature pubKey payload signature+  | verify (Just SHA256) pubKey payload signature = Right ()   | otherwise = Left InvalidSignature  -- ---------------------------------------------------------------------------@@ -295,13 +408,14 @@  validateClaims :: FirebaseConfig -> UTCTime -> JwtPayload -> Either AuthError () validateClaims config now payload = do-  let projectId = fcProjectId config-      expectedIssuer = firebaseIssuerPrefix <> projectId-      skew = fcClockSkew config   requireClaim "iss" (jpIss payload) (== expectedIssuer) (InvalidClaims "issuer mismatch")   requireClaim "aud" (jpAud payload) (== projectId) (InvalidClaims "audience mismatch")   requireExpiry skew now (jpExp payload)   requireIssuedAt skew now (jpIat payload)+  where+    projectId = fcProjectId config+    expectedIssuer = firebaseIssuerPrefix <> projectId+    skew = fcClockSkew config  requireClaim :: Text -> Maybe Text -> (Text -> Bool) -> AuthError -> Either AuthError () requireClaim label mVal predicate err =@@ -313,18 +427,14 @@ requireExpiry :: NominalDiffTime -> UTCTime -> Maybe Integer -> Either AuthError () requireExpiry _skew _now Nothing = Left (InvalidClaims "missing exp claim") requireExpiry skew now (Just expSeconds)-  | addUTCTime skew expTime >= now = Right ()+  | addUTCTime skew (posixSecondsToUTCTime (fromInteger expSeconds)) >= now = Right ()   | otherwise = Left TokenExpired-  where-    expTime = posixSecondsToUTCTime (fromInteger expSeconds)  requireIssuedAt :: NominalDiffTime -> UTCTime -> Maybe Integer -> Either AuthError () requireIssuedAt _skew _now Nothing = Left (InvalidClaims "missing iat claim") requireIssuedAt skew now (Just iatSeconds)-  | diffUTCTime iatTime now <= skew = Right ()+  | diffUTCTime (posixSecondsToUTCTime (fromInteger iatSeconds)) now <= skew = Right ()   | otherwise = Left (InvalidClaims "token issued in the future")-  where-    iatTime = posixSecondsToUTCTime (fromInteger iatSeconds)  -- --------------------------------------------------------------------------- -- User extraction@@ -333,8 +443,18 @@ extractUser :: JwtPayload -> Either AuthError FirebaseUser extractUser payload =   case jpSub payload of-    Just sub-      | not (T.null sub) ->-          Right FirebaseUser {fuUid = sub, fuEmail = jpEmail payload, fuName = jpName payload}-    Just _ -> Left (InvalidClaims "empty sub claim")     Nothing -> Left (InvalidClaims "missing sub claim")+    Just sub+      | T.null sub -> Left (InvalidClaims "empty sub claim")+      | otherwise ->+          Right+            FirebaseUser+              { fuUid = sub,+                fuEmail = jpEmail payload,+                fuEmailVerified = jpEmailVerified payload,+                fuName = jpName payload,+                fuPicture = jpPicture payload,+                fuAuthTime = posixSecondsToUTCTime . fromInteger <$> jpAuthTime payload,+                fuSignInProvider = jpSignInProvider payload,+                fuCustomClaims = jpCustomClaims payload+              }

@@ -0,0 +1,88 @@+-- |+-- Module      : Firebase.Auth.Internal+-- Description : Encoding and header primitives shared across the auth layers+--+-- Primitives shared by the JWT verifier and the WAI and Servant+-- integrations. Everything here is pure and depends only on the wire+-- formats, never on the authentication types, so each layer can use it+-- without pulling in the others.+module Firebase.Auth.Internal+  ( -- * Base64url+    padBase64Url,++    -- * Bearer tokens+    bearerToken,+    stripBearerPrefix,+    bearerChallenge,+  )+where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.Char (toLower)+import Data.Word (Word8)+import Network.HTTP.Types.Header (RequestHeaders, hAuthorization)++-- ---------------------------------------------------------------------------+-- Base64url+-- ---------------------------------------------------------------------------++-- | Base64 encodes three bytes per four characters, so a padded payload is+-- always a whole number of four-character groups.+base64GroupSize :: Int+base64GroupSize = 4++-- | ASCII @\'=\'@, the byte base64 pads a short final group with.+base64PadByte :: Word8+base64PadByte = 0x3d++-- | Restore the padding that JWT and JWK strip from their base64url payloads.+--+-- >>> padBase64Url "YWJjZA"+-- "YWJjZA=="+padBase64Url :: BS.ByteString -> BS.ByteString+padBase64Url payload+  | remainder == 0 = payload+  | otherwise = payload <> BS.replicate (base64GroupSize - remainder) base64PadByte+  where+    remainder = BS.length payload `rem` base64GroupSize++-- ---------------------------------------------------------------------------+-- Bearer tokens+-- ---------------------------------------------------------------------------++-- | The @Bearer@ authentication scheme, including the space that separates+-- it from the credentials.+bearerPrefix :: BS.ByteString+bearerPrefix = "Bearer "++-- | 'bearerPrefix' folded to lower case once, for case-insensitive matching.+bearerPrefixLower :: BS.ByteString+bearerPrefixLower = BS8.map toLower bearerPrefix++-- | The challenge a 401 response carries in its @WWW-Authenticate@ header,+-- naming the scheme the request should have used, as RFC 6750 requires.+bearerChallenge :: BS.ByteString+bearerChallenge = "Bearer"++-- | Extract a bearer token from a request's headers.+--+-- Takes the header list rather than a request so that both the WAI and the+-- Servant integrations can share it without either becoming a dependency of+-- the other.+bearerToken :: RequestHeaders -> Maybe BS.ByteString+bearerToken headers = lookup hAuthorization headers >>= stripBearerPrefix++-- | Strip the @\"Bearer \"@ prefix from an @Authorization@ header value.+--+-- The scheme name is matched case-insensitively, as RFC 7235 requires; the+-- credentials that follow are returned verbatim.+--+-- >>> stripBearerPrefix "bearer abc.def.ghi"+-- Just "abc.def.ghi"+stripBearerPrefix :: BS.ByteString -> Maybe BS.ByteString+stripBearerPrefix header+  | BS8.map toLower scheme == bearerPrefixLower = Just credentials+  | otherwise = Nothing+  where+    (scheme, credentials) = BS.splitAt (BS.length bearerPrefix) header

@@ -1,10 +1,6 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StrictData #-}- -- | -- Module      : Firebase.Auth.Types -- Description : Types for Firebase JWT verification--- License     : BSD-3-Clause -- -- Core data types for Firebase ID token verification: configuration, -- authenticated user, error reporting, and key caching.@@ -15,32 +11,38 @@      -- * Authenticated User     FirebaseUser (..),+    lookupClaim,+    hasClaim,      -- * Errors     AuthError (..),+    authErrorMessage,      -- * Key Cache+    -- $keycache     KeyCache (..),      -- * JWK Types     JwkKey (..),     JwkSet (..),--    -- * Internal (re-exported for Firebase.Auth)-    padBase64Url,   ) where -import Control.Concurrent.STM (TVar) import Crypto.PubKey.RSA.Types (PublicKey (..)) import Data.Aeson (FromJSON (..), Object, withObject, (.:))+import qualified Data.Aeson as Aeson import Data.Aeson.Types (Parser) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64.URL as B64URL+import qualified Data.ByteString.Lazy as LBS+import Data.IORef (IORef)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Time (NominalDiffTime, UTCTime)+import Firebase.Auth.Internal (padBase64Url) import Network.HTTP.Client (Manager)  -- ---------------------------------------------------------------------------@@ -81,11 +83,40 @@     fuUid :: !Text,     -- | Email address, if present in token claims.     fuEmail :: !(Maybe Text),+    -- | Whether Firebase considers the email address verified.+    fuEmailVerified :: !Bool,     -- | Display name, if present in token claims.-    fuName :: !(Maybe Text)+    fuName :: !(Maybe Text),+    -- | Profile picture URL, if present in token claims.+    fuPicture :: !(Maybe Text),+    -- | When the user last authenticated, from the @auth_time@ claim.+    -- Check this to require a recent login before a sensitive action.+    fuAuthTime :: !(Maybe UTCTime),+    -- | How the user signed in (@password@, @google.com@, @anonymous@, ...).+    fuSignInProvider :: !(Maybe Text),+    -- | Claims outside Firebase's reserved set, as assigned by the Admin+    -- SDK's @setCustomUserClaims@. This is where roles and permissions live.+    fuCustomClaims :: !(Map Text Aeson.Value)   }   deriving (Eq, Show) +-- | Look up a custom claim by name.+--+-- Reserved claims are not included; read those through the dedicated+-- fields.+lookupClaim :: Text -> FirebaseUser -> Maybe Aeson.Value+lookupClaim name = Map.lookup name . fuCustomClaims++-- | Whether a custom claim is present and exactly @true@.+--+-- The usual shape of a Firebase role check:+--+-- @+-- if hasClaim \"admin\" user then handleAdmin else refuse+-- @+hasClaim :: Text -> FirebaseUser -> Bool+hasClaim name user = lookupClaim name user == Just (Aeson.Bool True)+ -- --------------------------------------------------------------------------- -- Errors -- ---------------------------------------------------------------------------@@ -104,18 +135,36 @@     MalformedToken !Text   deriving (Eq, Show) +-- | Render an 'AuthError' as a message safe to return to a client.+--+-- The 'Text' payloads carried by 'KeyFetchError', 'InvalidClaims', and+-- 'MalformedToken' name internal specifics, so they are deliberately+-- dropped here: they belong in your logs, not in a 401 body.+authErrorMessage :: AuthError -> LBS.ByteString+authErrorMessage (KeyFetchError _) = "Authentication service unavailable"+authErrorMessage InvalidSignature = "Invalid token signature"+authErrorMessage TokenExpired = "Token expired"+authErrorMessage (InvalidClaims _) = "Invalid token claims"+authErrorMessage (MalformedToken _) = "Malformed token"+ -- --------------------------------------------------------------------------- -- Key cache -- --------------------------------------------------------------------------- +-- $keycache+-- The cache is created by "Firebase.Auth", which re-exports t'KeyCache' as an+-- abstract type. Its fields are visible here only so the verifier can reach+-- them, and are not part of the supported API.+ -- | Cached store of Google's public JWKs. ----- Create with 'Firebase.Auth.newKeyCache'. Keys are refreshed automatically--- when expired (per Google's @Cache-Control: max-age@ header).--- Thread-safe via STM — concurrent verifications compose atomically.+-- Create with 'Firebase.Auth.newKeyCache' or 'Firebase.Auth.newTlsKeyCache'.+-- Keys are refreshed automatically when expired (per Google's+-- @Cache-Control: max-age@ header). Safe to share across threads: updates go+-- through 'Data.IORef.atomicModifyIORef''. data KeyCache = KeyCache-  { -- | Cached JWK set and its expiry time (STM for atomic concurrent access).-    kcKeysRef :: !(TVar (JwkSet, UTCTime)),+  { -- | Cached JWK set paired with the instant it stops being valid.+    kcKeysRef :: !(IORef (JwkSet, UTCTime)),     -- | HTTP manager for fetching keys from Google.     kcManager :: !Manager   }@@ -157,22 +206,25 @@   eB64 <- o .: "e"   case (,) <$> decodeBase64Url nB64 <*> decodeBase64Url eB64 of     Left err -> fail err-    Right (nBytes, eBytes) ->-      let keySize = BS.length nBytes-       in pure $ JwkKey kid (PublicKey keySize (bsToInteger nBytes) (bsToInteger eBytes))+    Right (modulus, publicExponent) ->+      pure $+        JwkKey+          kid+          ( PublicKey+              (BS.length modulus)+              (bsToInteger modulus)+              (bsToInteger publicExponent)+          ) --- | Decode a base64url-encoded text value, adding padding as needed.+-- | Decode a base64url-encoded text value, restoring its padding first. decodeBase64Url :: Text -> Either String BS.ByteString decodeBase64Url = B64URL.decode . padBase64Url . TE.encodeUtf8 --- | Add padding to a base64url-encoded string (JWK/JWT use unpadded base64url).-padBase64Url :: BS.ByteString -> BS.ByteString-padBase64Url bs =-  let remainder = BS.length bs `mod` 4-   in if remainder == 0-        then bs-        else bs <> BS.replicate (4 - remainder) 0x3d -- '='+-- | Number of distinct values a byte can take, the radix of a big-endian+-- byte string read as an integer.+byteRadix :: Integer+byteRadix = 256  -- | Convert a big-endian unsigned 'BS.ByteString' to an 'Integer'. bsToInteger :: BS.ByteString -> Integer-bsToInteger = BS.foldl' (\acc w -> acc * 256 + fromIntegral w) 0+bsToInteger = BS.foldl' (\acc byte -> acc * byteRadix + fromIntegral byte) 0

@@ -1,10 +1,6 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StrictData #-}- -- | -- Module      : Firebase.Auth.WAI -- Description : WAI middleware for Firebase authentication--- License     : BSD-3-Clause -- -- Firebase authentication middleware for any WAI-based web server. -- Works with Warp, Scotty, Yesod, Spock, and any other framework@@ -33,22 +29,35 @@ where  import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy.Char8 as LBS8+import qualified Data.ByteString.Lazy as LBS import qualified Data.Vault.Lazy as Vault-import Firebase.Auth (verifyIdTokenCached)-import Firebase.Auth.Types (AuthError (..), FirebaseConfig, FirebaseUser, KeyCache)+import Firebase.Auth (FirebaseConfig, FirebaseUser, KeyCache, authErrorMessage, verifyIdTokenCached)+import Firebase.Auth.Internal (bearerChallenge, bearerToken)+import Network.HTTP.Types.Header (hContentType, hWWWAuthenticate) import Network.HTTP.Types.Status (status401)-import Network.Wai (Middleware, Request, Response, requestHeaders, responseLBS, vault)+import Network.Wai+  ( Middleware,+    Request,+    Response,+    ResponseReceived,+    requestHeaders,+    responseLBS,+    vault,+  ) import System.IO.Unsafe (unsafePerformIO)  -- --------------------------------------------------------------------------- -- Constants -- --------------------------------------------------------------------------- --- | The @\"Bearer \"@ prefix length (7 bytes).-bearerPrefixLen :: Int-bearerPrefixLen = 7+-- | Media type of the plain-text bodies this middleware returns.+textPlain :: BS.ByteString+textPlain = "text/plain; charset=utf-8" +-- | Response body when no bearer token was supplied at all.+missingHeaderMessage :: LBS.ByteString+missingHeaderMessage = "Missing or malformed Authorization header"+ -- --------------------------------------------------------------------------- -- Simple Middleware -- ---------------------------------------------------------------------------@@ -62,14 +71,8 @@ -- main = run 3000 $ requireAuth cache cfg myApp -- @ requireAuth :: KeyCache -> FirebaseConfig -> Middleware-requireAuth cache cfg app req respond = do-  case extractBearer req of-    Nothing -> respond unauthorizedResponse-    Just tok -> do-      result <- verifyIdTokenCached cache cfg tok-      case result of-        Left err -> respond (errorResponse err)-        Right _user -> app req respond+requireAuth cache cfg app req respond =+  withVerifiedUser cache cfg req respond (const (app req respond))  -- --------------------------------------------------------------------------- -- Vault-based Middleware (advanced)@@ -98,16 +101,9 @@ --   Nothing   -> ...  -- should not happen (middleware rejects first) -- @ firebaseAuth :: KeyCache -> FirebaseConfig -> Middleware-firebaseAuth cache cfg app req respond = do-  case extractBearer req of-    Nothing -> respond unauthorizedResponse-    Just tok -> do-      result <- verifyIdTokenCached cache cfg tok-      case result of-        Left err -> respond (errorResponse err)-        Right user ->-          let req' = req {vault = Vault.insert firebaseUserKey user (vault req)}-           in app req' respond+firebaseAuth cache cfg app req respond =+  withVerifiedUser cache cfg req respond $ \user ->+    app req {vault = Vault.insert firebaseUserKey user (vault req)} respond  -- | Look up the authenticated 'FirebaseUser' from a WAI request vault. --@@ -119,34 +115,29 @@ -- Helpers -- --------------------------------------------------------------------------- --- | Extract a Bearer token from a request's Authorization header.-extractBearer :: Request -> Maybe BS.ByteString-extractBearer req = do-  hdr <- lookup "Authorization" (requestHeaders req)-  if "Bearer " `BS.isPrefixOf` hdr-    then Just (BS.drop bearerPrefixLen hdr)-    else Nothing---- | 401 response for missing or invalid tokens.-unauthorizedResponse :: Response-unauthorizedResponse =-  responseLBS-    status401-    [("Content-Type", "text/plain")]-    "Missing or malformed Authorization header"+-- | Verify the request's bearer token, answering 401 on any failure and+-- handing the authenticated user to the continuation otherwise.+--+-- Both middlewares share this, so they cannot drift apart on which requests+-- they admit or what they say when they refuse.+withVerifiedUser ::+  KeyCache ->+  FirebaseConfig ->+  Request ->+  (Response -> IO ResponseReceived) ->+  (FirebaseUser -> IO ResponseReceived) ->+  IO ResponseReceived+withVerifiedUser cache cfg req respond onVerified =+  case bearerToken (requestHeaders req) of+    Nothing -> respond (unauthorized missingHeaderMessage)+    Just token -> do+      result <- verifyIdTokenCached cache cfg token+      either (respond . unauthorized . authErrorMessage) onVerified result --- | 401 response with a description of the auth error.-errorResponse :: AuthError -> Response-errorResponse err =+-- | A 401 response carrying a plain-text explanation and the+-- @WWW-Authenticate@ challenge RFC 6750 requires.+unauthorized :: LBS.ByteString -> Response+unauthorized =   responseLBS     status401-    [("Content-Type", "text/plain")]-    (authErrorMessage err)---- | Convert an 'AuthError' to a response message.-authErrorMessage :: AuthError -> LBS8.ByteString-authErrorMessage (KeyFetchError _) = "Authentication service unavailable"-authErrorMessage InvalidSignature = "Invalid token signature"-authErrorMessage TokenExpired = "Token expired"-authErrorMessage (InvalidClaims _) = "Invalid token claims"-authErrorMessage (MalformedToken _) = "Malformed token"+    [(hContentType, textPlain), (hWWWAuthenticate, bearerChallenge)]

@@ -1,36 +1,38 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StrictData #-}- -- | -- Module      : Firebase.Firestore -- Description : Firestore REST API client--- License     : BSD-3-Clause -- -- CRUD operations, structured queries, and atomic transactions against the--- Firestore REST API. All operations return @'Either' 'FirestoreError' a@ —+-- Firestore REST API. All operations return @'Either' 'FirestoreError' a@ - -- no exceptions are thrown for API-level errors. -- -- @+-- import qualified Data.Map.Strict as Map -- import Firebase.Firestore -- -- main :: IO () -- main = do---   mgr <- newTlsManager---   let pid = ProjectId \"my-project\"---       tok = AccessToken \"ya29...\"---       path = DocumentPath (CollectionPath \"users\") (DocumentId \"alice\")---   result <- getDocument mgr tok pid path+--   fs <- newFirestore (ProjectId \"my-project\") (AccessToken \"ya29...\")+--   let path = DocumentPath (CollectionPath \"users\") (DocumentId \"alice\")+--   result <- getDocument fs path --   case result of --     Left err  -> print err --     Right doc -> print (docFields doc) -- @ module Firebase.Firestore-  ( -- * CRUD Operations+  ( -- * Handle+    newFirestore,+    withToken,++    -- * CRUD Operations     getDocument,     createDocument,     updateDocument,     deleteDocument, +    -- * Listing+    listDocuments,+     -- * Queries     runQuery, @@ -40,6 +42,14 @@     rollbackTransaction,     runTransaction, +    -- * Transactional Reads+    getDocumentInTransaction,+    runQueryInTransaction,++    -- * Transaction Writes+    mkUpdateWrite,+    mkDeleteWrite,+     -- * HTTP Manager     newTlsManager, @@ -49,13 +59,14 @@   ) where -import Control.Exception (SomeException, try)+import Control.Exception (try) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson-import qualified Data.Aeson.KeyMap as KM+import Data.Bifunctor (first) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS+import Data.Functor (void) import Data.Map.Strict (Map) import Data.Text (Text) import qualified Data.Text as T@@ -63,7 +74,7 @@ import Firebase.Firestore.Query import Firebase.Firestore.Types import Network.HTTP.Client-  ( Manager,+  ( HttpException,     Request,     RequestBody (..),     Response,@@ -76,257 +87,280 @@     responseStatus,   ) import Network.HTTP.Client.TLS (newTlsManager)-import Network.HTTP.Types.Status (statusCode)+import Network.HTTP.Types.Header (hContentType)+import Network.HTTP.Types.Method+  ( Method,+    methodDelete,+    methodGet,+    methodPatch,+    methodPost,+  )+import Network.HTTP.Types.Status (statusCode, statusIsSuccessful)  -- ------------------------------------------------------------------------------ HTTP status code constants+-- Constants -- --------------------------------------------------------------------------- --- | HTTP 200 OK.-httpOk :: Int-httpOk = 200+-- | Media type of every request body this client sends.+applicationJson :: BS.ByteString+applicationJson = "application/json" --- | Upper bound for successful HTTP status codes (exclusive).-httpSuccessUpperBound :: Int-httpSuccessUpperBound = 300+-- ---------------------------------------------------------------------------+-- Handle+-- --------------------------------------------------------------------------- +-- | Build a t'Firestore' handle with a fresh TLS-enabled HTTP manager.+--+-- Build one and share it: the manager pools connections, so a handle per+-- request throws that away.+newFirestore :: ProjectId -> AccessToken -> IO Firestore+newFirestore pid tok = do+  mgr <- newTlsManager+  pure Firestore {fsManager = mgr, fsProject = pid, fsToken = tok}++-- | Replace the access token, keeping the manager and project.+--+-- OAuth2 tokens expire; swap in a fresh one rather than rebuilding the+-- handle and discarding the connection pool with it.+withToken :: AccessToken -> Firestore -> Firestore+withToken tok fs = fs {fsToken = tok}+ -- --------------------------------------------------------------------------- -- CRUD Operations -- ---------------------------------------------------------------------------  -- | Fetch a single document by path.-getDocument ::-  Manager ->-  AccessToken ->-  ProjectId ->-  DocumentPath ->-  IO (Either FirestoreError Document)-getDocument mgr tok pid dp =-  fmap (>>= decodeDocument) (doGet mgr tok (documentUrl pid dp))+getDocument :: Firestore -> DocumentPath -> IO (Either FirestoreError Document)+getDocument fs dp =+  fmap (>>= decodeBody) (doGet fs (documentUrl (fsProject fs) dp))  -- | Create a document with a specific ID in a collection. createDocument ::-  Manager ->-  AccessToken ->-  ProjectId ->+  Firestore ->   CollectionPath ->   DocumentId ->   Map Text FirestoreValue ->   IO (Either FirestoreError Document)-createDocument mgr tok pid cp did fields =-  let body = Aeson.encode (Aeson.object ["fields" .= fields])-   in fmap (>>= decodeDocument) (doPost mgr tok (createDocUrl pid cp did) body)+createDocument fs cp did fields =+  fmap (>>= decodeBody) (doPost fs (createDocUrl (fsProject fs) cp did) (encodeFields fields))  -- | Update a document's fields. Pass field names to update specific fields, -- or an empty list to replace all fields. updateDocument ::-  Manager ->-  AccessToken ->-  ProjectId ->+  Firestore ->   DocumentPath ->   [Text] ->   Map Text FirestoreValue ->   IO (Either FirestoreError Document)-updateDocument mgr tok pid dp fieldPaths fields =-  let body = Aeson.encode (Aeson.object ["fields" .= fields])-   in fmap (>>= decodeDocument) (doPatch mgr tok (updateDocUrl pid dp fieldPaths) body)+updateDocument fs dp fieldPaths fields =+  fmap (>>= decodeBody) (doPatch fs (updateDocUrl (fsProject fs) dp fieldPaths) (encodeFields fields))  -- | Delete a document by path.-deleteDocument ::-  Manager ->-  AccessToken ->-  ProjectId ->-  DocumentPath ->-  IO (Either FirestoreError ())-deleteDocument mgr tok pid dp =-  fmap (>> Right ()) (doRequest mgr tok (documentUrl pid dp) "DELETE" Nothing)+deleteDocument :: Firestore -> DocumentPath -> IO (Either FirestoreError ())+deleteDocument fs dp =+  fmap void (doRequest fs (documentUrl (fsProject fs) dp) methodDelete Nothing) +-- | Encode a field map as a Firestore write body.+encodeFields :: Map Text FirestoreValue -> LBS.ByteString+encodeFields fields = Aeson.encode (Aeson.object ["fields" .= fields])+ -- ---------------------------------------------------------------------------+-- Listing+-- ---------------------------------------------------------------------------++-- | List the documents in a collection.+--+-- Returns the first page Firestore sends, which is capped server-side. For+-- anything larger, or for a specific ordering, use 'runQuery'.+listDocuments :: Firestore -> CollectionPath -> IO (Either FirestoreError [Document])+listDocuments fs cp =+  fmap (>>= decodeDocumentList) (doGet fs (collectionUrl (fsProject fs) cp))++-- --------------------------------------------------------------------------- -- Queries -- ---------------------------------------------------------------------------  -- | Run a structured query against the Firestore REST API.-runQuery ::-  Manager ->-  AccessToken ->-  ProjectId ->-  StructuredQuery ->-  IO (Either FirestoreError [Document])-runQuery mgr tok pid sq =-  let body = Aeson.encode (encodeQuery sq)-   in fmap (>>= decodeQueryResults) (doPost mgr tok (queryUrl pid) body)+--+-- The request is posted to the queried collection's parent resource, so+-- subcollection paths (@\"users\/abc\/posts\"@) address the subcollection+-- under that document.+runQuery :: Firestore -> StructuredQuery -> IO (Either FirestoreError [Document])+runQuery fs sq =+  fmap (>>= decodeQueryResults) (doPost fs (runQueryUrl (fsProject fs) (sqFrom sq)) body)+  where+    body = Aeson.encode (encodeQuery sq)  -- --------------------------------------------------------------------------- -- Transactions -- ---------------------------------------------------------------------------  -- | Begin a new transaction.-beginTransaction ::-  Manager ->-  AccessToken ->-  ProjectId ->-  TransactionMode ->-  IO (Either FirestoreError TransactionId)-beginTransaction mgr tok pid mode =-  let body = Aeson.encode (encodeTransactionOptions mode)-   in fmap (>>= decodeTransactionId) (doPost mgr tok (beginTransactionUrl pid) body)+beginTransaction :: Firestore -> TransactionMode -> IO (Either FirestoreError TransactionId)+beginTransaction fs mode =+  fmap (>>= decodeTransactionId) (doPost fs (beginTransactionUrl (fsProject fs)) body)+  where+    body = Aeson.encode (encodeTransactionOptions mode)  -- | Commit a transaction with a list of write operations. commitTransaction ::-  Manager ->-  AccessToken ->-  ProjectId ->-  TransactionId ->-  [Aeson.Value] ->-  IO (Either FirestoreError ())-commitTransaction mgr tok pid (TransactionId txnId) writes =-  let body =-        Aeson.encode-          (Aeson.object ["writes" .= writes, "transaction" .= txnId])-   in fmap (>> Right ()) (doPost mgr tok (commitUrl pid) body)+  Firestore -> TransactionId -> [Write] -> IO (Either FirestoreError ())+commitTransaction fs (TransactionId txnId) writes =+  fmap void (doPost fs (commitUrl (fsProject fs)) body)+  where+    body = Aeson.encode (Aeson.object ["writes" .= writes, "transaction" .= txnId])  -- | Roll back a transaction without committing.-rollbackTransaction ::-  Manager ->-  AccessToken ->-  ProjectId ->-  TransactionId ->-  IO (Either FirestoreError ())-rollbackTransaction mgr tok pid (TransactionId txnId) =-  let body = Aeson.encode (Aeson.object ["transaction" .= txnId])-   in fmap (>> Right ()) (doPost mgr tok (rollbackUrl pid) body)+rollbackTransaction :: Firestore -> TransactionId -> IO (Either FirestoreError ())+rollbackTransaction fs (TransactionId txnId) =+  fmap void (doPost fs (rollbackUrl (fsProject fs)) body)+  where+    body = Aeson.encode (Aeson.object ["transaction" .= txnId])  -- | Run an atomic transaction. The callback receives the transaction ID -- and should return a list of writes to commit. ----- On success, all writes are applied atomically. On failure (including--- callback errors), the transaction is rolled back automatically.--- Use 'RetryWith' to retry an aborted transaction.+-- Reads made with 'getDocumentInTransaction' or 'runQueryInTransaction'+-- inside the callback see the transaction's snapshot, and Firestore+-- verifies at commit that nothing they read has changed since; losing that+-- race is reported as 'TransactionAborted'. Reads made without the+-- transaction ID are ordinary reads and get no such guarantee. --+-- On success, all writes are applied atomically. On a callback or commit+-- error, the transaction is rolled back automatically. Use 'RetryWith' to+-- retry an aborted transaction.+-- -- @--- runTransaction mgr tok pid ReadWrite $ \\txnId -> runExceptT $ do---   doc <- ExceptT $ getDocument mgr tok pid somePath---   pure [mkUpdateWrite somePath (docFields doc)]+-- runTransaction fs ReadWrite $ \\txnId -> runExceptT $ do+--   doc <- ExceptT $ getDocumentInTransaction fs txnId somePath+--   pure [mkUpdateWrite (fsProject fs) somePath (applyDebit 100 (docFields doc))] -- @ runTransaction ::-  Manager ->-  AccessToken ->-  ProjectId ->+  Firestore ->   TransactionMode ->-  (TransactionId -> IO (Either FirestoreError [Aeson.Value])) ->+  (TransactionId -> IO (Either FirestoreError [Write])) ->   IO (Either FirestoreError ())-runTransaction mgr tok pid mode action = do-  txnResult <- beginTransaction mgr tok pid mode-  case txnResult of-    Left err -> pure (Left err)-    Right txnId -> do+runTransaction fs mode action = do+  started <- beginTransaction fs mode+  either (pure . Left) commitOrRollback started+  where+    commitOrRollback txnId = do       result <- runExceptT $ do-        writes <- ExceptT $ action txnId-        ExceptT $ commitTransaction mgr tok pid txnId writes-      case result of-        Right () -> pure (Right ())-        Left err -> do-          _ <- rollbackTransaction mgr tok pid txnId-          pure (Left err)+        writes <- ExceptT (action txnId)+        ExceptT (commitTransaction fs txnId writes)+      either (rollbackWith txnId) (pure . Right) result +    -- The original failure is what the caller needs; a rollback that also+    -- fails must not mask it.+    rollbackWith txnId err = do+      _ <- rollbackTransaction fs txnId+      pure (Left err)+ -- ---------------------------------------------------------------------------+-- Transactional Reads+-- ---------------------------------------------------------------------------++-- | Fetch a document inside a transaction.+--+-- The read is served from the transaction's snapshot and joins its read+-- set, so a conflicting write elsewhere aborts the commit instead of being+-- silently overwritten.+getDocumentInTransaction ::+  Firestore -> TransactionId -> DocumentPath -> IO (Either FirestoreError Document)+getDocumentInTransaction fs txn dp =+  fmap (>>= decodeBody) (doGet fs (documentInTransactionUrl (fsProject fs) txn dp))++-- | Run a structured query inside a transaction, with the same snapshot+-- and commit-time verification as 'getDocumentInTransaction'.+runQueryInTransaction ::+  Firestore -> TransactionId -> StructuredQuery -> IO (Either FirestoreError [Document])+runQueryInTransaction fs txn sq =+  fmap (>>= decodeQueryResults) (doPost fs (runQueryUrl (fsProject fs) (sqFrom sq)) body)+  where+    body = Aeson.encode (encodeQueryInTransaction txn sq)++-- ---------------------------------------------------------------------------+-- Transaction Writes+-- ---------------------------------------------------------------------------++-- | A t'Write' that sets a document's fields, creating it if absent.+mkUpdateWrite ::+  ProjectId ->+  DocumentPath ->+  Map Text FirestoreValue ->+  Write+mkUpdateWrite pid dp fields =+  Write $+    Aeson.object+      [ "update"+          .= Aeson.object+            [ "name" .= documentResourceName pid dp,+              "fields" .= fields+            ]+      ]++-- | A t'Write' that deletes a document.+mkDeleteWrite :: ProjectId -> DocumentPath -> Write+mkDeleteWrite pid dp =+  Write (Aeson.object ["delete" .= documentResourceName pid dp])++-- --------------------------------------------------------------------------- -- HTTP Helpers -- ---------------------------------------------------------------------------  -- | Perform an authorized GET request.-doGet ::-  Manager -> AccessToken -> String -> IO (Either FirestoreError LBS.ByteString)-doGet mgr tok url = doRequest mgr tok url "GET" Nothing+doGet :: Firestore -> String -> IO (Either FirestoreError LBS.ByteString)+doGet fs url = doRequest fs url methodGet Nothing  -- | Perform an authorized POST request with a JSON body. doPost ::-  Manager ->-  AccessToken ->-  String ->-  LBS.ByteString ->-  IO (Either FirestoreError LBS.ByteString)-doPost mgr tok url body = doRequest mgr tok url "POST" (Just body)+  Firestore -> String -> LBS.ByteString -> IO (Either FirestoreError LBS.ByteString)+doPost fs url body = doRequest fs url methodPost (Just body)  -- | Perform an authorized PATCH request with a JSON body. doPatch ::-  Manager ->-  AccessToken ->-  String ->-  LBS.ByteString ->-  IO (Either FirestoreError LBS.ByteString)-doPatch mgr tok url body = doRequest mgr tok url "PATCH" (Just body)+  Firestore -> String -> LBS.ByteString -> IO (Either FirestoreError LBS.ByteString)+doPatch fs url body = doRequest fs url methodPatch (Just body)  -- | Core HTTP request executor. doRequest ::-  Manager ->-  AccessToken ->+  Firestore ->   String ->-  BS.ByteString ->+  Method ->   Maybe LBS.ByteString ->   IO (Either FirestoreError LBS.ByteString)-doRequest mgr tok url httpMethod mBody = do-  reqResult <- try (parseRequest url) :: IO (Either SomeException Request)-  case reqResult of-    Left err -> pure (Left (NetworkError (T.pack (show err))))-    Right baseReq -> do-      let req =-            authorizeRequest tok $-              baseReq-                { method = httpMethod,-                  requestHeaders =-                    ("Content-Type", "application/json")-                      : requestHeaders baseReq,-                  requestBody = maybe mempty RequestBodyLBS mBody-                }-      respResult <--        try (httpLbs req mgr) ::-          IO (Either SomeException (Response LBS.ByteString))-      case respResult of-        Left err -> pure (Left (NetworkError (T.pack (show err))))-        Right resp ->-          let status = statusCode (responseStatus resp)-              body = responseBody resp-           in if status >= httpOk && status < httpSuccessUpperBound-                then pure (Right body)-                else pure (Left (parseFirestoreError status body))---- ------------------------------------------------------------------------------ Response Decoders (pure)--- ------------------------------------------------------------------------------- | Decode a response body as a t'Document'.-decodeDocument :: LBS.ByteString -> Either FirestoreError Document-decodeDocument body = case Aeson.eitherDecode body of-  Left err -> Left (InvalidResponse (T.pack err))-  Right doc -> Right doc---- | Decode a query response (array of @{\"document\": ...}@ objects).-decodeQueryResults :: LBS.ByteString -> Either FirestoreError [Document]-decodeQueryResults body = case Aeson.eitherDecode body of-  Left err -> Left (InvalidResponse (T.pack err))-  Right results -> Right (extractDocuments results)+doRequest fs url httpMethod mBody = runExceptT $ do+  baseReq <- ExceptT (tryNetwork (parseRequest url))+  let req = buildRequest (fsToken fs) httpMethod mBody baseReq+  resp <- ExceptT (tryNetwork (httpLbs req (fsManager fs)))+  ExceptT (pure (responseOrError resp)) --- | Extract documents from query result objects, skipping entries without--- a @\"document\"@ field (e.g. the final @\"readTime\"@-only entry).-extractDocuments :: [Aeson.Value] -> [Document]-extractDocuments = concatMap go+-- | Run an action, reporting HTTP-layer failures as 'NetworkError'.+--+-- Only 'HttpException' is caught: anything else (asynchronous+-- cancellation, for instance) is not a network result and propagates.+tryNetwork :: IO a -> IO (Either FirestoreError a)+tryNetwork action = first describe <$> try action   where-    go (Aeson.Object o) = case KM.lookup "document" o of-      Just v -> case Aeson.fromJSON v of-        Aeson.Success doc -> [doc]-        _ -> []-      Nothing -> []-    go _ = []+    describe :: HttpException -> FirestoreError+    describe = NetworkError . T.pack . show --- | Decode a beginTransaction response to extract the transaction ID.-decodeTransactionId :: LBS.ByteString -> Either FirestoreError TransactionId-decodeTransactionId body = case Aeson.eitherDecode body of-  Left err -> Left (InvalidResponse (T.pack err))-  Right val -> case extractTxnId val of-    Just txnId -> Right txnId-    Nothing -> Left (InvalidResponse "missing transaction field")+-- | Apply the method, headers, and body to a parsed request.+buildRequest :: AccessToken -> Method -> Maybe LBS.ByteString -> Request -> Request+buildRequest tok httpMethod mBody req =+  authorizeRequest+    tok+    req+      { method = httpMethod,+        requestHeaders = (hContentType, applicationJson) : requestHeaders req,+        requestBody = maybe mempty RequestBodyLBS mBody+      }++-- | A 2xx response yields its body; anything else is a Firestore error.+responseOrError :: Response LBS.ByteString -> Either FirestoreError LBS.ByteString+responseOrError resp+  | statusIsSuccessful status = Right body+  | otherwise = Left (parseFirestoreError (statusCode status) body)   where-    extractTxnId (Aeson.Object o) = case KM.lookup "transaction" o of-      Just (Aeson.String t) -> Just (TransactionId t)-      _ -> Nothing-    extractTxnId _ = Nothing+    status = responseStatus resp+    body = responseBody resp

@@ -1,32 +1,50 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StrictData #-}- -- | -- Module      : Firebase.Firestore.Internal--- Description : Pure URL builders and request helpers for Firestore--- License     : BSD-3-Clause+-- Description : Pure URL builders, request helpers, and response decoders ----- Internal utilities for constructing Firestore REST API URLs and requests.--- All functions are pure and testable without IO.+-- Internal utilities for constructing Firestore REST API URLs and requests+-- and for decoding its responses. All functions are pure and testable+-- without IO.+--+-- Every caller-supplied component is percent-encoded on the way into a URL,+-- so a document ID or field path containing @?@, @#@, @%@, a space, or any+-- non-ASCII character addresses the document it names instead of corrupting+-- the request. module Firebase.Firestore.Internal   ( -- * Constants     firestoreBaseUrl, +    -- * Collection Paths+    splitCollectionPath,+     -- * URL Construction+    databaseUrl,     documentUrl,+    documentInTransactionUrl,     collectionUrl,     createDocUrl,     updateDocUrl,-    queryUrl,+    runQueryUrl,     beginTransactionUrl,     commitUrl,     rollbackUrl, +    -- * Resource Names+    documentResourceName,++    -- * Percent Encoding+    encodePathSegment,+    encodeQueryValue,+     -- * Request Helpers     authorizeRequest, -    -- * Response Parsing+    -- * Response Decoding     parseFirestoreError,+    decodeBody,+    decodeDocumentList,+    decodeQueryResults,+    decodeTransactionId,   ) where @@ -34,13 +52,20 @@ import qualified Data.Aeson as Aeson import qualified Data.Aeson.KeyMap as KM import Data.Aeson.Types (parseMaybe)+import Data.Bifunctor (first)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as LBS+import Data.Foldable (toList) import Data.List (intercalate)-import Data.Maybe (fromMaybe)+import Data.Maybe (catMaybes, fromMaybe) import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import Firebase.Firestore.Types import Network.HTTP.Client (Request, requestHeaders)+import Network.HTTP.Types.Header (hAuthorization)+import Network.HTTP.Types.URI (urlEncode)  -- --------------------------------------------------------------------------- -- Constants@@ -50,28 +75,127 @@ firestoreBaseUrl :: String firestoreBaseUrl = "https://firestore.googleapis.com/v1" --- | Firestore database path segment.+-- | Path of the project's default database, the root of every document path. firestoreDatabasePath :: String firestoreDatabasePath = "/databases/(default)/documents" +-- | Path segment introducing a project.+projectsSegment :: String+projectsSegment = "projects/"++-- | Separator between path segments.+pathSeparator :: String+pathSeparator = "/"++-- | Separator between a URL's path and its query string.+querySeparator :: String+querySeparator = "?"++-- | Separator between query parameters.+paramSeparator :: String+paramSeparator = "&"++-- | The @Bearer@ scheme prefix for the @Authorization@ header.+bearerScheme :: BS.ByteString+bearerScheme = "Bearer "+ -- ---------------------------------------------------------------------------+-- Database-level endpoints+--+-- Firestore names these with a @:verb@ suffix on the database path rather+-- than a path segment of their own.+-- ---------------------------------------------------------------------------++runQueryEndpoint :: String+runQueryEndpoint = ":runQuery"++beginTransactionEndpoint :: String+beginTransactionEndpoint = ":beginTransaction"++commitEndpoint :: String+commitEndpoint = ":commit"++rollbackEndpoint :: String+rollbackEndpoint = ":rollback"++-- ---------------------------------------------------------------------------+-- Percent encoding+-- ---------------------------------------------------------------------------++-- | Percent-encode one path segment.+--+-- Escapes @\/@ as well, so a caller-supplied value can never introduce a+-- path segment of its own.+--+-- >>> encodePathSegment "a/b c"+-- "a%2Fb%20c"+encodePathSegment :: Text -> String+encodePathSegment = BS8.unpack . urlEncode False . TE.encodeUtf8++-- | Percent-encode a query-string value.+--+-- Escapes @&@ and @=@ in addition to the path set, so a value cannot open a+-- parameter of its own.+--+-- >>> encodeQueryValue "a&b=c"+-- "a%26b%3Dc"+encodeQueryValue :: Text -> String+encodeQueryValue = BS8.unpack . urlEncode True . TE.encodeUtf8++-- | Percent-encode a @\/@-separated path. The separators are structural+-- and survive; each segment between them is encoded.+encodeSlashPath :: Text -> String+encodeSlashPath =+  intercalate pathSeparator+    . map encodePathSegment+    . T.splitOn (T.pack pathSeparator)++-- | Percent-encode a collection path.+--+-- Subcollections are addressed as @users\/abc\/posts@, so the @\/@+-- separators survive; each segment between them is encoded.+encodeCollectionPath :: CollectionPath -> String+encodeCollectionPath = encodeSlashPath . unCollectionPath++-- ---------------------------------------------------------------------------+-- Collection paths+-- ---------------------------------------------------------------------------++-- | Split a collection path into its parent document path, if any, and its+-- collection ID: the final @\/@-separated segment.+--+-- A structured query names these separately: the parent addresses the+-- @:runQuery@ URL and the collection ID travels in the query body.+--+-- >>> splitCollectionPath (CollectionPath "users")+-- (Nothing,"users")+--+-- >>> splitCollectionPath (CollectionPath "users/abc/posts")+-- (Just "users/abc","posts")+splitCollectionPath :: CollectionPath -> (Maybe Text, Text)+splitCollectionPath (CollectionPath path) =+  case T.breakOnEnd separator path of+    (parentAndSlash, collectionId)+      | T.null parentAndSlash -> (Nothing, collectionId)+      | otherwise -> (Just (T.dropEnd (T.length separator) parentAndSlash), collectionId)+  where+    separator = T.pack pathSeparator++-- --------------------------------------------------------------------------- -- URL Construction -- --------------------------------------------------------------------------- --- | URL for a specific document.+-- | URL of a project's default database: the prefix every other URL builds on. ----- >>> documentUrl (ProjectId "p") (DocumentPath (CollectionPath "c") (DocumentId "d"))--- "https://firestore.googleapis.com/v1/projects/p/databases/(default)/documents/c/d"-documentUrl :: ProjectId -> DocumentPath -> String-documentUrl pid dp =+-- >>> databaseUrl (ProjectId "p")+-- "https://firestore.googleapis.com/v1/projects/p/databases/(default)/documents"+databaseUrl :: ProjectId -> String+databaseUrl pid =   firestoreBaseUrl-    <> "/projects/"-    <> T.unpack (unProjectId pid)+    <> pathSeparator+    <> projectsSegment+    <> encodePathSegment (unProjectId pid)     <> firestoreDatabasePath-    <> "/"-    <> T.unpack (unCollectionPath (dpCollection dp))-    <> "/"-    <> T.unpack (unDocumentId (dpDocument dp))  -- | URL for a collection (used for listing). --@@ -79,21 +203,39 @@ -- "https://firestore.googleapis.com/v1/projects/p/databases/(default)/documents/users" collectionUrl :: ProjectId -> CollectionPath -> String collectionUrl pid cp =-  firestoreBaseUrl-    <> "/projects/"-    <> T.unpack (unProjectId pid)-    <> firestoreDatabasePath-    <> "/"-    <> T.unpack (unCollectionPath cp)+  databaseUrl pid <> pathSeparator <> encodeCollectionPath cp +-- | URL for a specific document.+--+-- >>> documentUrl (ProjectId "p") (DocumentPath (CollectionPath "c") (DocumentId "d"))+-- "https://firestore.googleapis.com/v1/projects/p/databases/(default)/documents/c/d"+documentUrl :: ProjectId -> DocumentPath -> String+documentUrl pid dp =+  collectionUrl pid (dpCollection dp)+    <> pathSeparator+    <> encodePathSegment (unDocumentId (dpDocument dp))++-- | URL for fetching a document inside a transaction, pinning the read to+-- the transaction's snapshot.+--+-- Transaction IDs are base64, so the value is percent-encoded on its way+-- into the query string.+documentInTransactionUrl :: ProjectId -> TransactionId -> DocumentPath -> String+documentInTransactionUrl pid txn dp =+  documentUrl pid dp+    <> querySeparator+    <> transactionParam+    <> encodeQueryValue (unTransactionId txn)+ -- | URL for creating a document with a specific ID. -- -- The document ID is passed as a query parameter. createDocUrl :: ProjectId -> CollectionPath -> DocumentId -> String createDocUrl pid cp did =   collectionUrl pid cp-    <> "?documentId="-    <> T.unpack (unDocumentId did)+    <> querySeparator+    <> documentIdParam+    <> encodeQueryValue (unDocumentId did)  -- | URL for updating a document with an optional field mask. --@@ -102,51 +244,88 @@ updateDocUrl pid dp fields =   documentUrl pid dp <> fieldMaskParams fields --- | URL for running a structured query.-queryUrl :: ProjectId -> String-queryUrl pid =-  firestoreBaseUrl-    <> "/projects/"-    <> T.unpack (unProjectId pid)-    <> firestoreDatabasePath-    <> ":runQuery"+-- | URL for running a structured query: the @:runQuery@ verb on the+-- queried collection's parent, which is the database root for a top-level+-- collection and the enclosing document for a subcollection.+--+-- The collection's own ID travels in the query body, not the URL; see+-- 'Firebase.Firestore.Query.encodeQuery'.+runQueryUrl :: ProjectId -> CollectionPath -> String+runQueryUrl pid cp =+  case splitCollectionPath cp of+    (Nothing, _) -> databaseEndpoint runQueryEndpoint pid+    (Just parent, _) ->+      databaseUrl pid+        <> pathSeparator+        <> encodeSlashPath parent+        <> runQueryEndpoint  -- | URL for beginning a transaction. beginTransactionUrl :: ProjectId -> String-beginTransactionUrl pid =-  firestoreBaseUrl-    <> "/projects/"-    <> T.unpack (unProjectId pid)-    <> firestoreDatabasePath-    <> ":beginTransaction"+beginTransactionUrl = databaseEndpoint beginTransactionEndpoint  -- | URL for committing a transaction. commitUrl :: ProjectId -> String-commitUrl pid =-  firestoreBaseUrl-    <> "/projects/"-    <> T.unpack (unProjectId pid)-    <> firestoreDatabasePath-    <> ":commit"+commitUrl = databaseEndpoint commitEndpoint  -- | URL for rolling back a transaction. rollbackUrl :: ProjectId -> String-rollbackUrl pid =-  firestoreBaseUrl-    <> "/projects/"-    <> T.unpack (unProjectId pid)-    <> firestoreDatabasePath-    <> ":rollback"+rollbackUrl = databaseEndpoint rollbackEndpoint  -- ---------------------------------------------------------------------------+-- Resource Names+-- ---------------------------------------------------------------------------++-- | Full resource name of a document, as it appears in a document's @name@+-- field and in the writes a transaction commits.+--+-- A resource name is not a URL. It travels inside a JSON string, so its+-- components are carried verbatim rather than percent-encoded.+--+-- >>> documentResourceName (ProjectId "p") (DocumentPath (CollectionPath "c") (DocumentId "d"))+-- "projects/p/databases/(default)/documents/c/d"+documentResourceName :: ProjectId -> DocumentPath -> Text+documentResourceName pid dp =+  T.concat+    [ T.pack projectsSegment,+      unProjectId pid,+      T.pack firestoreDatabasePath,+      separator,+      unCollectionPath (dpCollection dp),+      separator,+      unDocumentId (dpDocument dp)+    ]+  where+    separator = T.pack pathSeparator++-- --------------------------------------------------------------------------- -- Helpers -- --------------------------------------------------------------------------- --- | Build @updateMask.fieldPaths@ query parameters.+-- | A database-level endpoint, named by its @:method@ suffix.+databaseEndpoint :: String -> ProjectId -> String+databaseEndpoint verb pid = databaseUrl pid <> verb++-- | Query parameter naming the ID a created document should take.+documentIdParam :: String+documentIdParam = "documentId="++-- | Query parameter naming one field an update should touch.+fieldMaskParam :: String+fieldMaskParam = "updateMask.fieldPaths="++-- | Query parameter pinning a read to a transaction's snapshot.+transactionParam :: String+transactionParam = "transaction="++-- | Build the @updateMask.fieldPaths@ query parameters.+--+-- No fields means no mask, which Firestore reads as "replace them all". fieldMaskParams :: [Text] -> String fieldMaskParams [] = ""-fieldMaskParams fs =-  "?" <> intercalate "&" ["updateMask.fieldPaths=" <> T.unpack f | f <- fs]+fieldMaskParams fields =+  querySeparator+    <> intercalate paramSeparator [fieldMaskParam <> encodeQueryValue f | f <- fields]  -- --------------------------------------------------------------------------- -- Request Helpers@@ -155,7 +334,7 @@ -- | Add an OAuth2 Bearer token to a request's Authorization header. authorizeRequest :: AccessToken -> Request -> Request authorizeRequest (AccessToken tok) req =-  req {requestHeaders = ("Authorization", "Bearer " <> tok) : requestHeaders req}+  req {requestHeaders = (hAuthorization, bearerScheme <> tok) : requestHeaders req}  -- --------------------------------------------------------------------------- -- Response Parsing@@ -168,37 +347,91 @@ -- @ -- { "error": { "code": 404, "message": "...", "status": "NOT_FOUND" } } -- @+--+-- The streaming query endpoints wrap that object in a single-element JSON+-- array; both shapes are read. Bodies that match neither fall back to the+-- HTTP status, which is always known. parseFirestoreError :: Int -> LBS.ByteString -> FirestoreError parseFirestoreError status body =-  case Aeson.decode body of-    Just errObj -> parseErrorObject status errObj-    Nothing -> NetworkError ("HTTP " <> T.pack (show status))---- | Parse a decoded Firestore error JSON object.-parseErrorObject :: Int -> Aeson.Value -> FirestoreError-parseErrorObject status = go+  fromMaybe unrecognized (Aeson.decode body >>= classifyErrorValue . unwrapStreamFrame)   where-    go (Aeson.Object o) =-      case Aeson.fromJSON <$> KM.lookup "error" o of-        Just (Aeson.Success errInner) -> parseErrorInner status errInner-        _ -> fallback-    go _ = fallback-    fallback = FirestoreApiError status "" "unknown error"+    -- A body that is not JSON, or not shaped like a Firestore error, tells+    -- us nothing the HTTP status has not already.+    unrecognized = NetworkError ("HTTP " <> T.pack (show status)) --- | Parse the inner @\"error\"@ object.-parseErrorInner :: Int -> Aeson.Value -> FirestoreError-parseErrorInner status = go+-- | Firestore's streaming endpoints (@:runQuery@) frame their response as a+-- JSON array, and frame a failure before the first result as a+-- single-element array wrapping the ordinary error object. Unwrap that so+-- the error inside classifies like any other.+unwrapStreamFrame :: Aeson.Value -> Aeson.Value+unwrapStreamFrame value = case value of+  Aeson.Array elements+    | [single] <- toList elements -> single+  _ -> value++-- | Classify a Firestore error envelope, @{"error": {"code", "status",+-- "message"}}@, when the value has that shape.+classifyErrorValue :: Aeson.Value -> Maybe FirestoreError+classifyErrorValue = parseMaybe errorEnvelope   where-    go val = case parseMaybe parseInner val of-      Just (code, grpcStatus, msg) -> classifyError code grpcStatus msg-      Nothing -> FirestoreApiError status "" "unparseable error"-    parseInner = Aeson.withObject "error" $ \o ->-      (,,) <$> o .: "code" <*> o .:? "status" <*> o .:? "message"+    errorEnvelope = Aeson.withObject "response" $ \o ->+      o .: "error" >>= Aeson.withObject "error" errorObject +    errorObject e = classifyError <$> e .: "code" <*> e .:? "status" <*> e .:? "message"+ -- | Classify a Firestore error by HTTP code and gRPC status. classifyError :: Int -> Maybe Text -> Maybe Text -> FirestoreError classifyError 404 _ _ = DocumentNotFound-classifyError 403 _ msg = PermissionDenied (fromMaybe "" msg)-classifyError 409 (Just "ABORTED") msg = TransactionAborted (fromMaybe "" msg)+classifyError 403 _ msg = PermissionDenied (orEmpty msg)+classifyError 409 (Just "ABORTED") msg = TransactionAborted (orEmpty msg) classifyError code grpcStatus msg =-  FirestoreApiError code (fromMaybe "" grpcStatus) (fromMaybe "" msg)+  FirestoreApiError code (orEmpty grpcStatus) (orEmpty msg)++-- | An absent optional error field reads as the empty string.+orEmpty :: Maybe Text -> Text+orEmpty = fromMaybe ""++-- | Decode a response body, reporting parse failures as 'InvalidResponse'.+decodeBody :: (Aeson.FromJSON a) => LBS.ByteString -> Either FirestoreError a+decodeBody = first (InvalidResponse . T.pack) . Aeson.eitherDecode++-- | Decode a @:list@ response. An empty collection omits @documents@.+decodeDocumentList :: LBS.ByteString -> Either FirestoreError [Document]+decodeDocumentList body = decodeBody body >>= documentsField+  where+    documentsField (Aeson.Object o) =+      maybe (Right []) (fromAesonResult . Aeson.fromJSON) (KM.lookup "documents" o)+    documentsField _ = Left (InvalidResponse "expected a JSON object")++-- | Decode a @:runQuery@ response: a stream of result objects, of which+-- only some carry a document (the final entry may be @readTime@-only).+--+-- A result object whose document fails to decode is an error, not a+-- skipped entry. An entry carrying an @error@ (a mid-stream failure) is+-- reported too, rather than dropped as a non-document entry.+decodeQueryResults :: LBS.ByteString -> Either FirestoreError [Document]+decodeQueryResults body =+  decodeBody body >>= fmap catMaybes . traverse resultDocument+  where+    resultDocument value@(Aeson.Object o) =+      case classifyErrorValue value of+        Just err -> Left err+        Nothing -> traverse (fromAesonResult . Aeson.fromJSON) (KM.lookup "document" o)+    resultDocument _ = Left (InvalidResponse "expected a query result object")++-- | Decode a @:beginTransaction@ response to extract the transaction ID.+decodeTransactionId :: LBS.ByteString -> Either FirestoreError TransactionId+decodeTransactionId body =+  decodeBody body >>= maybe (Left missingTransaction) Right . transactionField+  where+    missingTransaction = InvalidResponse "missing transaction field"++    transactionField (Aeson.Object o) = case KM.lookup "transaction" o of+      Just (Aeson.String txnId) -> Just (TransactionId txnId)+      _ -> Nothing+    transactionField _ = Nothing++-- | Read an aeson conversion, reporting failure as 'InvalidResponse'.+fromAesonResult :: Aeson.Result a -> Either FirestoreError a+fromAesonResult (Aeson.Success value) = Right value+fromAesonResult (Aeson.Error err) = Left (InvalidResponse (T.pack err))

@@ -1,10 +1,6 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StrictData #-}- -- | -- Module      : Firebase.Firestore.Query -- Description : Structured query DSL for Firestore--- License     : BSD-3-Clause -- -- A pure builder-pattern DSL for constructing Firestore structured queries. -- Compose with @(&)@ from "Data.Function":@@ -19,7 +15,7 @@ -- @ module Firebase.Firestore.Query   ( -- * Query Construction-    StructuredQuery,+    StructuredQuery (sqFrom),     query,     where_,     orderBy,@@ -41,13 +37,15 @@      -- * Encoding     encodeQuery,+    encodeQueryInTransaction,   ) where  import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson import Data.Text (Text)-import Firebase.Firestore.Types (CollectionPath (..), FirestoreValue)+import Firebase.Firestore.Internal (splitCollectionPath)+import Firebase.Firestore.Types (CollectionPath (..), FirestoreValue, TransactionId (..))  -- --------------------------------------------------------------------------- -- Types@@ -56,7 +54,9 @@ -- | A structured query builder. Construct with 'query' and refine with -- 'where_', 'orderBy', 'limit', and 'offset'. data StructuredQuery = StructuredQuery-  { sqFrom :: !CollectionPath,+  { -- | The collection the query reads. 'Firebase.Firestore.runQuery'+    -- addresses its parent resource and the query body names its ID.+    sqFrom :: !CollectionPath,     sqWhere :: !(Maybe Filter),     sqOrderBy :: ![(Text, OrderDirection)],     sqLimit :: !(Maybe Int),@@ -157,9 +157,21 @@ -- | Encode a t'StructuredQuery' to the JSON format expected by the -- Firestore REST API's @:runQuery@ endpoint. encodeQuery :: StructuredQuery -> Aeson.Value-encodeQuery sq =+encodeQuery = queryRequest []++-- | Encode a query that runs inside a transaction: the request carries the+-- transaction ID, so the read joins the transaction's snapshot and is+-- validated at commit.+encodeQueryInTransaction :: TransactionId -> StructuredQuery -> Aeson.Value+encodeQueryInTransaction (TransactionId txn) =+  queryRequest ["transaction" .= txn]++-- | The @:runQuery@ request envelope, with any transaction pinning+-- alongside the structured query itself.+queryRequest :: [(Aeson.Key, Aeson.Value)] -> StructuredQuery -> Aeson.Value+queryRequest extras sq =   Aeson.object-    [ "structuredQuery"+    ( "structuredQuery"         .= Aeson.object           ( ["from" .= [encodeCollectionSelector (sqFrom sq)]]               ++ maybe [] (\f -> ["where" .= encodeFilter f]) (sqWhere sq)@@ -167,12 +179,15 @@               ++ maybe [] (\n -> ["limit" .= n]) (sqLimit sq)               ++ maybe [] (\n -> ["offset" .= n]) (sqOffset sq)           )-    ]+        : extras+    ) --- | Encode a collection selector.+-- | Encode a collection selector: only the collection's own ID. The parent+-- segments of a subcollection path are addressed by the URL instead; see+-- 'Firebase.Firestore.Internal.runQueryUrl'. encodeCollectionSelector :: CollectionPath -> Aeson.Value-encodeCollectionSelector (CollectionPath cp) =-  Aeson.object ["collectionId" .= cp]+encodeCollectionSelector cp =+  Aeson.object ["collectionId" .= snd (splitCollectionPath cp)]  -- | Encode a filter to Firestore JSON. encodeFilter :: Filter -> Aeson.Value

@@ -1,12 +1,6 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TupleSections #-}- -- | -- Module      : Firebase.Firestore.Types -- Description : Types for Firestore REST API--- License     : BSD-3-Clause -- -- Newtypes, value ADT, document, and error types for the Firestore REST API. -- 'FirestoreValue' uses custom JSON instances matching Firestore's tagged@@ -19,8 +13,12 @@     AccessToken (..),     DocumentPath (..), +    -- * Handle+    Firestore (..),+     -- * Values     FirestoreValue (..),+    GeoPoint (..),      -- * Documents     Document (..),@@ -32,23 +30,31 @@     TransactionId (..),     TransactionMode (..),     encodeTransactionOptions,++    -- * Transaction Writes+    Write (..),   ) where -import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=))+import Data.Aeson (FromJSON (..), ToJSON (..), (.!=), (.:), (.:?), (.=)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM import Data.Aeson.Types (Parser)+import Data.Bits (toIntegralSized) import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64 import Data.Int (Int64) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import qualified Data.Text.Read as TR-import Data.Time (UTCTime)+import Data.Time (UTCTime, utctDayTime)+import Data.Time.Clock (diffTimeToPicoseconds, picosecondsToDiffTime) import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeM)+import Network.HTTP.Client (Manager)  -- --------------------------------------------------------------------------- -- Identifiers@@ -82,6 +88,25 @@   deriving (Eq, Show)  -- ---------------------------------------------------------------------------+-- Handle+-- ---------------------------------------------------------------------------++-- | Everything a Firestore operation needs: a connection pool, the project+-- to address, and the credentials to present.+--+-- Build one with 'Firebase.Firestore.newFirestore' and pass it to every+-- call. Access tokens expire, so refresh one with+-- 'Firebase.Firestore.withToken' rather than rebuilding the manager.+data Firestore = Firestore+  { -- | Connection manager, reused across requests.+    fsManager :: !Manager,+    -- | Project every path is resolved against.+    fsProject :: !ProjectId,+    -- | OAuth2 credentials presented on each request.+    fsToken :: !AccessToken+  }++-- --------------------------------------------------------------------------- -- Transactions -- --------------------------------------------------------------------------- @@ -118,20 +143,58 @@   Aeson.object     ["options" .= Aeson.object ["readOnly" .= Aeson.object []]] +-- | A single write in a transaction commit, already in Firestore's wire+-- form.+--+-- Build one with 'Firebase.Firestore.mkUpdateWrite' or+-- 'Firebase.Firestore.mkDeleteWrite'. The constructor is visible so the+-- library can assemble writes, and is not part of the supported API.+newtype Write = Write {unWrite :: Aeson.Value}+  deriving (Eq, Show)++instance ToJSON Write where+  toJSON = unWrite+ -- --------------------------------------------------------------------------- -- Firestore values -- --------------------------------------------------------------------------- +-- | A geographic point, as carried by Firestore's @geoPointValue@.+data GeoPoint = GeoPoint+  { gpLatitude :: !Double,+    gpLongitude :: !Double+  }+  deriving (Eq, Show)++instance ToJSON GeoPoint where+  toJSON gp =+    Aeson.object+      [ "latitude" .= gpLatitude gp,+        "longitude" .= gpLongitude gp+      ]++instance FromJSON GeoPoint where+  parseJSON = Aeson.withObject "geoPointValue" $ \o ->+    -- Firestore omits a coordinate that is exactly zero.+    GeoPoint <$> o .:? "latitude" .!= 0 <*> o .:? "longitude" .!= 0+ -- | A Firestore value, mirroring the tagged JSON wire format. ----- Integers are transmitted as JSON strings (e.g. @{\"integerValue\":\"42\"}@),--- not as JSON numbers. The 'FromJSON' \/ 'ToJSON' instances handle this.+-- Covers every type Firestore stores. Integers are transmitted as JSON+-- strings (e.g. @{\"integerValue\":\"42\"}@) and bytes as base64; the+-- 'FromJSON' \/ 'ToJSON' instances handle both. data FirestoreValue   = NullValue   | BoolValue !Bool   | IntegerValue !Int64   | DoubleValue !Double   | StringValue !Text+  | -- | Raw bytes, transmitted base64-encoded.+    BytesValue !BS.ByteString+  | -- | Full resource name of another document, as built by+    -- 'Firebase.Firestore.Internal.documentResourceName'.+    ReferenceValue !Text+  | GeoPointValue !GeoPoint   | TimestampValue !UTCTime   | ArrayValue ![FirestoreValue]   | MapValue !(Map Text FirestoreValue)@@ -141,15 +204,64 @@ timestampFormat :: String timestampFormat = "%Y-%m-%dT%H:%M:%S%QZ" +-- | Picoseconds in one nanosecond.+picosecondsPerNanosecond :: Integer+picosecondsPerNanosecond = 1000++-- | Drop a 'UTCTime' below nanosecond resolution. Firestore timestamps carry+-- at most nine fractional digits, but a 'UTCTime' holds picoseconds, so a+-- value with sub-nanosecond precision would format to more digits than+-- Firestore accepts and be rejected on write.+truncateToNanos :: UTCTime -> UTCTime+truncateToNanos t =+  t {utctDayTime = picosecondsToDiffTime (nanoseconds * picosecondsPerNanosecond)}+  where+    nanoseconds = diffTimeToPicoseconds (utctDayTime t) `div` picosecondsPerNanosecond++-- | The proto3 JSON spellings of the doubles a JSON number cannot carry.+nanLiteral, positiveInfinityLiteral, negativeInfinityLiteral :: Text+nanLiteral = "NaN"+positiveInfinityLiteral = "Infinity"+negativeInfinityLiteral = "-Infinity"++-- | The IEEE 754 values behind those spellings.+notANumber, positiveInfinity :: Double+notANumber = 0 / 0+positiveInfinity = 1 / 0++-- | Encode a double the way proto3 JSON does: non-finite values travel as+-- strings, everything else as a plain JSON number.+encodeDouble :: Double -> Aeson.Value+encodeDouble d+  | isNaN d = Aeson.String nanLiteral+  | isInfinite d, d > 0 = Aeson.String positiveInfinityLiteral+  | isInfinite d = Aeson.String negativeInfinityLiteral+  | otherwise = Aeson.toJSON d++-- | Parse a double, accepting the proto3 string spellings of the+-- non-finite values alongside plain JSON numbers. Only numbers reach the+-- aeson parser: delegating JSON null would silently read it as NaN.+parseDoubleValue :: Aeson.Value -> Parser Double+parseDoubleValue (Aeson.String t)+  | t == nanLiteral = pure notANumber+  | t == positiveInfinityLiteral = pure positiveInfinity+  | t == negativeInfinityLiteral = pure (negate positiveInfinity)+  | otherwise = fail ("invalid doubleValue: " ++ T.unpack t)+parseDoubleValue v@(Aeson.Number _) = parseJSON v+parseDoubleValue _ = fail "invalid doubleValue: expected a number or a non-finite string"+ instance ToJSON FirestoreValue where   toJSON NullValue = Aeson.object ["nullValue" .= Aeson.Null]   toJSON (BoolValue b) = Aeson.object ["booleanValue" .= b]   toJSON (IntegerValue n) = Aeson.object ["integerValue" .= show n]-  toJSON (DoubleValue d) = Aeson.object ["doubleValue" .= d]+  toJSON (DoubleValue d) = Aeson.object ["doubleValue" .= encodeDouble d]   toJSON (StringValue s) = Aeson.object ["stringValue" .= s]+  toJSON (BytesValue bs) = Aeson.object ["bytesValue" .= TE.decodeUtf8 (B64.encode bs)]+  toJSON (ReferenceValue name) = Aeson.object ["referenceValue" .= name]+  toJSON (GeoPointValue gp) = Aeson.object ["geoPointValue" .= gp]   toJSON (TimestampValue t) =     Aeson.object-      ["timestampValue" .= formatTime defaultTimeLocale timestampFormat t]+      ["timestampValue" .= formatTime defaultTimeLocale timestampFormat (truncateToNanos t)]   toJSON (ArrayValue xs) =     Aeson.object ["arrayValue" .= Aeson.object ["values" .= xs]]   toJSON (MapValue m) =@@ -162,19 +274,33 @@       [("nullValue", _)] -> pure NullValue       [("booleanValue", v)] -> BoolValue <$> parseJSON v       [("integerValue", v)] -> IntegerValue <$> parseIntegerValue v-      [("doubleValue", v)] -> DoubleValue <$> parseJSON v+      [("doubleValue", v)] -> DoubleValue <$> parseDoubleValue v       [("stringValue", v)] -> StringValue <$> parseJSON v+      [("bytesValue", v)] -> BytesValue <$> parseBytesValue v+      [("referenceValue", v)] -> ReferenceValue <$> parseJSON v+      [("geoPointValue", v)] -> GeoPointValue <$> parseJSON v       [("timestampValue", v)] -> TimestampValue <$> parseTimestamp v       [("arrayValue", v)] -> ArrayValue <$> parseArrayValue v       [("mapValue", v)] -> MapValue <$> parseMapValue v-      _ -> fail "unrecognized FirestoreValue tag"+      tagged -> fail ("unrecognized FirestoreValue tag: " ++ show (map fst tagged)) +-- | Parse a bytes value from its base64 representation.+parseBytesValue :: Aeson.Value -> Parser BS.ByteString+parseBytesValue = Aeson.withText "bytesValue" $ \t ->+  either (fail . ("invalid bytesValue: " ++)) pure (B64.decode (TE.encodeUtf8 t))+ -- | Parse an integer value from a JSON string (Firestore's wire format).--- Uses decimal-only parsing — rejects hex, octal, and other Haskell literals.+-- Uses decimal-only parsing: hex, octal, and other Haskell literals are+-- rejected rather than silently accepted. The digits are read as an+-- unbounded 'Integer' and bounds-checked, because reading 'Int64' directly+-- would silently wrap on overflow. parseIntegerValue :: Aeson.Value -> Parser Int64 parseIntegerValue = Aeson.withText "integerValue" $ \t ->-  case TR.signed TR.decimal t of-    Right (n, remaining) | T.null remaining -> pure n+  case TR.signed TR.decimal t :: Either String (Integer, Text) of+    Right (n, remaining)+      | T.null remaining,+        Just bounded <- toIntegralSized n ->+          pure bounded     _ -> fail ("invalid integerValue: " ++ T.unpack t)  -- | Parse a timestamp from an RFC 3339 string.

@@ -1,10 +1,6 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StrictData #-}- -- | -- Module      : Firebase.Servant -- Description : Servant auth combinator for Firebase--- License     : BSD-3-Clause -- -- One-liner Firebase authentication for Servant servers. Use -- 'firebaseAuthHandler' to create an 'AuthHandler' that verifies@@ -22,33 +18,34 @@ --       ctx     = firebaseAuthHandler cache cfg :. EmptyContext --   runSettings defaultSettings (serveWithContext api ctx server) -- @+--+-- The token is extracted with 'Firebase.Auth.Internal.bearerToken' and+-- failures are rendered with 'Firebase.Auth.authErrorMessage', so this+-- combinator admits exactly the requests "Firebase.Auth.WAI" does and+-- refuses them with the same wording. module Firebase.Servant   ( -- * Auth Handler     firebaseAuthHandler,--    -- * Helpers (pure, testable)-    extractBearerToken,-    authErrorToBody,   ) where -import Control.Monad.Except (throwError) import Control.Monad.IO.Class (liftIO)-import qualified Data.ByteString as BS+import Control.Monad.Trans.Except (throwE) import qualified Data.ByteString.Lazy as LBS-import Firebase.Auth (verifyIdTokenCached)-import Firebase.Auth.Types (AuthError (..), FirebaseConfig, FirebaseUser, KeyCache)+import Firebase.Auth (FirebaseConfig, FirebaseUser, KeyCache, authErrorMessage, verifyIdTokenCached)+import Firebase.Auth.Internal (bearerChallenge, bearerToken)+import Network.HTTP.Types.Header (hWWWAuthenticate) import Network.Wai (Request, requestHeaders)-import Servant.Server (Handler, err401, errBody)+import Servant.Server (Handler (..), err401, errBody, errHeaders) import Servant.Server.Experimental.Auth (AuthHandler, mkAuthHandler)  -- --------------------------------------------------------------------------- -- Constants -- --------------------------------------------------------------------------- --- | The @\"Bearer \"@ prefix length (7 bytes).-bearerPrefixLen :: Int-bearerPrefixLen = 7+-- | Response body when no bearer token was supplied at all.+missingHeaderMessage :: LBS.ByteString+missingHeaderMessage = "Missing or malformed Authorization header"  -- --------------------------------------------------------------------------- -- Auth Handler@@ -60,42 +57,23 @@ -- against Google's public keys using the cached key store, and returns -- the authenticated 'FirebaseUser'. ----- On failure, returns HTTP 401 with a descriptive error body.+-- On failure, returns HTTP 401 with a body that names the failure without+-- disclosing which claim or key was at fault. firebaseAuthHandler ::   KeyCache -> FirebaseConfig -> AuthHandler Request FirebaseUser firebaseAuthHandler cache cfg = mkAuthHandler $ \req ->-  case extractBearerToken req of-    Nothing -> throw401 "Missing or malformed Authorization header"-    Just tok -> do-      result <- liftIO (verifyIdTokenCached cache cfg tok)-      either (throw401 . authErrorToBody) pure result---- | Throw a 401 error in the Servant 'Handler' monad.-throw401 :: LBS.ByteString -> Handler a-throw401 msg = throwError (err401 {errBody = msg})---- ------------------------------------------------------------------------------ Pure Helpers--- ------------------------------------------------------------------------------- | Extract a Bearer token from a WAI 'Request'.------ Looks for the @Authorization@ header and strips the @\"Bearer \"@ prefix.--- Returns 'Nothing' if the header is missing or doesn't start with @\"Bearer \"@.-extractBearerToken :: Request -> Maybe BS.ByteString-extractBearerToken req = do-  hdr <- lookup "Authorization" (requestHeaders req)-  if "Bearer " `BS.isPrefixOf` hdr-    then Just (BS.drop bearerPrefixLen hdr)-    else Nothing+  case bearerToken (requestHeaders req) of+    Nothing -> throw401 missingHeaderMessage+    Just token -> do+      result <- liftIO (verifyIdTokenCached cache cfg token)+      either (throw401 . authErrorMessage) pure result --- | Convert an 'AuthError' to a safe response message.+-- | Throw a 401 error, with the @WWW-Authenticate@ challenge RFC 6750+-- requires, in the Servant t'Handler' monad. ----- Internal details (JOSE errors, claim specifics) are hidden to prevent--- information leakage. Matches the error messages used by 'Firebase.Auth.WAI'.-authErrorToBody :: AuthError -> LBS.ByteString-authErrorToBody (KeyFetchError _) = "Authentication service unavailable"-authErrorToBody InvalidSignature = "Invalid token signature"-authErrorToBody TokenExpired = "Token expired"-authErrorToBody (InvalidClaims _) = "Invalid token claims"-authErrorToBody (MalformedToken _) = "Malformed token"+-- Built on the t'Handler' newtype rather than @MonadError@, which keeps this+-- working across servant versions without depending on @mtl@.+throw401 :: LBS.ByteString -> Handler a+throw401 msg =+  Handler+    (throwE err401 {errBody = msg, errHeaders = [(hWWWAuthenticate, bearerChallenge)]})

@@ -1,661 +1,815 @@-{-# LANGUAGE OverloadedStrings #-}--module Main (main) where--import qualified Data.Aeson as Aeson-import Data.Function ((&))-import Data.List (nub)-import qualified Data.Map.Strict as Map-import Data.Text (Text)-import Data.Time (UTCTime)-import Data.Time.Format (defaultTimeLocale, parseTimeOrError)-import Firebase.Auth-import Firebase.Firestore.Internal-import Firebase.Firestore.Query-import Firebase.Firestore.Types-import Network.HTTP.Client (parseRequest, requestHeaders)-import Network.HTTP.Types.Header (hCacheControl)-import System.Exit (exitFailure)--main :: IO ()-main = do-  putStrLn "firebase-hs tests"-  putStrLn "=================="-  results <--    sequence-      [ -- Auth: Config-        test "defaultFirebaseConfig sets project ID" testDefaultConfigProjectId,-        test "defaultFirebaseConfig sets 300s clock skew" testDefaultConfigClockSkew,-        -- Auth: Cache-Control parsing-        test "parseCacheMaxAge parses valid header" testParseCacheMaxAgeValid,-        test "parseCacheMaxAge handles missing header" testParseCacheMaxAgeMissing,-        test "parseCacheMaxAge handles malformed value" testParseCacheMaxAgeMalformed,-        test "parseCacheMaxAge rejects zero" testParseCacheMaxAgeZero,-        test "parseCacheMaxAge rejects negative" testParseCacheMaxAgeNegative,-        -- Auth: Types-        test "FirebaseUser Eq instance" testFirebaseUserEq,-        test "AuthError constructors" testAuthErrorConstructors,-        -- Firestore: Value JSON roundtrips-        test "FirestoreValue NullValue roundtrip" testNullValueRoundtrip,-        test "FirestoreValue BoolValue roundtrip" testBoolValueRoundtrip,-        test "FirestoreValue IntegerValue roundtrip" testIntegerValueRoundtrip,-        test "FirestoreValue DoubleValue roundtrip" testDoubleValueRoundtrip,-        test "FirestoreValue StringValue roundtrip" testStringValueRoundtrip,-        test "FirestoreValue TimestampValue roundtrip" testTimestampValueRoundtrip,-        test "FirestoreValue ArrayValue roundtrip" testArrayValueRoundtrip,-        test "FirestoreValue MapValue roundtrip" testMapValueRoundtrip,-        -- Firestore: Integer encoding as string-        test "IntegerValue encodes as JSON string" testIntegerEncodesAsString,-        -- Firestore: Document decoding-        test "Document decodes from Firestore JSON" testDocumentDecode,-        test "Document decodes with empty fields" testDocumentDecodeEmptyFields,-        -- Firestore: Error types-        test "FirestoreError constructors" testFirestoreErrorConstructors,-        -- Firestore: URL construction-        test "documentUrl builds correct URL" testDocumentUrl,-        test "collectionUrl builds correct URL" testCollectionUrl,-        test "createDocUrl builds correct URL" testCreateDocUrl,-        test "updateDocUrl with fields builds correct URL" testUpdateDocUrlWithFields,-        test "updateDocUrl without fields builds correct URL" testUpdateDocUrlNoFields,-        test "queryUrl builds correct URL" testQueryUrl,-        test "beginTransactionUrl builds correct URL" testBeginTransactionUrl,-        test "commitUrl builds correct URL" testCommitUrl,-        test "rollbackUrl builds correct URL" testRollbackUrl,-        -- Firestore: Query DSL-        test "query encodes basic collection" testQueryBasic,-        test "query encodes with field filter" testQueryWithFilter,-        test "query encodes with orderBy and limit" testQueryWithOrderByLimit,-        test "query encodes composite AND filter" testQueryCompositeAnd,-        test "query encodes composite OR filter" testQueryCompositeOr,-        test "query encodes with offset" testQueryWithOffset,-        test "query encodes Descending order" testQueryDescending,-        test "all FilterOp values encode correctly" testAllFilterOpEncodings,-        -- Firestore: Transaction options encoding-        test "ReadWrite transaction options encode" testReadWriteEncode,-        test "RetryWith transaction options encode" testRetryWithEncode,-        test "ReadOnly transaction options encode" testReadOnlyEncode,-        -- Firestore: Request helpers-        test "authorizeRequest adds Bearer header" testAuthorizeRequest,-        -- Firestore: Error parsing-        test "parseFirestoreError 404" testParseError404,-        test "parseFirestoreError 403" testParseError403,-        test "parseFirestoreError 409 ABORTED" testParseError409Aborted,-        test "parseFirestoreError unparseable" testParseErrorUnparseable-      ]-  let failures = length (filter not results)-  if failures > 0-    then do-      putStrLn ("\n" ++ show failures ++ " test(s) FAILED")-      exitFailure-    else putStrLn "\nAll tests passed."---- ------------------------------------------------------------------------------ Test runner--- -----------------------------------------------------------------------------test :: String -> IO Bool -> IO Bool-test name action = do-  result <- action-  putStrLn (indicator result ++ " " ++ name)-  pure result-  where-    indicator True = "  PASS"-    indicator False = "  FAIL"--assertEqual :: (Eq a, Show a) => String -> a -> a -> IO Bool-assertEqual label expected actual-  | expected == actual = pure True-  | otherwise = do-      putStrLn ("    " ++ label ++ ": expected " ++ show expected ++ ", got " ++ show actual)-      pure False---- ------------------------------------------------------------------------------ Auth: Config tests--- -----------------------------------------------------------------------------testDefaultConfigProjectId :: IO Bool-testDefaultConfigProjectId =-  assertEqual "fcProjectId" "test-project" (fcProjectId (defaultFirebaseConfig "test-project"))--testDefaultConfigClockSkew :: IO Bool-testDefaultConfigClockSkew =-  assertEqual "fcClockSkew" 300 (fcClockSkew (defaultFirebaseConfig "test-project"))---- ------------------------------------------------------------------------------ Auth: Cache-Control parsing tests--- -----------------------------------------------------------------------------testParseCacheMaxAgeValid :: IO Bool-testParseCacheMaxAgeValid =-  assertEqual-    "max-age=19845"-    (Just 19845)-    (parseCacheMaxAge [(hCacheControl, "public, max-age=19845, must-revalidate, no-transform")])--testParseCacheMaxAgeMissing :: IO Bool-testParseCacheMaxAgeMissing =-  assertEqual-    "no Cache-Control header"-    Nothing-    (parseCacheMaxAge [("content-type", "application/json")])--testParseCacheMaxAgeMalformed :: IO Bool-testParseCacheMaxAgeMalformed =-  assertEqual-    "max-age=abc"-    Nothing-    (parseCacheMaxAge [(hCacheControl, "max-age=abc")])--testParseCacheMaxAgeZero :: IO Bool-testParseCacheMaxAgeZero =-  assertEqual-    "max-age=0"-    Nothing-    (parseCacheMaxAge [(hCacheControl, "max-age=0")])--testParseCacheMaxAgeNegative :: IO Bool-testParseCacheMaxAgeNegative =-  assertEqual-    "max-age=-1"-    Nothing-    (parseCacheMaxAge [(hCacheControl, "max-age=-1")])---- ------------------------------------------------------------------------------ Auth: Type tests--- -----------------------------------------------------------------------------testFirebaseUserEq :: IO Bool-testFirebaseUserEq =-  let u1 = FirebaseUser "uid1" (Just "a@b.com") (Just "Alice")-      u2 = FirebaseUser "uid1" (Just "a@b.com") (Just "Alice")-   in assertEqual "same users" u1 u2--testAuthErrorConstructors :: IO Bool-testAuthErrorConstructors = do-  let errors =-        [ KeyFetchError "network error",-          InvalidSignature,-          TokenExpired,-          InvalidClaims "bad aud",-          MalformedToken "not a jwt"-        ]-  assertEqual "5 constructors" 5 (length errors)---- ------------------------------------------------------------------------------ Firestore: Value JSON roundtrips--- ------------------------------------------------------------------------------- | Roundtrip: encode then decode, verify identity.-roundtrip :: FirestoreValue -> IO Bool-roundtrip val =-  assertEqual (show val) (Just val) (Aeson.decode (Aeson.encode val))--testNullValueRoundtrip :: IO Bool-testNullValueRoundtrip = roundtrip NullValue--testBoolValueRoundtrip :: IO Bool-testBoolValueRoundtrip = do-  r1 <- roundtrip (BoolValue True)-  r2 <- roundtrip (BoolValue False)-  pure (r1 && r2)--testIntegerValueRoundtrip :: IO Bool-testIntegerValueRoundtrip = do-  r1 <- roundtrip (IntegerValue 0)-  r2 <- roundtrip (IntegerValue 42)-  r3 <- roundtrip (IntegerValue (-100))-  pure (r1 && r2 && r3)--testDoubleValueRoundtrip :: IO Bool-testDoubleValueRoundtrip = roundtrip (DoubleValue 3.14)--testStringValueRoundtrip :: IO Bool-testStringValueRoundtrip = roundtrip (StringValue "hello world")--testTimestampValueRoundtrip :: IO Bool-testTimestampValueRoundtrip = roundtrip (TimestampValue (parseUTC "2024-01-15T10:30:00Z"))--testArrayValueRoundtrip :: IO Bool-testArrayValueRoundtrip =-  roundtrip (ArrayValue [StringValue "a", IntegerValue 1, BoolValue True])--testMapValueRoundtrip :: IO Bool-testMapValueRoundtrip =-  roundtrip-    ( MapValue-        ( Map.fromList-            [("name", StringValue "Alice"), ("age", IntegerValue 30)]-        )-    )---- | Verify IntegerValue encodes as a JSON string, not a number.-testIntegerEncodesAsString :: IO Bool-testIntegerEncodesAsString =-  let encoded = Aeson.encode (IntegerValue 42)-      expected = Aeson.encode (Aeson.object ["integerValue" Aeson..= ("42" :: Text)])-   in assertEqual "integer encodes as string" expected encoded---- ------------------------------------------------------------------------------ Firestore: Document decoding--- -----------------------------------------------------------------------------testDocumentDecode :: IO Bool-testDocumentDecode =-  let json =-        "{ \"name\": \"projects/p/databases/(default)/documents/users/alice\"\-        \, \"fields\": { \"name\": { \"stringValue\": \"Alice\" }\-        \              , \"age\": { \"integerValue\": \"30\" } }\-        \, \"createTime\": \"2024-01-15T10:30:00Z\"\-        \, \"updateTime\": \"2024-06-20T14:45:00Z\" }"-      expected =-        Document-          { docName = "projects/p/databases/(default)/documents/users/alice",-            docFields =-              Map.fromList-                [ ("name", StringValue "Alice"),-                  ("age", IntegerValue 30)-                ],-            docCreateTime = Just (parseUTC "2024-01-15T10:30:00Z"),-            docUpdateTime = Just (parseUTC "2024-06-20T14:45:00Z")-          }-   in assertEqual "full document" (Just expected) (Aeson.decode json)--testDocumentDecodeEmptyFields :: IO Bool-testDocumentDecodeEmptyFields =-  let json = "{ \"name\": \"projects/p/databases/(default)/documents/col/doc\" }"-      expected =-        Document-          { docName = "projects/p/databases/(default)/documents/col/doc",-            docFields = Map.empty,-            docCreateTime = Nothing,-            docUpdateTime = Nothing-          }-   in assertEqual "empty fields" (Just expected) (Aeson.decode json)---- ------------------------------------------------------------------------------ Firestore: Error types--- -----------------------------------------------------------------------------testFirestoreErrorConstructors :: IO Bool-testFirestoreErrorConstructors = do-  let errors =-        [ DocumentNotFound,-          PermissionDenied "no access",-          NetworkError "timeout",-          InvalidResponse "bad json",-          FirestoreApiError 500 "INTERNAL" "oops",-          TransactionAborted "contention"-        ]-  assertEqual "6 constructors" 6 (length errors)---- ------------------------------------------------------------------------------ Firestore: URL construction--- -----------------------------------------------------------------------------testDocumentUrl :: IO Bool-testDocumentUrl =-  assertEqual-    "documentUrl"-    "https://firestore.googleapis.com/v1/projects/myproj/databases/(default)/documents/users/alice"-    (documentUrl (ProjectId "myproj") (DocumentPath (CollectionPath "users") (DocumentId "alice")))--testCollectionUrl :: IO Bool-testCollectionUrl =-  assertEqual-    "collectionUrl"-    "https://firestore.googleapis.com/v1/projects/myproj/databases/(default)/documents/users"-    (collectionUrl (ProjectId "myproj") (CollectionPath "users"))--testCreateDocUrl :: IO Bool-testCreateDocUrl =-  assertEqual-    "createDocUrl"-    "https://firestore.googleapis.com/v1/projects/myproj/databases/(default)/documents/users?documentId=alice"-    (createDocUrl (ProjectId "myproj") (CollectionPath "users") (DocumentId "alice"))--testUpdateDocUrlWithFields :: IO Bool-testUpdateDocUrlWithFields =-  assertEqual-    "updateDocUrl with fields"-    "https://firestore.googleapis.com/v1/projects/myproj/databases/(default)/documents/users/alice?updateMask.fieldPaths=name&updateMask.fieldPaths=age"-    (updateDocUrl (ProjectId "myproj") (DocumentPath (CollectionPath "users") (DocumentId "alice")) ["name", "age"])--testUpdateDocUrlNoFields :: IO Bool-testUpdateDocUrlNoFields =-  assertEqual-    "updateDocUrl no fields"-    "https://firestore.googleapis.com/v1/projects/myproj/databases/(default)/documents/users/alice"-    (updateDocUrl (ProjectId "myproj") (DocumentPath (CollectionPath "users") (DocumentId "alice")) [])--testQueryUrl :: IO Bool-testQueryUrl =-  assertEqual-    "queryUrl"-    "https://firestore.googleapis.com/v1/projects/myproj/databases/(default)/documents:runQuery"-    (queryUrl (ProjectId "myproj"))--testBeginTransactionUrl :: IO Bool-testBeginTransactionUrl =-  assertEqual-    "beginTransactionUrl"-    "https://firestore.googleapis.com/v1/projects/myproj/databases/(default)/documents:beginTransaction"-    (beginTransactionUrl (ProjectId "myproj"))--testCommitUrl :: IO Bool-testCommitUrl =-  assertEqual-    "commitUrl"-    "https://firestore.googleapis.com/v1/projects/myproj/databases/(default)/documents:commit"-    (commitUrl (ProjectId "myproj"))--testRollbackUrl :: IO Bool-testRollbackUrl =-  assertEqual-    "rollbackUrl"-    "https://firestore.googleapis.com/v1/projects/myproj/databases/(default)/documents:rollback"-    (rollbackUrl (ProjectId "myproj"))---- ------------------------------------------------------------------------------ Firestore: Query DSL--- -----------------------------------------------------------------------------testQueryBasic :: IO Bool-testQueryBasic =-  let q = encodeQuery (query (CollectionPath "users"))-      expected =-        Aeson.object-          [ "structuredQuery"-              Aeson..= Aeson.object-                ["from" Aeson..= [Aeson.object ["collectionId" Aeson..= ("users" :: Text)]]]-          ]-   in assertEqual "basic query" expected q--testQueryWithFilter :: IO Bool-testQueryWithFilter =-  let q =-        encodeQuery $-          query (CollectionPath "users")-            & where_ (fieldFilter "age" OpGreaterThan (IntegerValue 18))-      expected =-        Aeson.object-          [ "structuredQuery"-              Aeson..= Aeson.object-                [ "from" Aeson..= [Aeson.object ["collectionId" Aeson..= ("users" :: Text)]],-                  "where"-                    Aeson..= Aeson.object-                      [ "fieldFilter"-                          Aeson..= Aeson.object-                            [ "field" Aeson..= Aeson.object ["fieldPath" Aeson..= ("age" :: Text)],-                              "op" Aeson..= ("GREATER_THAN" :: Text),-                              "value" Aeson..= Aeson.object ["integerValue" Aeson..= ("18" :: Text)]-                            ]-                      ]-                ]-          ]-   in assertEqual "query with field filter" expected q--testQueryWithOrderByLimit :: IO Bool-testQueryWithOrderByLimit =-  let q =-        encodeQuery $-          query (CollectionPath "users")-            & orderBy "name" Ascending-            & limit 25-      expected =-        Aeson.object-          [ "structuredQuery"-              Aeson..= Aeson.object-                [ "from" Aeson..= [Aeson.object ["collectionId" Aeson..= ("users" :: Text)]],-                  "orderBy"-                    Aeson..= [ Aeson.object-                                 [ "field" Aeson..= Aeson.object ["fieldPath" Aeson..= ("name" :: Text)],-                                   "direction" Aeson..= ("ASCENDING" :: Text)-                                 ]-                             ],-                  "limit" Aeson..= (25 :: Int)-                ]-          ]-   in assertEqual "query with orderBy and limit" expected q--testQueryCompositeAnd :: IO Bool-testQueryCompositeAnd =-  let q =-        encodeQuery $-          query (CollectionPath "users")-            & where_-              ( compositeAnd-                  [ fieldFilter "age" OpGreaterThan (IntegerValue 18),-                    fieldFilter "active" OpEqual (BoolValue True)-                  ]-              )-      expected =-        Aeson.object-          [ "structuredQuery"-              Aeson..= Aeson.object-                [ "from" Aeson..= [Aeson.object ["collectionId" Aeson..= ("users" :: Text)]],-                  "where"-                    Aeson..= Aeson.object-                      [ "compositeFilter"-                          Aeson..= Aeson.object-                            [ "op" Aeson..= ("AND" :: Text),-                              "filters"-                                Aeson..= [ Aeson.object-                                             [ "fieldFilter"-                                                 Aeson..= Aeson.object-                                                   [ "field" Aeson..= Aeson.object ["fieldPath" Aeson..= ("age" :: Text)],-                                                     "op" Aeson..= ("GREATER_THAN" :: Text),-                                                     "value" Aeson..= Aeson.object ["integerValue" Aeson..= ("18" :: Text)]-                                                   ]-                                             ],-                                           Aeson.object-                                             [ "fieldFilter"-                                                 Aeson..= Aeson.object-                                                   [ "field" Aeson..= Aeson.object ["fieldPath" Aeson..= ("active" :: Text)],-                                                     "op" Aeson..= ("EQUAL" :: Text),-                                                     "value" Aeson..= Aeson.object ["booleanValue" Aeson..= True]-                                                   ]-                                             ]-                                         ]-                            ]-                      ]-                ]-          ]-   in assertEqual "query with composite AND filter" expected q--testQueryCompositeOr :: IO Bool-testQueryCompositeOr =-  let q =-        encodeQuery $-          query (CollectionPath "users")-            & where_-              ( compositeOr-                  [ fieldFilter "role" OpEqual (StringValue "admin"),-                    fieldFilter "role" OpEqual (StringValue "moderator")-                  ]-              )-      expected =-        Aeson.object-          [ "structuredQuery"-              Aeson..= Aeson.object-                [ "from" Aeson..= [Aeson.object ["collectionId" Aeson..= ("users" :: Text)]],-                  "where"-                    Aeson..= Aeson.object-                      [ "compositeFilter"-                          Aeson..= Aeson.object-                            [ "op" Aeson..= ("OR" :: Text),-                              "filters"-                                Aeson..= [ Aeson.object-                                             [ "fieldFilter"-                                                 Aeson..= Aeson.object-                                                   [ "field" Aeson..= Aeson.object ["fieldPath" Aeson..= ("role" :: Text)],-                                                     "op" Aeson..= ("EQUAL" :: Text),-                                                     "value" Aeson..= Aeson.object ["stringValue" Aeson..= ("admin" :: Text)]-                                                   ]-                                             ],-                                           Aeson.object-                                             [ "fieldFilter"-                                                 Aeson..= Aeson.object-                                                   [ "field" Aeson..= Aeson.object ["fieldPath" Aeson..= ("role" :: Text)],-                                                     "op" Aeson..= ("EQUAL" :: Text),-                                                     "value" Aeson..= Aeson.object ["stringValue" Aeson..= ("moderator" :: Text)]-                                                   ]-                                             ]-                                         ]-                            ]-                      ]-                ]-          ]-   in assertEqual "query with composite OR filter" expected q--testQueryWithOffset :: IO Bool-testQueryWithOffset =-  let q =-        encodeQuery $-          query (CollectionPath "items")-            & offset 50-            & limit 25-      expected =-        Aeson.object-          [ "structuredQuery"-              Aeson..= Aeson.object-                [ "from" Aeson..= [Aeson.object ["collectionId" Aeson..= ("items" :: Text)]],-                  "limit" Aeson..= (25 :: Int),-                  "offset" Aeson..= (50 :: Int)-                ]-          ]-   in assertEqual "query with offset" expected q--testQueryDescending :: IO Bool-testQueryDescending =-  let q =-        encodeQuery $-          query (CollectionPath "posts")-            & orderBy "createdAt" Descending-      expected =-        Aeson.object-          [ "structuredQuery"-              Aeson..= Aeson.object-                [ "from" Aeson..= [Aeson.object ["collectionId" Aeson..= ("posts" :: Text)]],-                  "orderBy"-                    Aeson..= [ Aeson.object-                                 [ "field" Aeson..= Aeson.object ["fieldPath" Aeson..= ("createdAt" :: Text)],-                                   "direction" Aeson..= ("DESCENDING" :: Text)-                                 ]-                             ]-                ]-          ]-   in assertEqual "query with Descending order" expected q--testAllFilterOpEncodings :: IO Bool-testAllFilterOpEncodings =-  let encodeOp op =-        let q =-              encodeQuery $-                query (CollectionPath "c")-                  & where_ (fieldFilter "f" op (StringValue "v"))-         in Aeson.encode q-      -- Each operator must produce a distinct, non-empty encoding-      allEncodings = map encodeOp allOps-      allOps =-        [ OpEqual,-          OpNotEqual,-          OpLessThan,-          OpLessThanOrEqual,-          OpGreaterThan,-          OpGreaterThanOrEqual,-          OpArrayContains,-          OpIn,-          OpArrayContainsAny,-          OpNotIn-        ]-      allDistinct = length allEncodings == length (nub allEncodings)-   in do-        r1 <- assertEqual "10 ops" 10 (length allOps)-        r2 <- assertEqual "all distinct" True allDistinct-        pure (r1 && r2)---- ------------------------------------------------------------------------------ Firestore: Request helpers--- -----------------------------------------------------------------------------testAuthorizeRequest :: IO Bool-testAuthorizeRequest = do-  baseReq <- parseRequest "https://example.com"-  let tok = AccessToken "test-token-123"-      authorized = authorizeRequest tok baseReq-      authHeader = lookup "Authorization" (requestHeaders authorized)-  assertEqual "Authorization header" (Just "Bearer test-token-123") authHeader---- ------------------------------------------------------------------------------ Firestore: Transaction options encoding--- -----------------------------------------------------------------------------testReadWriteEncode :: IO Bool-testReadWriteEncode =-  let encoded = encodeTransactionOptions ReadWrite-      expected =-        Aeson.object-          [ "options"-              Aeson..= Aeson.object-                ["readWrite" Aeson..= Aeson.object []]-          ]-   in assertEqual "ReadWrite" expected encoded--testRetryWithEncode :: IO Bool-testRetryWithEncode =-  let encoded = encodeTransactionOptions (RetryWith (TransactionId "abc123"))-      expected =-        Aeson.object-          [ "options"-              Aeson..= Aeson.object-                [ "readWrite"-                    Aeson..= Aeson.object-                      ["retryTransaction" Aeson..= ("abc123" :: Text)]-                ]-          ]-   in assertEqual "RetryWith" expected encoded--testReadOnlyEncode :: IO Bool-testReadOnlyEncode =-  let encoded = encodeTransactionOptions ReadOnly-      expected =-        Aeson.object-          [ "options"-              Aeson..= Aeson.object-                ["readOnly" Aeson..= Aeson.object []]-          ]-   in assertEqual "ReadOnly" expected encoded---- ------------------------------------------------------------------------------ Firestore: Error parsing--- -----------------------------------------------------------------------------testParseError404 :: IO Bool-testParseError404 =-  let body = "{\"error\":{\"code\":404,\"message\":\"not found\",\"status\":\"NOT_FOUND\"}}"-   in assertEqual "404 -> DocumentNotFound" DocumentNotFound (parseFirestoreError 404 body)--testParseError403 :: IO Bool-testParseError403 =-  let body = "{\"error\":{\"code\":403,\"message\":\"denied\",\"status\":\"PERMISSION_DENIED\"}}"-   in assertEqual "403 -> PermissionDenied" (PermissionDenied "denied") (parseFirestoreError 403 body)--testParseError409Aborted :: IO Bool-testParseError409Aborted =-  let body = "{\"error\":{\"code\":409,\"message\":\"contention\",\"status\":\"ABORTED\"}}"-   in assertEqual "409 ABORTED -> TransactionAborted" (TransactionAborted "contention") (parseFirestoreError 409 body)--testParseErrorUnparseable :: IO Bool-testParseErrorUnparseable =-  assertEqual-    "unparseable -> NetworkError"-    (NetworkError "HTTP 500")-    (parseFirestoreError 500 "not json at all")---- ------------------------------------------------------------------------------ Helpers--- ------------------------------------------------------------------------------- | Parse a UTC time string for test data.-parseUTC :: String -> UTCTime-parseUTC = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ"+module Main (main) where++import qualified Data.Aeson as Aeson+import qualified Data.ByteString as BS+import Data.Function ((&))+import Data.List (nub)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time (UTCTime)+import Data.Time.Format (defaultTimeLocale, parseTimeOrError)+import Firebase.Auth+import Firebase.Auth.Internal (bearerToken, padBase64Url, stripBearerPrefix)+import Firebase.Firestore (mkDeleteWrite, mkUpdateWrite)+import Firebase.Firestore.Internal+import Firebase.Firestore.Query+import Firebase.Firestore.Types+import Network.HTTP.Client (Request, parseRequest, requestHeaders)+import Network.HTTP.Types.Header (hAuthorization, hCacheControl)+import System.Exit (exitFailure)++-- ---------------------------------------------------------------------------+-- Test framework+--+-- Every check below is a pure value. IO appears once, in 'main', to report+-- the results and set the exit code.+-- ---------------------------------------------------------------------------++-- | A named check that either holds or explains why it does not.+data Test = Test !String !(Either String ())++-- | Assert that a computed value matches an expected one.+--+-- Fixed at comparison precedence, so the expected side can be built up with+-- '<>' and sequenced with '>>' without parentheses.+infix 4 `shouldBe`++shouldBe :: (Eq a, Show a) => a -> a -> Either String ()+shouldBe actual expected+  | actual == expected = Right ()+  | otherwise = Left ("expected " <> show expected <> ", got " <> show actual)++-- | Assert that a condition holds, describing it if it does not.+shouldHold :: String -> Bool -> Either String ()+shouldHold _ True = Right ()+shouldHold description False = Left ("expected " <> description)++-- | Run every check in order, reporting each and failing the suite if any did.+main :: IO ()+main = do+  putStrLn "firebase-hs tests"+  putStrLn "=================="+  mapM_ (putStrLn . report) tests+  case filter failed tests of+    [] -> putStrLn ("\nAll " <> show (length tests) <> " tests passed.")+    failures -> do+      putStrLn ("\n" <> show (length failures) <> " test(s) FAILED")+      exitFailure+  where+    failed (Test _ result) = either (const True) (const False) result++    report (Test name (Right ())) = "  PASS " <> name+    report (Test name (Left reason)) = "  FAIL " <> name <> "\n    " <> reason++-- ---------------------------------------------------------------------------+-- Test registry+-- ---------------------------------------------------------------------------++tests :: [Test]+tests =+  concat+    [ authConfigTests,+      cacheControlTests,+      authErrorTests,+      claimTests,+      bearerTokenTests,+      base64Tests,+      valueRoundtripTests,+      documentTests,+      urlTests,+      urlEncodingTests,+      resourceNameTests,+      writeTests,+      queryTests,+      transactionOptionTests,+      requestTests,+      errorParsingTests,+      decoderTests+    ]++-- ---------------------------------------------------------------------------+-- Auth: Config+-- ---------------------------------------------------------------------------++authConfigTests :: [Test]+authConfigTests =+  [ Test "defaultFirebaseConfig sets project ID" $+      fcProjectId (defaultFirebaseConfig "test-project") `shouldBe` "test-project",+    Test "defaultFirebaseConfig sets 300s clock skew" $+      fcClockSkew (defaultFirebaseConfig "test-project") `shouldBe` 300+  ]++-- ---------------------------------------------------------------------------+-- Auth: Cache-Control parsing+-- ---------------------------------------------------------------------------++cacheControlTests :: [Test]+cacheControlTests =+  [ Test "parseCacheMaxAge parses valid header" $+      parseCacheMaxAge [(hCacheControl, "public, max-age=19845, must-revalidate, no-transform")]+        `shouldBe` Just 19845,+    Test "parseCacheMaxAge handles missing header" $+      parseCacheMaxAge [("content-type", "application/json")] `shouldBe` Nothing,+    Test "parseCacheMaxAge handles malformed value" $+      parseCacheMaxAge [(hCacheControl, "max-age=abc")] `shouldBe` Nothing,+    Test "parseCacheMaxAge rejects zero" $+      parseCacheMaxAge [(hCacheControl, "max-age=0")] `shouldBe` Nothing,+    Test "parseCacheMaxAge rejects negative" $+      parseCacheMaxAge [(hCacheControl, "max-age=-1")] `shouldBe` Nothing,+    Test "parseCacheMaxAge ignores unrelated directives" $+      parseCacheMaxAge [(hCacheControl, "no-store, must-revalidate")] `shouldBe` Nothing,+    Test "parseCacheMaxAge reads a directive in final position" $+      parseCacheMaxAge [(hCacheControl, "public, max-age=60")] `shouldBe` Just 60+  ]++-- ---------------------------------------------------------------------------+-- Auth: Errors+-- ---------------------------------------------------------------------------++-- | A representative verified user, for checks that vary one field.+testUser :: FirebaseUser+testUser =+  FirebaseUser+    { fuUid = "uid1",+      fuEmail = Just "a@b.com",+      fuEmailVerified = True,+      fuName = Just "Alice",+      fuPicture = Nothing,+      fuAuthTime = Nothing,+      fuSignInProvider = Just "password",+      fuCustomClaims = Map.fromList [("admin", Aeson.Bool True), ("tier", Aeson.String "gold")]+    }++authErrorTests :: [Test]+authErrorTests =+  [ Test "FirebaseUser Eq instance" $+      testUser `shouldBe` testUser,+    Test "FirebaseUser Eq distinguishes custom claims" $+      shouldHold "differing claims compare unequal" $+        testUser /= testUser {fuCustomClaims = Map.empty},+    Test "AuthError constructors" $+      length+        [ KeyFetchError "network error",+          InvalidSignature,+          TokenExpired,+          InvalidClaims "bad aud",+          MalformedToken "not a jwt"+        ]+        `shouldBe` 5,+    Test "authErrorMessage withholds the key-fetch detail" $+      authErrorMessage (KeyFetchError "connect to 10.0.0.1 refused")+        `shouldBe` "Authentication service unavailable",+    Test "authErrorMessage withholds which claim failed" $+      authErrorMessage (InvalidClaims "audience mismatch") `shouldBe` "Invalid token claims",+    Test "authErrorMessage withholds the parse detail" $+      authErrorMessage (MalformedToken "header: invalid base64") `shouldBe` "Malformed token",+    Test "authErrorMessage distinguishes signature from expiry" $+      shouldHold "different messages" $+        authErrorMessage InvalidSignature /= authErrorMessage TokenExpired+  ]++-- ---------------------------------------------------------------------------+-- Auth: Custom claims+-- ---------------------------------------------------------------------------++claimTests :: [Test]+claimTests =+  [ Test "lookupClaim finds a custom claim" $+      lookupClaim "tier" testUser `shouldBe` Just (Aeson.String "gold"),+    Test "lookupClaim misses an absent claim" $+      lookupClaim "nope" testUser `shouldBe` Nothing,+    Test "lookupClaim does not expose reserved claims" $+      lookupClaim "email" testUser `shouldBe` Nothing,+    Test "hasClaim accepts a true claim" $+      shouldHold "admin holds" (hasClaim "admin" testUser),+    Test "hasClaim rejects an absent claim" $+      shouldHold "absent claim is false" (not (hasClaim "superuser" testUser)),+    Test "hasClaim rejects a non-boolean claim" $+      shouldHold "gold is not true" (not (hasClaim "tier" testUser)),+    Test "hasClaim rejects a false claim" $+      shouldHold "explicit false" $+        not (hasClaim "admin" testUser {fuCustomClaims = Map.fromList [("admin", Aeson.Bool False)]})+  ]++-- ---------------------------------------------------------------------------+-- Auth: Bearer token extraction+-- ---------------------------------------------------------------------------++bearerTokenTests :: [Test]+bearerTokenTests =+  [ Test "stripBearerPrefix accepts the canonical scheme" $+      stripBearerPrefix "Bearer abc.def.ghi" `shouldBe` Just "abc.def.ghi",+    Test "stripBearerPrefix accepts a lowercase scheme" $+      stripBearerPrefix "bearer abc.def.ghi" `shouldBe` Just "abc.def.ghi",+    Test "stripBearerPrefix accepts an uppercase scheme" $+      stripBearerPrefix "BEARER abc.def.ghi" `shouldBe` Just "abc.def.ghi",+    Test "stripBearerPrefix rejects another scheme" $+      stripBearerPrefix "Basic dXNlcjpwYXNz" `shouldBe` Nothing,+    Test "stripBearerPrefix rejects a bare token" $+      stripBearerPrefix "abc.def.ghi" `shouldBe` Nothing,+    Test "stripBearerPrefix rejects an empty header" $+      stripBearerPrefix "" `shouldBe` Nothing,+    Test "stripBearerPrefix keeps an empty credential" $+      stripBearerPrefix "Bearer " `shouldBe` Just "",+    Test "bearerToken reads the Authorization header" $+      bearerToken [(hAuthorization, "Bearer token123")] `shouldBe` Just "token123",+    Test "bearerToken matches the header name case-insensitively" $+      bearerToken [("authorization", "Bearer token123")] `shouldBe` Just "token123",+    Test "bearerToken ignores other headers" $+      bearerToken [("content-type", "application/json")] `shouldBe` Nothing,+    Test "bearerToken rejects a malformed scheme" $+      bearerToken [(hAuthorization, "Bearer2 token123")] `shouldBe` Nothing+  ]++-- ---------------------------------------------------------------------------+-- Auth: base64url padding+-- ---------------------------------------------------------------------------++base64Tests :: [Test]+base64Tests =+  [ Test "padBase64Url leaves a whole group alone" $+      padBase64Url "YWJjZA==" `shouldBe` "YWJjZA==",+    Test "padBase64Url pads a two-character remainder" $+      padBase64Url "YWJjZA" `shouldBe` "YWJjZA==",+    Test "padBase64Url pads a three-character remainder" $+      padBase64Url "YWJjZGU" `shouldBe` "YWJjZGU=",+    Test "padBase64Url leaves empty input alone" $+      padBase64Url "" `shouldBe` "",+    Test "padBase64Url always yields a whole number of groups" $+      shouldHold "every padded length divisible by 4" $+        all (\s -> BS.length (padBase64Url s) `rem` 4 == 0) ["", "a", "ab", "abc", "abcd", "abcde"]+  ]++-- ---------------------------------------------------------------------------+-- Firestore: Value JSON roundtrips+-- ---------------------------------------------------------------------------++valueRoundtripTests :: [Test]+valueRoundtripTests =+  [ Test "FirestoreValue NullValue roundtrip" (roundtrip NullValue),+    Test "FirestoreValue BoolValue roundtrip" (roundtrip (BoolValue True) >> roundtrip (BoolValue False)),+    Test "FirestoreValue IntegerValue roundtrip" $+      roundtrip (IntegerValue 0) >> roundtrip (IntegerValue 42) >> roundtrip (IntegerValue (-100)),+    Test "FirestoreValue DoubleValue roundtrip" (roundtrip (DoubleValue 3.14)),+    Test "FirestoreValue StringValue roundtrip" (roundtrip (StringValue "hello world")),+    Test "FirestoreValue TimestampValue roundtrip" $+      roundtrip (TimestampValue (parseUTC "2024-01-15T10:30:00Z")),+    Test "FirestoreValue ArrayValue roundtrip" $+      roundtrip (ArrayValue [StringValue "a", IntegerValue 1, BoolValue True]),+    Test "FirestoreValue MapValue roundtrip" $+      roundtrip (MapValue (Map.fromList [("name", StringValue "Alice"), ("age", IntegerValue 30)])),+    Test "FirestoreValue BytesValue roundtrip" $+      roundtrip (BytesValue "\0\1\2binary\255"),+    Test "FirestoreValue ReferenceValue roundtrip" $+      roundtrip (ReferenceValue "projects/p/databases/(default)/documents/users/alice"),+    Test "FirestoreValue GeoPointValue roundtrip" $+      roundtrip (GeoPointValue (GeoPoint 51.5 (-0.12))),+    Test "BytesValue encodes as base64" $+      Aeson.encode (BytesValue "hello")+        `shouldBe` Aeson.encode (Aeson.object ["bytesValue" Aeson..= ("aGVsbG8=" :: Text)]),+    Test "BytesValue rejects invalid base64" $+      (Aeson.decode "{\"bytesValue\":\"not!base64\"}" :: Maybe FirestoreValue) `shouldBe` Nothing,+    Test "GeoPoint defaults an omitted coordinate to zero" $+      (Aeson.decode "{\"geoPointValue\":{\"latitude\":10.5}}" :: Maybe FirestoreValue)+        `shouldBe` Just (GeoPointValue (GeoPoint 10.5 0)),+    Test "a document carrying a geo point decodes" $+      fmap+        docFields+        ( Aeson.decode+            "{\"name\":\"projects/p/databases/(default)/documents/c/d\"\+            \,\"fields\":{\"where\":{\"geoPointValue\":{\"latitude\":1,\"longitude\":2}}}}"+        )+        `shouldBe` Just (Map.fromList [("where", GeoPointValue (GeoPoint 1 2))]),+    Test "an unknown value tag is named in the error" $+      (Aeson.decode "{\"nonsenseValue\":1}" :: Maybe FirestoreValue) `shouldBe` Nothing,+    Test "IntegerValue encodes as a JSON string" $+      Aeson.encode (IntegerValue 42)+        `shouldBe` Aeson.encode (Aeson.object ["integerValue" Aeson..= ("42" :: Text)]),+    Test "IntegerValue rejects a hexadecimal literal" $+      (Aeson.decode "{\"integerValue\":\"0x2A\"}" :: Maybe FirestoreValue) `shouldBe` Nothing,+    Test "IntegerValue rejects trailing characters" $+      (Aeson.decode "{\"integerValue\":\"42abc\"}" :: Maybe FirestoreValue) `shouldBe` Nothing,+    Test "DoubleValue roundtrips positive infinity" $+      roundtrip (DoubleValue (1 / 0)),+    Test "DoubleValue encodes NaN as the proto3 string" $+      Aeson.encode (DoubleValue (0 / 0))+        `shouldBe` Aeson.encode (Aeson.object ["doubleValue" Aeson..= ("NaN" :: Text)]),+    Test "DoubleValue encodes negative infinity as the proto3 string" $+      Aeson.encode (DoubleValue (negate (1 / 0)))+        `shouldBe` Aeson.encode (Aeson.object ["doubleValue" Aeson..= ("-Infinity" :: Text)]),+    Test "DoubleValue decodes the proto3 NaN string" $+      case Aeson.decode "{\"doubleValue\":\"NaN\"}" of+        Just (DoubleValue d) -> shouldHold "NaN decodes to NaN" (isNaN d)+        other -> Left ("expected a DoubleValue, got " <> show other),+    Test "DoubleValue rejects an unknown string spelling" $+      (Aeson.decode "{\"doubleValue\":\"fast\"}" :: Maybe FirestoreValue) `shouldBe` Nothing,+    Test "DoubleValue rejects JSON null" $+      (Aeson.decode "{\"doubleValue\":null}" :: Maybe FirestoreValue) `shouldBe` Nothing,+    Test "IntegerValue parses the Int64 bounds" $+      Aeson.decode "{\"integerValue\":\"9223372036854775807\"}"+        `shouldBe` Just (IntegerValue maxBound)+        >> Aeson.decode "{\"integerValue\":\"-9223372036854775808\"}"+          `shouldBe` Just (IntegerValue minBound),+    Test "IntegerValue rejects a value past the Int64 bounds" $+      (Aeson.decode "{\"integerValue\":\"9223372036854775808\"}" :: Maybe FirestoreValue)+        `shouldBe` Nothing+        >> (Aeson.decode "{\"integerValue\":\"-9223372036854775809\"}" :: Maybe FirestoreValue)+          `shouldBe` Nothing,+    Test "TimestampValue caps encoded precision at nine fractional digits" $+      Aeson.encode (TimestampValue (parseUTCSubsecond "2024-01-15T10:30:00.123456789012Z"))+        `shouldBe` Aeson.encode+          (Aeson.object ["timestampValue" Aeson..= ("2024-01-15T10:30:00.123456789Z" :: Text)])+  ]++-- | Encode then decode, and confirm nothing was lost.+roundtrip :: FirestoreValue -> Either String ()+roundtrip val = Aeson.decode (Aeson.encode val) `shouldBe` Just val++-- ---------------------------------------------------------------------------+-- Firestore: Document decoding+-- ---------------------------------------------------------------------------++documentTests :: [Test]+documentTests =+  [ Test "Document decodes from Firestore JSON" $+      Aeson.decode+        "{ \"name\": \"projects/p/databases/(default)/documents/users/alice\"\+        \, \"fields\": { \"name\": { \"stringValue\": \"Alice\" }\+        \              , \"age\": { \"integerValue\": \"30\" } }\+        \, \"createTime\": \"2024-01-15T10:30:00Z\"\+        \, \"updateTime\": \"2024-06-20T14:45:00Z\" }"+        `shouldBe` Just+          Document+            { docName = "projects/p/databases/(default)/documents/users/alice",+              docFields = Map.fromList [("name", StringValue "Alice"), ("age", IntegerValue 30)],+              docCreateTime = Just (parseUTC "2024-01-15T10:30:00Z"),+              docUpdateTime = Just (parseUTC "2024-06-20T14:45:00Z")+            },+    Test "Document decodes with empty fields" $+      Aeson.decode "{ \"name\": \"projects/p/databases/(default)/documents/col/doc\" }"+        `shouldBe` Just+          Document+            { docName = "projects/p/databases/(default)/documents/col/doc",+              docFields = Map.empty,+              docCreateTime = Nothing,+              docUpdateTime = Nothing+            },+    Test "FirestoreError constructors" $+      length+        [ DocumentNotFound,+          PermissionDenied "no access",+          NetworkError "timeout",+          InvalidResponse "bad json",+          FirestoreApiError 500 "INTERNAL" "oops",+          TransactionAborted "contention"+        ]+        `shouldBe` 6+  ]++-- ---------------------------------------------------------------------------+-- Firestore: URL construction+-- ---------------------------------------------------------------------------++-- | Project used by the URL tests.+testProject :: ProjectId+testProject = ProjectId "myproj"++-- | Prefix every document URL under 'testProject' shares.+testDatabaseUrl :: String+testDatabaseUrl = "https://firestore.googleapis.com/v1/projects/myproj/databases/(default)/documents"++alicePath :: DocumentPath+alicePath = DocumentPath (CollectionPath "users") (DocumentId "alice")++urlTests :: [Test]+urlTests =+  [ Test "databaseUrl builds correct URL" $+      databaseUrl testProject `shouldBe` testDatabaseUrl,+    Test "documentUrl builds correct URL" $+      documentUrl testProject alicePath `shouldBe` testDatabaseUrl <> "/users/alice",+    Test "collectionUrl builds correct URL" $+      collectionUrl testProject (CollectionPath "users") `shouldBe` testDatabaseUrl <> "/users",+    Test "createDocUrl builds correct URL" $+      createDocUrl testProject (CollectionPath "users") (DocumentId "alice")+        `shouldBe` testDatabaseUrl+        <> "/users?documentId=alice",+    Test "updateDocUrl with fields builds correct URL" $+      updateDocUrl testProject alicePath ["name", "age"]+        `shouldBe` testDatabaseUrl+        <> "/users/alice?updateMask.fieldPaths=name&updateMask.fieldPaths=age",+    Test "updateDocUrl without fields builds correct URL" $+      updateDocUrl testProject alicePath [] `shouldBe` testDatabaseUrl <> "/users/alice",+    Test "runQueryUrl posts to the database root for a top-level collection" $+      runQueryUrl testProject (CollectionPath "users") `shouldBe` testDatabaseUrl <> ":runQuery",+    Test "runQueryUrl posts to the parent document for a subcollection" $+      runQueryUrl testProject (CollectionPath "users/abc/posts")+        `shouldBe` testDatabaseUrl+        <> "/users/abc:runQuery",+    Test "beginTransactionUrl builds correct URL" $+      beginTransactionUrl testProject `shouldBe` testDatabaseUrl <> ":beginTransaction",+    Test "commitUrl builds correct URL" $+      commitUrl testProject `shouldBe` testDatabaseUrl <> ":commit",+    Test "rollbackUrl builds correct URL" $+      rollbackUrl testProject `shouldBe` testDatabaseUrl <> ":rollback",+    Test "collectionUrl keeps subcollection separators" $+      collectionUrl testProject (CollectionPath "users/abc/posts")+        `shouldBe` testDatabaseUrl+        <> "/users/abc/posts",+    Test "splitCollectionPath keeps a top-level collection whole" $+      splitCollectionPath (CollectionPath "users") `shouldBe` (Nothing, "users"),+    Test "splitCollectionPath splits a subcollection from its parent" $+      splitCollectionPath (CollectionPath "users/abc/posts") `shouldBe` (Just "users/abc", "posts"),+    Test "splitCollectionPath splits a deep subcollection" $+      splitCollectionPath (CollectionPath "a/b/c/d/e") `shouldBe` (Just "a/b/c/d", "e")+  ]++-- ---------------------------------------------------------------------------+-- Firestore: Percent encoding+--+-- Caller-supplied components reach the URL encoded, so a value carrying a+-- URL delimiter names a document instead of altering the request.+-- ---------------------------------------------------------------------------++urlEncodingTests :: [Test]+urlEncodingTests =+  [ Test "encodePathSegment escapes a path separator" $+      encodePathSegment "a/b" `shouldBe` "a%2Fb",+    Test "encodePathSegment escapes a query introducer" $+      encodePathSegment "a?b" `shouldBe` "a%3Fb",+    Test "encodePathSegment escapes a fragment introducer" $+      encodePathSegment "a#b" `shouldBe` "a%23b",+    Test "encodePathSegment escapes a space" $+      encodePathSegment "a b" `shouldBe` "a%20b",+    Test "encodePathSegment escapes a percent" $+      encodePathSegment "a%b" `shouldBe` "a%25b",+    Test "encodePathSegment encodes non-ASCII as UTF-8" $+      encodePathSegment (T.pack "caf\233") `shouldBe` "caf%C3%A9",+    Test "encodePathSegment leaves unreserved characters alone" $+      encodePathSegment "aZ0.~-_" `shouldBe` "aZ0.~-_",+    Test "encodeQueryValue escapes a parameter separator" $+      encodeQueryValue "a&b" `shouldBe` "a%26b",+    Test "encodeQueryValue escapes an assignment" $+      encodeQueryValue "a=b" `shouldBe` "a%3Db",+    Test "documentUrl escapes a document ID" $+      documentUrl testProject (DocumentPath (CollectionPath "users") (DocumentId "a?b#c"))+        `shouldBe` testDatabaseUrl+        <> "/users/a%3Fb%23c",+    Test "documentUrl escapes a project ID" $+      documentUrl (ProjectId "a b") alicePath+        `shouldBe` "https://firestore.googleapis.com/v1/projects/a%20b/databases/(default)/documents/users/alice",+    Test "createDocUrl escapes a document ID in the query" $+      createDocUrl testProject (CollectionPath "users") (DocumentId "a&b=c")+        `shouldBe` testDatabaseUrl+        <> "/users?documentId=a%26b%3Dc",+    Test "updateDocUrl escapes field paths" $+      updateDocUrl testProject alicePath ["a&b"]+        `shouldBe` testDatabaseUrl+        <> "/users/alice?updateMask.fieldPaths=a%26b",+    Test "collectionUrl escapes within a subcollection segment" $+      collectionUrl testProject (CollectionPath "users/a b/posts")+        `shouldBe` testDatabaseUrl+        <> "/users/a%20b/posts",+    Test "runQueryUrl escapes within the parent path" $+      runQueryUrl testProject (CollectionPath "users/a b/posts")+        `shouldBe` testDatabaseUrl+        <> "/users/a%20b:runQuery",+    Test "documentInTransactionUrl escapes the transaction ID" $+      documentInTransactionUrl testProject (TransactionId "ab+/=") alicePath+        `shouldBe` testDatabaseUrl+        <> "/users/alice?transaction=ab%2B%2F%3D"+  ]++-- ---------------------------------------------------------------------------+-- Firestore: Resource names+-- ---------------------------------------------------------------------------++resourceNameTests :: [Test]+resourceNameTests =+  [ Test "documentResourceName builds the full path" $+      documentResourceName testProject alicePath+        `shouldBe` "projects/myproj/databases/(default)/documents/users/alice",+    Test "documentResourceName carries components verbatim" $+      documentResourceName testProject (DocumentPath (CollectionPath "users") (DocumentId "a b"))+        `shouldBe` "projects/myproj/databases/(default)/documents/users/a b",+    Test "documentResourceName matches a decoded document's name" $+      documentResourceName (ProjectId "p") (DocumentPath (CollectionPath "users") (DocumentId "alice"))+        `shouldBe` "projects/p/databases/(default)/documents/users/alice"+  ]++-- ---------------------------------------------------------------------------+-- Firestore: Transaction writes+-- ---------------------------------------------------------------------------++writeTests :: [Test]+writeTests =+  [ Test "mkUpdateWrite encodes name and fields" $+      Aeson.toJSON (mkUpdateWrite testProject alicePath (Map.fromList [("age", IntegerValue 31)]))+        `shouldBe` Aeson.object+          [ "update"+              Aeson..= Aeson.object+                [ "name" Aeson..= (T.pack (testResourcePrefix <> "/users/alice") :: Text),+                  "fields"+                    Aeson..= Aeson.object+                      ["age" Aeson..= Aeson.object ["integerValue" Aeson..= ("31" :: Text)]]+                ]+          ],+    Test "mkDeleteWrite encodes the document name" $+      Aeson.toJSON (mkDeleteWrite testProject alicePath)+        `shouldBe` Aeson.object+          ["delete" Aeson..= (T.pack (testResourcePrefix <> "/users/alice") :: Text)],+    Test "mkUpdateWrite accepts an empty field map" $+      Aeson.toJSON (mkUpdateWrite testProject alicePath Map.empty)+        `shouldBe` Aeson.object+          [ "update"+              Aeson..= Aeson.object+                [ "name" Aeson..= (T.pack (testResourcePrefix <> "/users/alice") :: Text),+                  "fields" Aeson..= Aeson.object []+                ]+          ]+  ]+  where+    testResourcePrefix = "projects/myproj/databases/(default)/documents"++-- ---------------------------------------------------------------------------+-- Firestore: Query DSL+-- ---------------------------------------------------------------------------++-- | Wrap a structured-query body in the envelope 'encodeQuery' produces.+structuredQuery :: [(Aeson.Key, Aeson.Value)] -> Aeson.Value+structuredQuery body = Aeson.object ["structuredQuery" Aeson..= Aeson.object body]++-- | The @from@ clause naming a single collection.+fromCollection :: Text -> (Aeson.Key, Aeson.Value)+fromCollection name = "from" Aeson..= [Aeson.object ["collectionId" Aeson..= name]]++-- | A @fieldFilter@ as it appears on the wire.+wireFieldFilter :: Text -> Text -> Aeson.Value -> Aeson.Value+wireFieldFilter field op value =+  Aeson.object+    [ "fieldFilter"+        Aeson..= Aeson.object+          [ "field" Aeson..= Aeson.object ["fieldPath" Aeson..= field],+            "op" Aeson..= op,+            "value" Aeson..= value+          ]+    ]++-- | An @integerValue@ as it appears on the wire.+wireInteger :: Text -> Aeson.Value+wireInteger n = Aeson.object ["integerValue" Aeson..= n]++-- | An @orderBy@ entry as it appears on the wire.+wireOrderBy :: Text -> Text -> Aeson.Value+wireOrderBy field direction =+  Aeson.object+    [ "field" Aeson..= Aeson.object ["fieldPath" Aeson..= field],+      "direction" Aeson..= direction+    ]++queryTests :: [Test]+queryTests =+  [ Test "query encodes basic collection" $+      encodeQuery (query (CollectionPath "users")) `shouldBe` structuredQuery [fromCollection "users"],+    Test "query on a subcollection names only its collection ID" $+      encodeQuery (query (CollectionPath "users/abc/posts"))+        `shouldBe` structuredQuery [fromCollection "posts"],+    Test "encodeQueryInTransaction carries the transaction alongside the query" $+      encodeQueryInTransaction (TransactionId "txn123") (query (CollectionPath "users"))+        `shouldBe` Aeson.object+          [ "structuredQuery" Aeson..= Aeson.object [fromCollection "users"],+            "transaction" Aeson..= ("txn123" :: Text)+          ],+    Test "query encodes with field filter" $+      encodeQuery (query (CollectionPath "users") & where_ (fieldFilter "age" OpGreaterThan (IntegerValue 18)))+        `shouldBe` structuredQuery+          [ fromCollection "users",+            "where" Aeson..= wireFieldFilter "age" "GREATER_THAN" (wireInteger "18")+          ],+    Test "query encodes with orderBy and limit" $+      encodeQuery (query (CollectionPath "users") & orderBy "name" Ascending & limit 25)+        `shouldBe` structuredQuery+          [ fromCollection "users",+            "orderBy" Aeson..= [wireOrderBy "name" "ASCENDING"],+            "limit" Aeson..= (25 :: Int)+          ],+    Test "query encodes composite AND filter" $+      encodeQuery+        ( query (CollectionPath "users")+            & where_+              ( compositeAnd+                  [ fieldFilter "age" OpGreaterThan (IntegerValue 18),+                    fieldFilter "active" OpEqual (BoolValue True)+                  ]+              )+        )+        `shouldBe` structuredQuery+          [ fromCollection "users",+            "where"+              Aeson..= Aeson.object+                [ "compositeFilter"+                    Aeson..= Aeson.object+                      [ "op" Aeson..= ("AND" :: Text),+                        "filters"+                          Aeson..= [ wireFieldFilter "age" "GREATER_THAN" (wireInteger "18"),+                                     wireFieldFilter "active" "EQUAL" (Aeson.object ["booleanValue" Aeson..= True])+                                   ]+                      ]+                ]+          ],+    Test "query encodes composite OR filter" $+      encodeQuery+        ( query (CollectionPath "users")+            & where_+              ( compositeOr+                  [ fieldFilter "role" OpEqual (StringValue "admin"),+                    fieldFilter "role" OpEqual (StringValue "moderator")+                  ]+              )+        )+        `shouldBe` structuredQuery+          [ fromCollection "users",+            "where"+              Aeson..= Aeson.object+                [ "compositeFilter"+                    Aeson..= Aeson.object+                      [ "op" Aeson..= ("OR" :: Text),+                        "filters"+                          Aeson..= [ wireFieldFilter "role" "EQUAL" (Aeson.object ["stringValue" Aeson..= ("admin" :: Text)]),+                                     wireFieldFilter "role" "EQUAL" (Aeson.object ["stringValue" Aeson..= ("moderator" :: Text)])+                                   ]+                      ]+                ]+          ],+    Test "query encodes with offset" $+      encodeQuery (query (CollectionPath "items") & offset 50 & limit 25)+        `shouldBe` structuredQuery+          [ fromCollection "items",+            "limit" Aeson..= (25 :: Int),+            "offset" Aeson..= (50 :: Int)+          ],+    Test "query encodes Descending order" $+      encodeQuery (query (CollectionPath "posts") & orderBy "createdAt" Descending)+        `shouldBe` structuredQuery+          [ fromCollection "posts",+            "orderBy" Aeson..= [wireOrderBy "createdAt" "DESCENDING"]+          ],+    Test "orderBy clauses accumulate in order" $+      encodeQuery (query (CollectionPath "posts") & orderBy "a" Ascending & orderBy "b" Descending)+        `shouldBe` structuredQuery+          [ fromCollection "posts",+            "orderBy" Aeson..= [wireOrderBy "a" "ASCENDING", wireOrderBy "b" "DESCENDING"]+          ],+    Test "all FilterOp values encode distinctly" $+      shouldHold "10 distinct encodings" (length encodings == length (nub encodings))+        >> length allOps `shouldBe` 10+  ]+  where+    encodings = map encodeOp allOps+    encodeOp op = Aeson.encode (encodeQuery (query (CollectionPath "c") & where_ (fieldFilter "f" op (StringValue "v"))))+    allOps =+      [ OpEqual,+        OpNotEqual,+        OpLessThan,+        OpLessThanOrEqual,+        OpGreaterThan,+        OpGreaterThanOrEqual,+        OpArrayContains,+        OpIn,+        OpArrayContainsAny,+        OpNotIn+      ]++-- ---------------------------------------------------------------------------+-- Firestore: Transaction options+-- ---------------------------------------------------------------------------++transactionOptionTests :: [Test]+transactionOptionTests =+  [ Test "ReadWrite transaction options encode" $+      encodeTransactionOptions ReadWrite+        `shouldBe` transactionOptions ["readWrite" Aeson..= Aeson.object []],+    Test "RetryWith transaction options encode" $+      encodeTransactionOptions (RetryWith (TransactionId "abc123"))+        `shouldBe` transactionOptions+          ["readWrite" Aeson..= Aeson.object ["retryTransaction" Aeson..= ("abc123" :: Text)]],+    Test "ReadOnly transaction options encode" $+      encodeTransactionOptions ReadOnly+        `shouldBe` transactionOptions ["readOnly" Aeson..= Aeson.object []],+    Test "TransactionId Show does not leak the token" $+      shouldHold "redacted" (show (TransactionId "super-secret") == "TransactionId <redacted>"),+    Test "AccessToken Show does not leak the token" $+      shouldHold "redacted" (show (AccessToken "ya29.super-secret") == "AccessToken <redacted>")+  ]+  where+    transactionOptions body = Aeson.object ["options" Aeson..= Aeson.object body]++-- ---------------------------------------------------------------------------+-- Firestore: Request helpers+-- ---------------------------------------------------------------------------++requestTests :: [Test]+requestTests =+  [ Test "authorizeRequest adds Bearer header" $+      case parseRequest "https://example.com" :: Maybe Request of+        Nothing -> Left "parseRequest rejected a valid URL"+        Just req ->+          lookup hAuthorization (requestHeaders (authorizeRequest (AccessToken "test-token-123") req))+            `shouldBe` Just "Bearer test-token-123"+  ]++-- ---------------------------------------------------------------------------+-- Firestore: Error parsing+-- ---------------------------------------------------------------------------++errorParsingTests :: [Test]+errorParsingTests =+  [ Test "parseFirestoreError 404" $+      parseFirestoreError 404 "{\"error\":{\"code\":404,\"message\":\"not found\",\"status\":\"NOT_FOUND\"}}"+        `shouldBe` DocumentNotFound,+    Test "parseFirestoreError 403" $+      parseFirestoreError 403 "{\"error\":{\"code\":403,\"message\":\"denied\",\"status\":\"PERMISSION_DENIED\"}}"+        `shouldBe` PermissionDenied "denied",+    Test "parseFirestoreError 409 ABORTED" $+      parseFirestoreError 409 "{\"error\":{\"code\":409,\"message\":\"contention\",\"status\":\"ABORTED\"}}"+        `shouldBe` TransactionAborted "contention",+    Test "parseFirestoreError unparseable" $+      parseFirestoreError 500 "not json at all" `shouldBe` NetworkError "HTTP 500",+    Test "parseFirestoreError JSON without an error object" $+      parseFirestoreError 500 "{\"unexpected\":true}" `shouldBe` NetworkError "HTTP 500",+    Test "parseFirestoreError keeps an unclassified status" $+      parseFirestoreError 500 "{\"error\":{\"code\":500,\"message\":\"boom\",\"status\":\"INTERNAL\"}}"+        `shouldBe` FirestoreApiError 500 "INTERNAL" "boom",+    Test "parseFirestoreError tolerates a missing message" $+      parseFirestoreError 403 "{\"error\":{\"code\":403,\"status\":\"PERMISSION_DENIED\"}}"+        `shouldBe` PermissionDenied "",+    Test "parseFirestoreError unwraps a streaming array-framed error" $+      parseFirestoreError 403 "[{\"error\":{\"code\":403,\"message\":\"denied\",\"status\":\"PERMISSION_DENIED\"}}]"+        `shouldBe` PermissionDenied "denied",+    Test "parseFirestoreError classifies an array-framed ABORTED" $+      parseFirestoreError 409 "[{\"error\":{\"code\":409,\"message\":\"contention\",\"status\":\"ABORTED\"}}]"+        `shouldBe` TransactionAborted "contention"+  ]++-- ---------------------------------------------------------------------------+-- Firestore: Response decoding+-- ---------------------------------------------------------------------------++decoderTests :: [Test]+decoderTests =+  [ Test "decodeQueryResults keeps documents and skips the readTime entry" $+      decodeQueryResults+        "[{\"document\":{\"name\":\"projects/p/databases/(default)/documents/c/d\"}}\+        \,{\"readTime\":\"2024-01-15T10:30:00Z\"}]"+        `shouldBe` Right+          [ Document+              { docName = "projects/p/databases/(default)/documents/c/d",+                docFields = Map.empty,+                docCreateTime = Nothing,+                docUpdateTime = Nothing+              }+          ],+    Test "decodeQueryResults reports a malformed document instead of dropping it" $+      shouldHold "InvalidResponse" $+        isInvalidResponse (decodeQueryResults "[{\"document\":{\"fields\":{}}}]"),+    Test "decodeQueryResults reports a non-object result entry" $+      shouldHold "InvalidResponse" (isInvalidResponse (decodeQueryResults "[42]")),+    Test "decodeDocumentList reads an empty response as no documents" $+      decodeDocumentList "{}" `shouldBe` Right [],+    Test "decodeDocumentList reads the documents field" $+      fmap+        (map docName)+        ( decodeDocumentList+            "{\"documents\":[{\"name\":\"projects/p/databases/(default)/documents/c/d\"}]}"+        )+        `shouldBe` Right ["projects/p/databases/(default)/documents/c/d"],+    Test "decodeTransactionId extracts the ID" $+      decodeTransactionId "{\"transaction\":\"txn-bytes\"}"+        `shouldBe` Right (TransactionId "txn-bytes"),+    Test "decodeTransactionId reports a missing ID" $+      shouldHold "InvalidResponse" (isInvalidResponse (decodeTransactionId "{}")),+    Test "decodeQueryResults surfaces a streamed error element" $+      decodeQueryResults "[{\"error\":{\"code\":403,\"message\":\"denied\",\"status\":\"PERMISSION_DENIED\"}}]"+        `shouldBe` Left (PermissionDenied "denied"),+    Test "decodeQueryResults reports an error after partial results" $+      decodeQueryResults+        "[{\"document\":{\"name\":\"projects/p/databases/(default)/documents/c/d\"}}\+        \,{\"error\":{\"code\":409,\"message\":\"contention\",\"status\":\"ABORTED\"}}]"+        `shouldBe` Left (TransactionAborted "contention")+  ]+  where+    isInvalidResponse :: Either FirestoreError a -> Bool+    isInvalidResponse (Left (InvalidResponse _)) = True+    isInvalidResponse _ = False++-- ---------------------------------------------------------------------------+-- Helpers+-- ---------------------------------------------------------------------------++-- | Parse a UTC time string for test data.+parseUTC :: String -> UTCTime+parseUTC = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ"++-- | Parse a UTC time with sub-second precision, for the timestamp-precision test.+parseUTCSubsecond :: String -> UTCTime+parseUTCSubsecond = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ"