firebase-hs (empty) → 0.1.0.0

raw patch · 13 files changed

+2653/−0 lines, 13 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, firebase-hs, http-client, http-client-tls, http-types, jose, lens, servant-server, stm, text, time, transformers, vault, wai

Files

• CHANGELOG.md +45/−0
• LICENSE +21/−0
• README.md +311/−0
• firebase-hs.cabal +99/−0
• src/Firebase/Auth.hs +326/−0
• src/Firebase/Auth/Types.hs +91/−0
• src/Firebase/Auth/WAI.hs +152/−0
• src/Firebase/Firestore.hs +332/−0
• src/Firebase/Firestore/Internal.hs +207/−0
• src/Firebase/Firestore/Query.hs +231/−0
• src/Firebase/Firestore/Types.hs +261/−0
• src/Firebase/Servant.hs +100/−0
• test/Main.hs +477/−0

@@ -0,0 +1,45 @@+# Changelog++## 0.1.0.0++Initial release.++### Auth+- Firebase ID token (JWT) verification against Google's public keys+- RS256 signature validation via jose's polymorphic `verifyJWT` with custom claims subtype+- JWK-based key fetching with `Cache-Control: max-age` caching+- STM-backed `KeyCache` for thread-safe concurrent verification+- Strict JWKSet evaluation on fetch (zero deferred parse cost on hot path)+- Convenience `newTlsKeyCache` constructor+- Full claims validation: issuer, audience, expiry, issued-at, subject+- Configurable clock skew (default 300s)++### Firestore REST API Client+- CRUD operations: `getDocument`, `createDocument`, `updateDocument`, `deleteDocument`+- Structured query DSL with composable builder pattern (`query`, `where_`, `orderBy`, `limit`)+- Composite filters (`compositeAnd`, `compositeOr`) for complex query conditions+- `FirestoreValue` ADT with custom JSON instances matching Firestore's tagged wire format+- `Document` type with automatic JSON decoding from Firestore responses++### Atomic Transactions+- `beginTransaction`, `commitTransaction`, `rollbackTransaction` for manual control+- `runTransaction` for automatic begin/commit/rollback with callback+- `TransactionMode` sum type: `ReadWrite`, `RetryWith`, `ReadOnly`+- `TransactionAborted` error variant for contention detection++### WAI Auth Middleware (optional)+- `requireAuth` — simple gate middleware, rejects unauthenticated requests+- `firebaseAuth` — vault-based middleware, propagates `FirebaseUser` to handlers+- `lookupFirebaseUser` — retrieve authenticated user from WAI vault+- Gated behind `wai` cabal flag (default off)+- Works with Warp, Scotty, Yesod, Spock, and any WAI-based framework++### Servant Auth Combinator (optional)+- `firebaseAuthHandler` — one-liner Firebase auth for Servant servers+- Gated behind `servant` cabal flag (default off, zero extra deps)+- Pure helpers: `extractBearerToken`, `authErrorToBody`++### Internal+- Pure URL builders and error parsers in `Firebase.Firestore.Internal` (fully testable)+- Redacted `Show` instances for `AccessToken` and `TransactionId` (no credential leakage)+- 40 pure tests: value roundtrips, document decoding, URL construction, query DSL, transaction encoding, error parsing

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 Gondola Bros Entertainment++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,311 @@+<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>++[![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.6-purple)+![License](https://img.shields.io/badge/license-MIT-blue)++</p>+</div>++---++## What is firebase-hs?++A pure Haskell library for Firebase services:++- **Auth** — JWT verification against Google's public JWKs, 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)++---++## Quick Start++Add to your `.cabal` file:++```cabal+build-depends: firebase-hs+```++### Verify a Token++```haskell+import Firebase.Auth++main :: IO ()+main = do+  cache <- newTlsKeyCache+  let cfg = defaultFirebaseConfig "my-project-id"+  result <- verifyIdTokenCached cache cfg tokenBytes+  case result of+    Left err   -> putStrLn ("Auth failed: " ++ show err)+    Right user -> putStrLn ("UID: " ++ show (fuUid user))+```++---++## Auth++### Verification Rules++| 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.++### Error Handling++```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+```++---++## Firestore++### CRUD Operations++```haskell+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++  -- 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 ()+```++### Structured Queries++Build queries with a pure DSL and `(&)` composition:++```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)+```++### Firestore Value Types++Values mirror Firestore's tagged wire format:++```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+```++### Simple Gate++Reject unauthenticated requests before they reach your app:++```haskell+import Firebase.Auth (newTlsKeyCache, defaultFirebaseConfig)+import Firebase.Auth.WAI (requireAuth)+import Network.Wai.Handler.Warp (run)++main :: IO ()+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")+```++---++## 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)+import Servant.Server (Context (..))++main :: IO ()+main = do+  cache <- newTlsKeyCache+  let cfg = defaultFirebaseConfig "my-project-id"+      ctx = firebaseAuthHandler cache cfg :. EmptyContext+  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++```bash+cabal build                              # Build library+cabal test                               # Run all tests (40 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+```++---++<p align="center">+  <sub>MIT License · <a href="https://github.com/Gondola-Bros-Entertainment">Gondola Bros Entertainment</a></sub>+</p>

@@ -0,0 +1,99 @@+cabal-version:      3.0+name:               firebase-hs+version:            0.1.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.++license:            MIT+license-file:       LICENSE+author:             Devon Tomlin+maintainer:         devon.tomlin@novavero.ai+homepage:           https://github.com/Gondola-Bros-Entertainment/firebase-hs+bug-reports:        https://github.com/Gondola-Bros-Entertainment/firebase-hs/issues+category:           Web, Authentication, Database+stability:          experimental+build-type:         Simple+tested-with:        GHC == 9.6.7+extra-doc-files:+    CHANGELOG.md+    README.md++flag wai+  description: Enable WAI auth middleware (Firebase.Auth.WAI)+  default:     False+  manual:      True++flag servant+  description: Enable Servant auth combinator (Firebase.Servant)+  default:     False+  manual:      True++library+  exposed-modules:+    Firebase.Auth+    Firebase.Auth.Types+    Firebase.Firestore+    Firebase.Firestore.Internal+    Firebase.Firestore.Query+    Firebase.Firestore.Types++  build-depends:+      base             >= 4.17 && < 5+    , aeson            >= 2.0 && < 2.3+    , bytestring       >= 0.11 && < 0.13+    , containers       >= 0.6 && < 0.8+    , http-client      >= 0.7 && < 0.8+    , http-client-tls  >= 0.3 && < 0.4+    , http-types       >= 0.12 && < 0.13+    , jose             >= 0.11 && < 0.13+    , lens             >= 5.0 && < 5.4+    , stm              >= 2.5 && < 2.6+    , text             >= 2.0 && < 2.2+    , time             >= 1.12 && < 1.15+    , transformers     >= 0.5 && < 0.7++  if flag(wai)+    exposed-modules: Firebase.Auth.WAI+    build-depends:+        vault            >= 0.3 && < 0.4+      , wai              >= 3.2 && < 3.3++  if flag(servant)+    exposed-modules: Firebase.Servant+    build-depends:+        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+  type:             exitcode-stdio-1.0+  main-is:          Main.hs+  hs-source-dirs:   test+  build-depends:+      base             >= 4.17 && < 5+    , aeson            >= 2.0 && < 2.3+    , bytestring       >= 0.11 && < 0.13+    , containers       >= 0.6 && < 0.8+    , firebase-hs+    , http-types       >= 0.12 && < 0.13+    , text             >= 2.0 && < 2.2+    , time             >= 1.12 && < 1.15+  default-language:  Haskell2010+  ghc-options:       -Wall -Wcompat++source-repository head+  type:     git+  location: https://github.com/Gondola-Bros-Entertainment/firebase-hs+  branch:   main

@@ -0,0 +1,326 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}++-- |+-- Module      : Firebase.Auth+-- Description : Firebase ID token verification+-- License     : MIT+--+-- Verify Firebase Authentication ID tokens (JWTs) against Google's+-- public keys. Supports both one-shot verification and cached key+-- stores for production servers.+--+-- @+-- import Firebase.Auth+--+-- main :: IO ()+-- main = do+--   cache <- newTlsKeyCache+--   let cfg = defaultFirebaseConfig \"my-project-id\"+--   result <- verifyIdTokenCached cache cfg someJwtBytes+--   case result of+--     Left err   -> putStrLn (\"Auth failed: \" ++ show err)+--     Right user -> putStrLn (\"Welcome, \" ++ show (fuUid user))+-- @+module Firebase.Auth+  ( -- * One-shot verification+    verifyIdToken,++    -- * Cached verification+    newKeyCache,+    newTlsKeyCache,+    verifyIdTokenCached,++    -- * 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.Lens (view, (&), (.~))+import Control.Monad.Trans.Except (ExceptT, runExceptT, withExceptT)+import Crypto.JOSE.Error (Error)+import Crypto.JOSE.JWK (JWKSet (..))+import Crypto.JWT+  ( ClaimsSet,+    HasClaimsSet (..),+    JWTError (..),+    JWTValidationSettings,+    SignedJWT,+    StringOrURI,+    claimSub,+    decodeCompact,+    defaultJWTValidationSettings,+    jwtValidationSettingsAllowedSkew,+    jwtValidationSettingsIssuerPredicate,+    verifyJWT,+  )+import Data.Aeson (FromJSON (..), (.:?))+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as LBS+import Data.String (fromString)+import qualified Data.Text as T+import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)+import Firebase.Auth.Types+import Network.HTTP.Client+  ( Manager,+    Response,+    httpLbs,+    parseRequest,+    responseBody,+    responseHeaders,+  )+import Network.HTTP.Client.TLS (newTlsManager)+import Network.HTTP.Types.Header (ResponseHeaders, hCacheControl)++-- ---------------------------------------------------------------------------+-- Firebase JWT claims (jose subtype pattern)+-- ---------------------------------------------------------------------------++-- | JWT claims carrying both the standard 'ClaimsSet' and Firebase-specific+-- custom fields. This is the jose-recommended subtype approach: 'verifyJWT'+-- decodes and validates everything in one pass, with the types driving+-- which fields get extracted.+data FirebaseClaims = FirebaseClaims+  { _fcClaimsSet :: !ClaimsSet,+    _fcEmail :: !(Maybe T.Text),+    _fcName :: !(Maybe T.Text)+  }++instance HasClaimsSet FirebaseClaims where+  claimsSet f (FirebaseClaims cs e n) =+    (\cs' -> FirebaseClaims cs' e n) <$> f cs++instance FromJSON FirebaseClaims where+  parseJSON = Aeson.withObject "FirebaseClaims" $ \o ->+    FirebaseClaims+      <$> parseJSON (Aeson.Object o)+      <*> o .:? "email"+      <*> o .:? "name"++-- ---------------------------------------------------------------------------+-- Constants+-- ---------------------------------------------------------------------------++-- | Google's JWK endpoint for Firebase token verification.+googleJwkUrl :: String+googleJwkUrl =+  "https://www.googleapis.com/service_accounts/v1/jwk/securetoken@system.gserviceaccount.com"++-- | Fallback cache duration when @Cache-Control@ header is missing (1 hour).+defaultCacheDurationSeconds :: NominalDiffTime+defaultCacheDurationSeconds = 3600++-- | Firebase issuer URL prefix. Full issuer is this plus the project ID.+firebaseIssuerPrefix :: T.Text+firebaseIssuerPrefix = "https://securetoken.google.com/"++-- ---------------------------------------------------------------------------+-- One-shot verification+-- ---------------------------------------------------------------------------++-- | Verify a Firebase ID token, fetching Google's public keys fresh.+--+-- For production servers handling many requests, prefer 'verifyIdTokenCached'+-- to avoid re-fetching keys on every call.+verifyIdToken ::+  Manager ->+  FirebaseConfig ->+  -- | Raw JWT bytes (compact serialization)+  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++-- ---------------------------------------------------------------------------+-- Cached verification+-- ---------------------------------------------------------------------------++-- | Create a key cache backed by the given HTTP manager.+--+-- The manager must support HTTPS (e.g. from @Network.HTTP.Client.TLS@).+-- Keys are fetched lazily on first verification and refreshed when expired.+newKeyCache :: Manager -> IO KeyCache+newKeyCache mgr = do+  epoch <- getCurrentTime+  ref <- newTVarIO (JWKSet [], epoch)+  pure+    KeyCache+      { kcKeysRef = ref,+        kcManager = mgr+      }++-- | Create a key cache with a fresh TLS-enabled HTTP manager.+--+-- Convenience wrapper around 'newKeyCache' for the common case.+newTlsKeyCache :: IO KeyCache+newTlsKeyCache = newTlsManager >>= newKeyCache++-- | Verify a Firebase ID token using cached public keys.+--+-- Keys are refreshed automatically when the cache expires (per Google's+-- @Cache-Control: max-age@ response header).+verifyIdTokenCached ::+  KeyCache ->+  FirebaseConfig ->+  -- | Raw JWT bytes (compact serialization)+  BS.ByteString ->+  IO (Either AuthError FirebaseUser)+verifyIdTokenCached cache config token = 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++-- ---------------------------------------------------------------------------+-- Key fetching+-- ---------------------------------------------------------------------------++-- | Fetch Google's public JWK set and compute the cache expiry from the+-- @Cache-Control: max-age@ response header.+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+    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+          -- Force the decoded JWKSet to WHNF so verification doesn't pay+          -- deferred parse cost on the hot path.+          !_ <- evaluate jwks+          pure (Right (jwks, expiry))++-- | Parse the @max-age@ directive from a @Cache-Control@ response header.+--+-- Returns 'Nothing' if the header is absent or has no valid @max-age@ value.+--+-- >>> 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++-- ---------------------------------------------------------------------------+-- JWT verification+-- ---------------------------------------------------------------------------++-- | Verify a JWT against the given JWK set and Firebase configuration.+--+-- Uses jose's polymorphic 'verifyJWT' with our 'FirebaseClaims' subtype,+-- so signature verification, claims validation, and custom field extraction+-- all happen in a single type-directed pass.+verifyWithKeys ::+  JWKSet ->+  FirebaseConfig ->+  BS.ByteString ->+  IO (Either AuthError FirebaseUser)+verifyWithKeys jwks config tokenBytes = do+  let token = LBS.fromStrict tokenBytes+      projectId = fcProjectId config+      expectedIssuer = firebaseIssuerPrefix <> projectId+      settings = makeValidationSettings projectId expectedIssuer (fcClockSkew config)+  result <- runExceptT $ do+    jwt <-+      withExceptT+        mapDecodeError+        (decodeCompact token :: ExceptT Error IO SignedJWT)+    withExceptT+      mapVerifyError+      (verifyJWT settings jwks jwt :: ExceptT JWTError IO FirebaseClaims)+  pure $ case result of+    Left err -> Left err+    Right fc -> toFirebaseUser fc++-- | Build JWT validation settings for Firebase token verification.+--+-- Validates: audience = project ID, issuer = Firebase issuer URL,+-- expiry and issued-at within allowed clock skew.+makeValidationSettings ::+  T.Text -> T.Text -> NominalDiffTime -> JWTValidationSettings+makeValidationSettings projectId expectedIssuer skew =+  defaultJWTValidationSettings (== textToStringOrURI projectId)+    & jwtValidationSettingsIssuerPredicate .~ (== textToStringOrURI expectedIssuer)+    & jwtValidationSettingsAllowedSkew .~ skew++-- | Convert verified 'FirebaseClaims' to a 'FirebaseUser'.+--+-- The @sub@ claim is guaranteed present by Firebase's token contract,+-- but we handle the missing case defensively.+toFirebaseUser :: FirebaseClaims -> Either AuthError FirebaseUser+toFirebaseUser fc = do+  sub <- maybe (Left (InvalidClaims "missing sub claim")) Right (view claimSub fc)+  uid <- maybe (Left (InvalidClaims "empty sub claim")) Right (stringOrUriToText sub)+  Right+    FirebaseUser+      { fuUid = uid,+        fuEmail = _fcEmail fc,+        fuName = _fcName fc+      }++-- ---------------------------------------------------------------------------+-- Helpers+-- ---------------------------------------------------------------------------++-- | Convert 'Data.Text.Text' to jose 'StringOrURI' via the 'Data.String.IsString' instance.+textToStringOrURI :: T.Text -> StringOrURI+textToStringOrURI = fromString . T.unpack++-- | Extract text from a jose 'StringOrURI' by round-tripping through JSON.+stringOrUriToText :: StringOrURI -> Maybe T.Text+stringOrUriToText s = case Aeson.toJSON s of+  Aeson.String t | not (T.null t) -> Just t+  _ -> Nothing++-- | Map a JOSE decode error to 'AuthError'.+mapDecodeError :: Error -> AuthError+mapDecodeError = MalformedToken . T.pack . show++-- | Map a JWT verification error to 'AuthError'.+mapVerifyError :: JWTError -> AuthError+mapVerifyError JWTExpired = TokenExpired+mapVerifyError JWTNotInAudience = InvalidClaims "audience mismatch"+mapVerifyError JWTNotInIssuer = InvalidClaims "issuer mismatch"+mapVerifyError JWTIssuedAtFuture = InvalidClaims "token issued in the future"+mapVerifyError JWTNotYetValid = InvalidClaims "token not yet valid"+mapVerifyError (JWTClaimsSetDecodeError msg) = MalformedToken (T.pack msg)+mapVerifyError (JWSError _) = InvalidSignature

@@ -0,0 +1,91 @@+{-# LANGUAGE StrictData #-}++-- |+-- Module      : Firebase.Auth.Types+-- Description : Types for Firebase JWT verification+-- License     : MIT+--+-- Core data types for Firebase ID token verification: configuration,+-- authenticated user, error reporting, and key caching.+module Firebase.Auth.Types+  ( -- * Configuration+    FirebaseConfig (..),+    defaultFirebaseConfig,++    -- * Authenticated User+    FirebaseUser (..),++    -- * Errors+    AuthError (..),++    -- * Key Cache+    KeyCache (..),+  )+where++import Control.Concurrent.STM (TVar)+import Crypto.JOSE.JWK (JWKSet)+import Data.Text (Text)+import Data.Time (NominalDiffTime, UTCTime)+import Network.HTTP.Client (Manager)++-- | Configuration for Firebase ID token verification.+data FirebaseConfig = FirebaseConfig+  { -- | Firebase project ID (e.g. @\"gondola-bros-hub\"@).+    fcProjectId :: !Text,+    -- | Maximum allowed clock skew between server and Google.+    -- Default: 300 seconds.+    fcClockSkew :: !NominalDiffTime+  }++-- | Default clock skew allowance: 300 seconds.+defaultClockSkewSeconds :: NominalDiffTime+defaultClockSkewSeconds = 300++-- | Create a 'FirebaseConfig' with a 300-second clock skew allowance.+defaultFirebaseConfig ::+  -- | Firebase project ID+  Text ->+  FirebaseConfig+defaultFirebaseConfig projectId =+  FirebaseConfig+    { fcProjectId = projectId,+      fcClockSkew = defaultClockSkewSeconds+    }++-- | An authenticated Firebase user, extracted from a verified ID token.+data FirebaseUser = FirebaseUser+  { -- | Firebase UID (the token's @sub@ claim).+    fuUid :: !Text,+    -- | Email address, if present in token claims.+    fuEmail :: !(Maybe Text),+    -- | Display name, if present in token claims.+    fuName :: !(Maybe Text)+  }+  deriving (Eq, Show)++-- | Errors that can occur during token verification.+data AuthError+  = -- | Failed to fetch Google's public keys.+    KeyFetchError !Text+  | -- | JWT signature does not match any Google public key.+    InvalidSignature+  | -- | Token has expired (past @exp@ claim minus allowed skew).+    TokenExpired+  | -- | Token claims are invalid (wrong issuer, audience, empty subject, etc.).+    InvalidClaims !Text+  | -- | Token is not valid compact JWT serialization.+    MalformedToken !Text+  deriving (Eq, Show)++-- | 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.+data KeyCache = KeyCache+  { -- | Cached JWK set and its expiry time (STM for atomic concurrent access).+    kcKeysRef :: !(TVar (JWKSet, UTCTime)),+    -- | HTTP manager for fetching keys from Google.+    kcManager :: !Manager+  }

@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}++-- |+-- Module      : Firebase.Auth.WAI+-- Description : WAI middleware for Firebase authentication+-- License     : MIT+--+-- Firebase authentication middleware for any WAI-based web server.+-- Works with Warp, Scotty, Yesod, Spock, and any other framework+-- built on WAI.+--+-- @+-- import Firebase.Auth (newTlsKeyCache, defaultFirebaseConfig)+-- import Firebase.Auth.WAI (firebaseAuth, requireAuth)+-- import Network.Wai.Handler.Warp (run)+--+-- main :: IO ()+-- main = do+--   cache <- newTlsKeyCache+--   let cfg = defaultFirebaseConfig \"my-project-id\"+--   run 3000 $ requireAuth cache cfg myApp+-- @+module Firebase.Auth.WAI+  ( -- * Middleware+    requireAuth,++    -- * Vault-based (advanced)+    firebaseAuth,+    firebaseUserKey,+    lookupFirebaseUser,+  )+where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.Char8 as LBS8+import qualified Data.Vault.Lazy as Vault+import Firebase.Auth (verifyIdTokenCached)+import Firebase.Auth.Types (AuthError (..), FirebaseConfig, FirebaseUser, KeyCache)+import Network.HTTP.Types.Status (status401)+import Network.Wai (Middleware, Request, Response, requestHeaders, responseLBS, vault)+import System.IO.Unsafe (unsafePerformIO)++-- ---------------------------------------------------------------------------+-- Constants+-- ---------------------------------------------------------------------------++-- | The @\"Bearer \"@ prefix length (7 bytes).+bearerPrefixLen :: Int+bearerPrefixLen = 7++-- ---------------------------------------------------------------------------+-- Simple Middleware+-- ---------------------------------------------------------------------------++-- | Middleware that requires a valid Firebase ID token on every request.+--+-- Requests without a valid @Authorization: Bearer \<token\>@ header receive+-- a 401 response and never reach the wrapped application.+--+-- @+-- 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++-- ---------------------------------------------------------------------------+-- Vault-based Middleware (advanced)+-- ---------------------------------------------------------------------------++-- | Global vault key for storing the authenticated 'FirebaseUser'.+--+-- Uses @unsafePerformIO@ per the @vault@ library's documented pattern+-- for creating global keys.+firebaseUserKey :: Vault.Key FirebaseUser+firebaseUserKey = unsafePerformIO Vault.newKey+{-# NOINLINE firebaseUserKey #-}++-- | Middleware that verifies Firebase tokens and stores the authenticated+-- user in the WAI request vault.+--+-- Downstream handlers can retrieve the user with 'lookupFirebaseUser'.+-- Requests without valid tokens receive a 401 response.+--+-- @+-- main = run 3000 $ firebaseAuth cache cfg myApp+--+-- myHandler :: Request -> IO Response+-- myHandler req = case lookupFirebaseUser req of+--   Just user -> ...  -- authenticated+--   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++-- | Look up the authenticated 'FirebaseUser' from a WAI request vault.+--+-- Returns 'Just' when the request has passed through 'firebaseAuth'.+lookupFirebaseUser :: Request -> Maybe FirebaseUser+lookupFirebaseUser = Vault.lookup firebaseUserKey . vault++-- ---------------------------------------------------------------------------+-- 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"++-- | 401 response with a description of the auth error.+errorResponse :: AuthError -> Response+errorResponse err =+  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"

@@ -0,0 +1,332 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}++-- |+-- Module      : Firebase.Firestore+-- Description : Firestore REST API client+-- License     : MIT+--+-- CRUD operations, structured queries, and atomic transactions against the+-- Firestore REST API. All operations return @'Either' 'FirestoreError' a@ —+-- no exceptions are thrown for API-level errors.+--+-- @+-- 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+--   case result of+--     Left err  -> print err+--     Right doc -> print (docFields doc)+-- @+module Firebase.Firestore+  ( -- * CRUD Operations+    getDocument,+    createDocument,+    updateDocument,+    deleteDocument,++    -- * Queries+    runQuery,++    -- * Transactions+    beginTransaction,+    commitTransaction,+    rollbackTransaction,+    runTransaction,++    -- * HTTP Manager+    newTlsManager,++    -- * Re-exports+    module Firebase.Firestore.Types,+    module Firebase.Firestore.Query,+  )+where++import Control.Exception (SomeException, 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 qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Map.Strict (Map)+import Data.Text (Text)+import qualified Data.Text as T+import Firebase.Firestore.Internal+import Firebase.Firestore.Query+import Firebase.Firestore.Types+import Network.HTTP.Client+  ( Manager,+    Request,+    RequestBody (..),+    Response,+    httpLbs,+    method,+    parseRequest,+    requestBody,+    requestHeaders,+    responseBody,+    responseStatus,+  )+import Network.HTTP.Client.TLS (newTlsManager)+import Network.HTTP.Types.Status (statusCode)++-- ---------------------------------------------------------------------------+-- HTTP status code constants+-- ---------------------------------------------------------------------------++-- | HTTP 200 OK.+httpOk :: Int+httpOk = 200++-- | Upper bound for successful HTTP status codes (exclusive).+httpSuccessUpperBound :: Int+httpSuccessUpperBound = 300++-- ---------------------------------------------------------------------------+-- 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))++-- | Create a document with a specific ID in a collection.+createDocument ::+  Manager ->+  AccessToken ->+  ProjectId ->+  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)++-- | Update a document's fields. Pass field names to update specific fields,+-- or an empty list to replace all fields.+updateDocument ::+  Manager ->+  AccessToken ->+  ProjectId ->+  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)++-- | 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)++-- ---------------------------------------------------------------------------+-- 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)++-- ---------------------------------------------------------------------------+-- 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)++-- | 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)++-- | 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)++-- | 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.+--+-- @+-- runTransaction mgr tok pid ReadWrite $ \\txnId -> runExceptT $ do+--   doc <- ExceptT $ getDocument mgr tok pid somePath+--   pure [mkUpdateWrite somePath (docFields doc)]+-- @+runTransaction ::+  Manager ->+  AccessToken ->+  ProjectId ->+  TransactionMode ->+  (TransactionId -> IO (Either FirestoreError [Aeson.Value])) ->+  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+      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)++-- ---------------------------------------------------------------------------+-- 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++-- | 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)++-- | 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)++-- | Core HTTP request executor.+doRequest ::+  Manager ->+  AccessToken ->+  String ->+  BS.ByteString ->+  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 '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)++-- | 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+  where+    go (Aeson.Object o) = case KM.lookup "document" o of+      Just v -> case Aeson.fromJSON v of+        Aeson.Success doc -> [doc]+        _ -> []+      Nothing -> []+    go _ = []++-- | 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")+  where+    extractTxnId (Aeson.Object o) = case KM.lookup "transaction" o of+      Just (Aeson.String t) -> Just (TransactionId t)+      _ -> Nothing+    extractTxnId _ = Nothing

@@ -0,0 +1,207 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}++-- |+-- Module      : Firebase.Firestore.Internal+-- Description : Pure URL builders and request helpers for Firestore+-- License     : MIT+--+-- Internal utilities for constructing Firestore REST API URLs and requests.+-- All functions are pure and testable without IO.+module Firebase.Firestore.Internal+  ( -- * Constants+    firestoreBaseUrl,++    -- * URL Construction+    documentUrl,+    collectionUrl,+    createDocUrl,+    updateDocUrl,+    queryUrl,+    beginTransactionUrl,+    commitUrl,+    rollbackUrl,++    -- * Request Helpers+    authorizeRequest,++    -- * Response Parsing+    parseFirestoreError,+  )+where++import Data.Aeson ((.:), (.:?))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.KeyMap as KM+import Data.Aeson.Types (parseMaybe)+import qualified Data.ByteString.Lazy as LBS+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Firebase.Firestore.Types+import Network.HTTP.Client (Request, requestHeaders)++-- ---------------------------------------------------------------------------+-- Constants+-- ---------------------------------------------------------------------------++-- | Firestore REST API base URL.+firestoreBaseUrl :: String+firestoreBaseUrl = "https://firestore.googleapis.com/v1"++-- | Firestore database path segment.+firestoreDatabasePath :: String+firestoreDatabasePath = "/databases/(default)/documents"++-- ---------------------------------------------------------------------------+-- URL Construction+-- ---------------------------------------------------------------------------++-- | 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 =+  firestoreBaseUrl+    <> "/projects/"+    <> T.unpack (unProjectId pid)+    <> firestoreDatabasePath+    <> "/"+    <> T.unpack (unCollectionPath (dpCollection dp))+    <> "/"+    <> T.unpack (unDocumentId (dpDocument dp))++-- | URL for a collection (used for listing).+--+-- >>> collectionUrl (ProjectId "p") (CollectionPath "users")+-- "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)++-- | 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)++-- | URL for updating a document with an optional field mask.+--+-- Empty field list means update all fields.+updateDocUrl :: ProjectId -> DocumentPath -> [Text] -> String+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 beginning a transaction.+beginTransactionUrl :: ProjectId -> String+beginTransactionUrl pid =+  firestoreBaseUrl+    <> "/projects/"+    <> T.unpack (unProjectId pid)+    <> firestoreDatabasePath+    <> ":beginTransaction"++-- | URL for committing a transaction.+commitUrl :: ProjectId -> String+commitUrl pid =+  firestoreBaseUrl+    <> "/projects/"+    <> T.unpack (unProjectId pid)+    <> firestoreDatabasePath+    <> ":commit"++-- | URL for rolling back a transaction.+rollbackUrl :: ProjectId -> String+rollbackUrl pid =+  firestoreBaseUrl+    <> "/projects/"+    <> T.unpack (unProjectId pid)+    <> firestoreDatabasePath+    <> ":rollback"++-- ---------------------------------------------------------------------------+-- Helpers+-- ---------------------------------------------------------------------------++-- | Build @updateMask.fieldPaths@ query parameters.+fieldMaskParams :: [Text] -> String+fieldMaskParams [] = ""+fieldMaskParams fs =+  "?" <> intercalateAmp ["updateMask.fieldPaths=" <> T.unpack f | f <- fs]+  where+    intercalateAmp [] = ""+    intercalateAmp [x] = x+    intercalateAmp (x : xs) = x <> "&" <> intercalateAmp xs++-- ---------------------------------------------------------------------------+-- Request Helpers+-- ---------------------------------------------------------------------------++-- | 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}++-- ---------------------------------------------------------------------------+-- Response Parsing+-- ---------------------------------------------------------------------------++-- | Parse an HTTP error response body into a 'FirestoreError'.+--+-- Firestore returns errors in the form:+--+-- @+-- { "error": { "code": 404, "message": "...", "status": "NOT_FOUND" } }+-- @+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+  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"++-- | Parse the inner @\"error\"@ object.+parseErrorInner :: Int -> Aeson.Value -> FirestoreError+parseErrorInner status = go+  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"++-- | 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 code grpcStatus msg =+  FirestoreApiError code (fromMaybe "" grpcStatus) (fromMaybe "" msg)

@@ -0,0 +1,231 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}++-- |+-- Module      : Firebase.Firestore.Query+-- Description : Structured query DSL for Firestore+-- License     : MIT+--+-- A pure builder-pattern DSL for constructing Firestore structured queries.+-- Compose with @(&)@ from "Data.Function":+--+-- @+-- import Data.Function ((&))+--+-- let q = query (CollectionPath \"users\")+--       & where_ (fieldFilter \"age\" OpGreaterThan (IntegerValue 18))+--       & orderBy \"age\" Ascending+--       & limit 10+-- @+module Firebase.Firestore.Query+  ( -- * Query Construction+    StructuredQuery,+    query,+    where_,+    orderBy,+    limit,+    offset,++    -- * Filters+    Filter (..),+    FieldFilter (..),+    CompositeFilter (..),+    CompositeOp (..),+    FilterOp (..),+    fieldFilter,+    compositeAnd,+    compositeOr,++    -- * Ordering+    OrderDirection (..),++    -- * Encoding+    encodeQuery,+  )+where++import Data.Aeson ((.=))+import qualified Data.Aeson as Aeson+import Data.Text (Text)+import Firebase.Firestore.Types (CollectionPath (..), FirestoreValue)++-- ---------------------------------------------------------------------------+-- Types+-- ---------------------------------------------------------------------------++-- | A structured query builder. Construct with 'query' and refine with+-- 'where_', 'orderBy', 'limit', and 'offset'.+data StructuredQuery = StructuredQuery+  { sqFrom :: !CollectionPath,+    sqWhere :: !(Maybe Filter),+    sqOrderBy :: ![(Text, OrderDirection)],+    sqLimit :: !(Maybe Int),+    sqOffset :: !(Maybe Int)+  }+  deriving (Eq, Show)++-- | A query filter: either a single field filter or a composite of filters.+data Filter+  = FieldFilterF !FieldFilter+  | CompositeFilterF !CompositeFilter+  deriving (Eq, Show)++-- | A filter on a single field.+data FieldFilter = FieldFilter+  { ffField :: !Text,+    ffOp :: !FilterOp,+    ffValue :: !FirestoreValue+  }+  deriving (Eq, Show)++-- | A composite of multiple filters joined by AND or OR.+data CompositeFilter = CompositeFilter+  { cfOp :: !CompositeOp,+    cfFilters :: ![Filter]+  }+  deriving (Eq, Show)++-- | Composite filter operator.+data CompositeOp = OpAnd | OpOr+  deriving (Eq, Show)++-- | Field filter comparison operators.+data FilterOp+  = OpEqual+  | OpNotEqual+  | OpLessThan+  | OpLessThanOrEqual+  | OpGreaterThan+  | OpGreaterThanOrEqual+  | OpArrayContains+  | OpIn+  | OpArrayContainsAny+  | OpNotIn+  deriving (Eq, Show)++-- | Sort direction for 'orderBy'.+data OrderDirection = Ascending | Descending+  deriving (Eq, Show)++-- ---------------------------------------------------------------------------+-- Builders+-- ---------------------------------------------------------------------------++-- | Start a query on a collection.+query :: CollectionPath -> StructuredQuery+query cp =+  StructuredQuery+    { sqFrom = cp,+      sqWhere = Nothing,+      sqOrderBy = [],+      sqLimit = Nothing,+      sqOffset = Nothing+    }++-- | Add a filter to the query. Replaces any existing filter.+where_ :: Filter -> StructuredQuery -> StructuredQuery+where_ f sq = sq {sqWhere = Just f}++-- | Add an ordering clause. Multiple calls append in order.+orderBy :: Text -> OrderDirection -> StructuredQuery -> StructuredQuery+orderBy field dir sq = sq {sqOrderBy = sqOrderBy sq ++ [(field, dir)]}++-- | Set the maximum number of results to return.+limit :: Int -> StructuredQuery -> StructuredQuery+limit n sq = sq {sqLimit = Just n}++-- | Set the number of results to skip before returning.+offset :: Int -> StructuredQuery -> StructuredQuery+offset n sq = sq {sqOffset = Just n}++-- | Convenience: create a single field filter.+fieldFilter :: Text -> FilterOp -> FirestoreValue -> Filter+fieldFilter field op val = FieldFilterF (FieldFilter field op val)++-- | Convenience: create an AND composite filter.+compositeAnd :: [Filter] -> Filter+compositeAnd = CompositeFilterF . CompositeFilter OpAnd++-- | Convenience: create an OR composite filter.+compositeOr :: [Filter] -> Filter+compositeOr = CompositeFilterF . CompositeFilter OpOr++-- ---------------------------------------------------------------------------+-- JSON Encoding+-- ---------------------------------------------------------------------------++-- | Encode a 'StructuredQuery' to the JSON format expected by the+-- Firestore REST API's @:runQuery@ endpoint.+encodeQuery :: StructuredQuery -> Aeson.Value+encodeQuery sq =+  Aeson.object+    [ "structuredQuery"+        .= Aeson.object+          ( ["from" .= [encodeCollectionSelector (sqFrom sq)]]+              ++ maybe [] (\f -> ["where" .= encodeFilter f]) (sqWhere sq)+              ++ encodeOrderBy (sqOrderBy sq)+              ++ maybe [] (\n -> ["limit" .= n]) (sqLimit sq)+              ++ maybe [] (\n -> ["offset" .= n]) (sqOffset sq)+          )+    ]++-- | Encode a collection selector.+encodeCollectionSelector :: CollectionPath -> Aeson.Value+encodeCollectionSelector (CollectionPath cp) =+  Aeson.object ["collectionId" .= cp]++-- | Encode a filter to Firestore JSON.+encodeFilter :: Filter -> Aeson.Value+encodeFilter (FieldFilterF ff) =+  Aeson.object+    [ "fieldFilter"+        .= Aeson.object+          [ "field" .= Aeson.object ["fieldPath" .= ffField ff],+            "op" .= encodeFilterOp (ffOp ff),+            "value" .= ffValue ff+          ]+    ]+encodeFilter (CompositeFilterF cf) =+  Aeson.object+    [ "compositeFilter"+        .= Aeson.object+          [ "op" .= encodeCompositeOp (cfOp cf),+            "filters" .= map encodeFilter (cfFilters cf)+          ]+    ]++-- | Encode ordering clauses.+encodeOrderBy :: [(Text, OrderDirection)] -> [(Aeson.Key, Aeson.Value)]+encodeOrderBy [] = []+encodeOrderBy orders =+  [ "orderBy"+      .= [ Aeson.object+             [ "field" .= Aeson.object ["fieldPath" .= field],+               "direction" .= encodeDirection dir+             ]+         | (field, dir) <- orders+         ]+  ]++-- | Encode a filter operator to its Firestore string representation.+encodeFilterOp :: FilterOp -> Text+encodeFilterOp OpEqual = "EQUAL"+encodeFilterOp OpNotEqual = "NOT_EQUAL"+encodeFilterOp OpLessThan = "LESS_THAN"+encodeFilterOp OpLessThanOrEqual = "LESS_THAN_OR_EQUAL"+encodeFilterOp OpGreaterThan = "GREATER_THAN"+encodeFilterOp OpGreaterThanOrEqual = "GREATER_THAN_OR_EQUAL"+encodeFilterOp OpArrayContains = "ARRAY_CONTAINS"+encodeFilterOp OpIn = "IN"+encodeFilterOp OpArrayContainsAny = "ARRAY_CONTAINS_ANY"+encodeFilterOp OpNotIn = "NOT_IN"++-- | Encode a composite operator.+encodeCompositeOp :: CompositeOp -> Text+encodeCompositeOp OpAnd = "AND"+encodeCompositeOp OpOr = "OR"++-- | Encode an order direction.+encodeDirection :: OrderDirection -> Text+encodeDirection Ascending = "ASCENDING"+encodeDirection Descending = "DESCENDING"

@@ -0,0 +1,261 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Module      : Firebase.Firestore.Types+-- Description : Types for Firestore REST API+-- License     : MIT+--+-- Newtypes, value ADT, document, and error types for the Firestore REST API.+-- 'FirestoreValue' uses custom JSON instances matching Firestore's tagged+-- wire format (@{\"stringValue\":\"...\"}@, @{\"integerValue\":\"42\"}@, etc.).+module Firebase.Firestore.Types+  ( -- * Identifiers+    ProjectId (..),+    CollectionPath (..),+    DocumentId (..),+    AccessToken (..),+    DocumentPath (..),++    -- * Values+    FirestoreValue (..),++    -- * Documents+    Document (..),++    -- * Errors+    FirestoreError (..),++    -- * Transactions+    TransactionId (..),+    TransactionMode (..),+    encodeTransactionOptions,+  )+where++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 qualified Data.ByteString as BS+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 Data.Time (UTCTime)+import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeM)++-- ---------------------------------------------------------------------------+-- Identifiers+-- ---------------------------------------------------------------------------++-- | Firebase project ID (e.g. @\"my-project-id\"@).+newtype ProjectId = ProjectId {unProjectId :: Text}+  deriving (Eq, Show)++-- | Firestore collection path (e.g. @\"users\"@ or @\"users\/abc\/posts\"@).+newtype CollectionPath = CollectionPath {unCollectionPath :: Text}+  deriving (Eq, Show)++-- | Firestore document ID within a collection.+newtype DocumentId = DocumentId {unDocumentId :: Text}+  deriving (Eq, Show)++-- | OAuth2 access token for authenticating Firestore requests.+newtype AccessToken = AccessToken {unAccessToken :: BS.ByteString}+  deriving (Eq)++-- | Redacted to prevent credential leakage in logs and error messages.+instance Show AccessToken where+  show _ = "AccessToken <redacted>"++-- | Full path to a document: collection + document ID.+data DocumentPath = DocumentPath+  { dpCollection :: !CollectionPath,+    dpDocument :: !DocumentId+  }+  deriving (Eq, Show)++-- ---------------------------------------------------------------------------+-- Transactions+-- ---------------------------------------------------------------------------++-- | Opaque transaction identifier returned by Firestore.+newtype TransactionId = TransactionId {unTransactionId :: Text}+  deriving (Eq)++-- | Redacted to prevent token leakage in logs and error messages.+instance Show TransactionId where+  show _ = "TransactionId <redacted>"++-- | How to begin a Firestore transaction.+data TransactionMode+  = -- | Read-write transaction (the default).+    ReadWrite+  | -- | Read-write transaction that retries a previously aborted one.+    RetryWith !TransactionId+  | -- | Read-only transaction (no writes allowed).+    ReadOnly+  deriving (Eq, Show)++-- | Encode transaction options to the JSON body for @:beginTransaction@.+encodeTransactionOptions :: TransactionMode -> Aeson.Value+encodeTransactionOptions ReadWrite =+  Aeson.object+    ["options" .= Aeson.object ["readWrite" .= Aeson.object []]]+encodeTransactionOptions (RetryWith (TransactionId txn)) =+  Aeson.object+    [ "options"+        .= Aeson.object+          ["readWrite" .= Aeson.object ["retryTransaction" .= txn]]+    ]+encodeTransactionOptions ReadOnly =+  Aeson.object+    ["options" .= Aeson.object ["readOnly" .= Aeson.object []]]++-- ---------------------------------------------------------------------------+-- Firestore values+-- ---------------------------------------------------------------------------++-- | 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.+data FirestoreValue+  = NullValue+  | BoolValue !Bool+  | IntegerValue !Int64+  | DoubleValue !Double+  | StringValue !Text+  | TimestampValue !UTCTime+  | ArrayValue ![FirestoreValue]+  | MapValue !(Map Text FirestoreValue)+  deriving (Eq, Show)++-- | Firestore's RFC 3339 timestamp format.+timestampFormat :: String+timestampFormat = "%Y-%m-%dT%H:%M:%S%QZ"++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 (StringValue s) = Aeson.object ["stringValue" .= s]+  toJSON (TimestampValue t) =+    Aeson.object+      ["timestampValue" .= formatTime defaultTimeLocale timestampFormat t]+  toJSON (ArrayValue xs) =+    Aeson.object ["arrayValue" .= Aeson.object ["values" .= xs]]+  toJSON (MapValue m) =+    Aeson.object+      ["mapValue" .= Aeson.object ["fields" .= mapToFieldsJSON m]]++instance FromJSON FirestoreValue where+  parseJSON = Aeson.withObject "FirestoreValue" $ \o ->+    case KM.toList o of+      [("nullValue", _)] -> pure NullValue+      [("booleanValue", v)] -> BoolValue <$> parseJSON v+      [("integerValue", v)] -> IntegerValue <$> parseIntegerValue v+      [("doubleValue", v)] -> DoubleValue <$> parseJSON v+      [("stringValue", v)] -> StringValue <$> parseJSON v+      [("timestampValue", v)] -> TimestampValue <$> parseTimestamp v+      [("arrayValue", v)] -> ArrayValue <$> parseArrayValue v+      [("mapValue", v)] -> MapValue <$> parseMapValue v+      _ -> fail "unrecognized FirestoreValue tag"++-- | Parse an integer value from a JSON string (Firestore's wire format).+parseIntegerValue :: Aeson.Value -> Parser Int64+parseIntegerValue = Aeson.withText "integerValue" $ \t ->+  case reads (T.unpack t) of+    [(n, "")] -> pure n+    _ -> fail ("invalid integerValue: " ++ T.unpack t)++-- | Parse a timestamp from an RFC 3339 string.+parseTimestamp :: Aeson.Value -> Parser UTCTime+parseTimestamp = Aeson.withText "timestampValue" $ \t ->+  case parseTimeM True defaultTimeLocale timestampFormat (T.unpack t) of+    Just utc -> pure utc+    Nothing -> fail ("invalid timestamp: " ++ T.unpack t)++-- | Parse an array value from @{\"values\": [...]}@.+parseArrayValue :: Aeson.Value -> Parser [FirestoreValue]+parseArrayValue = Aeson.withObject "arrayValue" $ \o ->+  o .:? "values" >>= \case+    Nothing -> pure []+    Just vs -> parseJSON vs++-- | Parse a map value from @{\"fields\": {...}}@.+parseMapValue :: Aeson.Value -> Parser (Map Text FirestoreValue)+parseMapValue = Aeson.withObject "mapValue" $ \o ->+  o .:? "fields" >>= \case+    Nothing -> pure Map.empty+    Just fieldsVal -> parseFieldsJSON fieldsVal++-- | Parse Firestore fields object to a 'Map'.+parseFieldsJSON :: Aeson.Value -> Parser (Map Text FirestoreValue)+parseFieldsJSON = Aeson.withObject "fields" $ \o ->+  Map.fromList <$> traverse parseField (KM.toList o)+  where+    parseField (k, v) = (Key.toText k,) <$> parseJSON v++-- | Encode a 'Map' to Firestore fields JSON.+mapToFieldsJSON :: Map Text FirestoreValue -> Aeson.Value+mapToFieldsJSON m =+  Aeson.object [Key.fromText k .= v | (k, v) <- Map.toList m]++-- ---------------------------------------------------------------------------+-- Documents+-- ---------------------------------------------------------------------------++-- | A Firestore document with its metadata.+data Document = Document+  { -- | Full resource name (e.g. @\"projects\/p\/databases\/(default)\/documents\/col\/doc\"@).+    docName :: !Text,+    -- | Document fields.+    docFields :: !(Map Text FirestoreValue),+    -- | Server-assigned creation time.+    docCreateTime :: !(Maybe UTCTime),+    -- | Server-assigned last update time.+    docUpdateTime :: !(Maybe UTCTime)+  }+  deriving (Eq, Show)++instance FromJSON Document where+  parseJSON = Aeson.withObject "Document" $ \o ->+    Document+      <$> o .: "name"+      <*> (o .:? "fields" >>= maybe (pure Map.empty) parseFieldsJSON)+      <*> o .:? "createTime"+      <*> o .:? "updateTime"++instance ToJSON Document where+  toJSON doc =+    Aeson.object+      [ "name" .= docName doc,+        "fields" .= mapToFieldsJSON (docFields doc)+      ]++-- ---------------------------------------------------------------------------+-- Errors+-- ---------------------------------------------------------------------------++-- | Errors that can occur during Firestore operations.+data FirestoreError+  = -- | Document does not exist (HTTP 404).+    DocumentNotFound+  | -- | Insufficient permissions (HTTP 403).+    PermissionDenied !Text+  | -- | HTTP or network-level error.+    NetworkError !Text+  | -- | Response could not be decoded as expected.+    InvalidResponse !Text+  | -- | Firestore API error with HTTP status, gRPC status, and message.+    FirestoreApiError !Int !Text !Text+  | -- | Transaction was aborted (contention or conflict).+    TransactionAborted !Text+  deriving (Eq, Show)

@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}++-- |+-- Module      : Firebase.Servant+-- Description : Servant auth combinator for Firebase+-- License     : MIT+--+-- One-liner Firebase authentication for Servant servers. Use+-- 'firebaseAuthHandler' to create an 'AuthHandler' that verifies+-- Firebase ID tokens from the @Authorization: Bearer \<token\>@ header.+--+-- @+-- import Firebase.Auth (newTlsKeyCache, defaultFirebaseConfig)+-- import Firebase.Servant (firebaseAuthHandler)+-- import Servant.Server (Context (..))+--+-- main :: IO ()+-- main = do+--   cache <- newTlsKeyCache+--   let cfg     = defaultFirebaseConfig \"my-project-id\"+--       ctx     = firebaseAuthHandler cache cfg :. EmptyContext+--   runSettings defaultSettings (serveWithContext api ctx server)+-- @+module Firebase.Servant+  ( -- * Auth Handler+    firebaseAuthHandler,++    -- * Helpers (pure, testable)+    extractBearerToken,+    authErrorToBody,+  )+where++import Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Firebase.Auth (verifyIdTokenCached)+import Firebase.Auth.Types (AuthError (..), FirebaseConfig, FirebaseUser, KeyCache)+import Network.Wai (Request, requestHeaders)+import Servant.Server (Handler, err401, errBody, throwError)+import Servant.Server.Experimental.Auth (AuthHandler, mkAuthHandler)++-- ---------------------------------------------------------------------------+-- Constants+-- ---------------------------------------------------------------------------++-- | The @\"Bearer \"@ prefix length (7 bytes).+bearerPrefixLen :: Int+bearerPrefixLen = 7++-- ---------------------------------------------------------------------------+-- Auth Handler+-- ---------------------------------------------------------------------------++-- | Create a Servant 'AuthHandler' that verifies Firebase ID tokens.+--+-- Extracts the Bearer token from the @Authorization@ header, verifies it+-- 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.+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++-- | Convert an 'AuthError' to a safe response message.+--+-- 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"

@@ -0,0 +1,477 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import qualified Data.Aeson as Aeson+import Data.Function ((&))+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust)+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.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,+        -- Firestore: Transaction options encoding+        test "ReadWrite transaction options encode" testReadWriteEncode,+        test "RetryWith transaction options encode" testRetryWithEncode,+        test "ReadOnly transaction options encode" testReadOnlyEncode,+        -- 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++assertBool :: String -> Bool -> IO Bool+assertBool _ True = pure True+assertBool label False = do+  putStrLn ("    " ++ label ++ ": expected True")+  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))+      decoded = Aeson.decode (Aeson.encode q) :: Maybe Aeson.Value+   in assertBool "has fieldFilter" (isJust decoded)++testQueryWithOrderByLimit :: IO Bool+testQueryWithOrderByLimit =+  let q =+        encodeQuery $+          query (CollectionPath "users")+            & orderBy "name" Ascending+            & limit 25+      decoded = Aeson.decode (Aeson.encode q) :: Maybe Aeson.Value+   in assertBool "has orderBy and limit" (isJust decoded)++testQueryCompositeAnd :: IO Bool+testQueryCompositeAnd =+  let q =+        encodeQuery $+          query (CollectionPath "users")+            & where_+              ( compositeAnd+                  [ fieldFilter "age" OpGreaterThan (IntegerValue 18),+                    fieldFilter "active" OpEqual (BoolValue True)+                  ]+              )+      decoded = Aeson.decode (Aeson.encode q) :: Maybe Aeson.Value+   in assertBool "has compositeFilter" (isJust decoded)++-- ---------------------------------------------------------------------------+-- 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"