firestore (empty) → 0.1.0.0
raw patch · 8 files changed
+533/−0 lines, 8 filesdep +QuickCheckdep +aesondep +aeson-prettysetup-changed
Dependencies added: QuickCheck, aeson, aeson-pretty, base, bytestring, firestore, generic-random, gogol, gogol-firestore, http-types, lens, lens-aeson, quickcheck-instances, resourcet, text, time, unordered-containers, vector
Files
- LICENSE +30/−0
- README.md +7/−0
- Setup.hs +2/−0
- firestore.cabal +156/−0
- src/Database/Firestore.hs +104/−0
- src/Database/Firestore/Internal.hs +72/−0
- src/Database/Firestore/Types.hs +89/−0
- test/Main.hs +73/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,7 @@+# firestore++This is an arguably convenient wrapper around `gogol`'s `Network.Google.FireStore`. This is likely not the idiomatic or best API for Google Firestore/Datastore/Firebase. I don't even understand the difference between all of those trademarks. Bug reports and suggestions are welcome.++It's created to avoid working with `Gogol` directly, which is awesome, but begs for a little wrapper. It also tries to add some checks that Gogol's types don't really express.++I have plans to evolve this somehow, but that's what I needed for now. Suggestions and feedback is always welcome.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ firestore.cabal view
@@ -0,0 +1,156 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: firestore+version: 0.1.0.0+synopsis: Wrapper for Google Firestore/Datastore API+description: This is an arguably convenient wrapper around gogols `Network.Google.FireStore`. This is likely not the idiomatic or best API for Google Firestore/Datastore/Firebase. I don't even understand the difference between all of those trademarks. Bug reports and suggestions are welcome. <https://github.com/valyagolev/firestore>+category: Database, Google+homepage: https://github.com/valyagolev/firestore#readme+bug-reports: https://github.com/valyagolev/firestore/issues+author: Valentin Golev+maintainer: v.golev@gmail.com+copyright: 2021 Valentin Golev+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/valyagolev/firestore++library+ exposed-modules:+ Database.Firestore+ Database.Firestore.Internal+ Database.Firestore.Types+ other-modules:+ Paths_firestore+ hs-source-dirs:+ src+ default-extensions:+ EmptyCase+ PostfixOperators+ TupleSections+ NamedFieldPuns+ BangPatterns+ BinaryLiterals+ HexFloatLiterals+ NumericUnderscores+ GADTSyntax+ RankNTypes+ TypeApplications+ PolyKinds+ ExistentialQuantification+ TypeOperators+ ConstraintKinds+ ExplicitForAll+ KindSignatures+ NamedWildCards+ ScopedTypeVariables+ FlexibleContexts+ FlexibleInstances+ MultiParamTypeClasses+ ConstrainedClassMethods+ InstanceSigs+ TypeSynonymInstances+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveTraversable+ StandaloneDeriving+ EmptyDataDeriving+ DeriveLift+ GeneralisedNewtypeDeriving+ DeriveGeneric+ OverloadedStrings+ LambdaCase+ RecordWildCards+ ghc-options: -fwarn-unused-imports+ build-depends:+ aeson >=1.5.6 && <1.6+ , base >=4.7 && <5+ , bytestring >=0.10.12 && <0.11+ , gogol >=0.5.0 && <0.6+ , gogol-firestore >=0.5.0 && <0.6+ , http-types >=0.12.3 && <0.13+ , lens >=4.19 && <5.1+ , lens-aeson >=1.1.1 && <1.2+ , resourcet >=1.2.4 && <1.3+ , text >=1.2.4 && <1.3+ , time >=1.9.3 && <1.10+ , unordered-containers >=0.2.14 && <0.3+ , vector >=0.12.3 && <0.13+ default-language: Haskell2010++test-suite firestore-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_firestore+ hs-source-dirs:+ test+ default-extensions:+ EmptyCase+ PostfixOperators+ TupleSections+ NamedFieldPuns+ BangPatterns+ BinaryLiterals+ HexFloatLiterals+ NumericUnderscores+ GADTSyntax+ RankNTypes+ TypeApplications+ PolyKinds+ ExistentialQuantification+ TypeOperators+ ConstraintKinds+ ExplicitForAll+ KindSignatures+ NamedWildCards+ ScopedTypeVariables+ FlexibleContexts+ FlexibleInstances+ MultiParamTypeClasses+ ConstrainedClassMethods+ InstanceSigs+ TypeSynonymInstances+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveTraversable+ StandaloneDeriving+ EmptyDataDeriving+ DeriveLift+ GeneralisedNewtypeDeriving+ DeriveGeneric+ OverloadedStrings+ LambdaCase+ RecordWildCards+ ghc-options: -fwarn-unused-imports -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , aeson >=1.5.6 && <1.6+ , aeson-pretty+ , base >=4.7 && <5+ , bytestring >=0.10.12 && <0.11+ , firestore+ , generic-random+ , gogol >=0.5.0 && <0.6+ , gogol-firestore >=0.5.0 && <0.6+ , http-types >=0.12.3 && <0.13+ , lens >=4.19 && <5.1+ , lens-aeson >=1.1.1 && <1.2+ , quickcheck-instances+ , resourcet >=1.2.4 && <1.3+ , text >=1.2.4 && <1.3+ , time >=1.9.3 && <1.10+ , unordered-containers >=0.2.14 && <0.3+ , vector >=0.12.3 && <0.13+ default-language: Haskell2010
+ src/Database/Firestore.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}++-- | This is an arguably convenient wrapper around gogol's `Network.Google.FireStore`. This is likely not the idiomatic or best API for Google Firestore\/Datastore\/Firebase. I don't even understand the difference between all of those trademarks. Bug reports and suggestions are welcome.+module Database.Firestore+ ( -- * The types+ Document (..),+ Value (..),+ FireStore,++ -- * Running `FireStore`+ runFireStore,+ defaultEnvironment,++ -- * CRUD+ listAllDocuments,+ patchDocument,++ -- * Other stuff++ -- | You can check out the docs for the additional types, as well as the lenses in the `Database.Firestore.Types` module:+ module Database.Firestore.Types,+ )+where++import Control.Lens ((&), (.~), (<&>), (^.))+import Control.Monad.Trans.Resource+-- import Data.Aeson+import Data.Data+import qualified Data.Text as Text+import Database.Firestore.Internal+import Database.Firestore.Types+import Network.Google (AllowScopes, HasEnv)+import qualified Network.Google as Google+import qualified Network.Google.Auth.Scope as Google+import qualified Network.Google.FireStore as FireStore+import System.IO (stderr)++-- | This initializes the the google environment with stderr logging, tls manager, and "application default" credentials. (@gcloud auth login@ on your local machine, or maybe @gcloud auth application-default login@, and it will also probably "just work" with the relevant service account (e.g. "compute") in the cloud). It will only have the scopes needed for FireStore (`FireStoreScope`).+--+-- This is just pure convenience.+--+-- > do+-- > env <- defaultEnvironment+-- > result <- runFireStore env "myproject" someFireStoreAction+defaultEnvironment :: IO (Google.Env FireStoreScope)+defaultEnvironment = do+ lgr <- Google.newLogger Google.Trace stderr+ mgr <- Google.newManager Google.tlsManagerSettings+ crd <- Google.getApplicationDefault mgr+ Google.newEnvWith crd lgr mgr <&> (Google.envScopes .~ Proxy @FireStoreScope)++-- | Runs the FireStore monad. It needs the env and the project name.+--+-- > runFireStore env "myproject" someFireStoreAction+runFireStore ::+ ( MonadUnliftIO m,+ HasEnv s env,+ AllowScopes s,+ Google.HasScope' s FireStoreScope ~ 'True+ ) =>+ env ->+ Text.Text ->+ FireStore a ->+ m a+runFireStore env project (FireStore _action) = runResourceT $ Google.runGoogle env (_action project)++listDocumentsOnePage :: Text.Text -> Maybe PageToken -> FireStore ([Document], Maybe PageToken)+listDocumentsOnePage collectionName np =+ do+ res <- FireStore $+ \projectName ->+ FireStore.projectsDatabasesDocumentsList+ ("projects/" <> projectName <> "/databases/(default)/documents/" <> collectionName)+ ""+ & FireStore.pPageToken .~ fmap _unPageToken np+ & Google.send+ return (map parseDocument $ res ^. FireStore.ldrDocuments, PageToken <$> res ^. FireStore.ldrNextPageToken)++-- | It only wants the collection name itself. In the language of the Google's resource identifiers,+-- this will get into @("projects\/" <> projectName <> "\/databases\/(default)\/documents\/" <> collectionName)@.+-- Apparently, @(default)@ is the actual real name of the only database you can have.+listAllDocuments :: Text.Text -> FireStore [Document]+listAllDocuments collectionName = getPage Nothing+ where+ getPage pt =+ do+ (res, np) <- listDocumentsOnePage collectionName pt+ case np of+ Nothing -> return res+ Just pt' -> (res ++) <$> getPage (Just pt')++patchDocument :: Text.Text -> Document -> FireStore Document+-- patchDocument (Document {name = Nothing}) = error "Can't patch a"+patchDocument path document =+ do+ res <- FireStore $+ \projectName ->+ FireStore.projectsDatabasesDocumentsPatch+ (buildDocument document)+ ("projects/" <> projectName <> "/databases/(default)/documents/" <> path)+ & Google.send++ return $ parseDocument res
+ src/Database/Firestore/Internal.hs view
@@ -0,0 +1,72 @@+module Database.Firestore.Internal where++import Control.Applicative (Applicative (liftA2))+import Control.Lens+import Control.Monad (join, msum)+import Data.Maybe (fromMaybe)+import Database.Firestore.Types+import qualified Network.Google.FireStore as FireStore++-- | This module is for the interaction with `gogol` stuff.++-- | There's a bug in gogol-firestore currently, apparently... that makes "nulls" slightly ambiguous. https://github.com/brendanhay/gogol/issues/170)+parseValue :: FireStore.Value -> Value+parseValue v =+ fromMaybe+ -- (Unknown $ Text.pack $ show v)+ Null+ $ msum+ [ liftA2 GeoPoint (join $ v ^? (FireStore.vGeoPointValue . _Just . FireStore.llLatitude)) (join $ v ^? (FireStore.vGeoPointValue . _Just . FireStore.llLongitude)),+ Bytes <$> v ^. FireStore.vBytesValue,+ Int . fromIntegral <$> v ^. FireStore.vIntegerValue,+ Timestamp <$> v ^. FireStore.vTimestampValue,+ Double <$> v ^. FireStore.vDoubleValue,+ String <$> v ^. FireStore.vStringValue,+ Bool <$> v ^. FireStore.vBooleanValue,+ Map . fmap parseValue+ <$> v ^? (FireStore.vMapValue . _Just . FireStore.mvFields . _Just . FireStore.mvfAddtional),+ Array . map parseValue <$> v ^? (FireStore.vArrayValue . _Just . FireStore.avValues),+ Reference <$> v ^. FireStore.vReferenceValue,+ Null <$ v ^. FireStore.vNullValue+ ]++buildValue :: Value -> FireStore.Value+buildValue v =+ FireStore.value+ & FireStore.vGeoPointValue+ .~ ( ( \(lat, lng) ->+ FireStore.latLng+ & FireStore.llLatitude ?~ lat+ & FireStore.llLongitude ?~ lng+ )+ <$> v+ ^? _GeoPoint+ )+ & FireStore.vBytesValue .~ (v ^? _Bytes)+ & FireStore.vIntegerValue .~ (fromIntegral <$> v ^? _Int)+ & FireStore.vTimestampValue .~ (v ^? _Timestamp)+ & FireStore.vDoubleValue .~ (v ^? _Double)+ & FireStore.vStringValue .~ (v ^? _String)+ & FireStore.vBooleanValue .~ (v ^? _Bool)+ & FireStore.vMapValue+ .~ ( (\v -> FireStore.mapValue & FireStore.mvFields ?~ FireStore.mapValueFields v) . fmap buildValue <$> v ^? _Map+ )+ & FireStore.vArrayValue .~ ((\v -> FireStore.arrayValue & FireStore.avValues .~ v) . map buildValue <$> v ^? _Array)+ & FireStore.vReferenceValue .~ (v ^? _Reference)+ & FireStore.vNullValue .~ (FireStore.NullValue <$ v ^? _Null)++parseDocument :: FireStore.Document -> Document+parseDocument d =+ Document+ (d ^. FireStore.dName)+ (d ^. FireStore.dCreateTime)+ (d ^. FireStore.dUpdateTime)+ (parseValue <$> d ^. FireStore.dFields . _Just . FireStore.dfAddtional)++buildDocument :: Document -> FireStore.Document+buildDocument (Document {name, fields}) =+ FireStore.document+ & FireStore.dName .~ name+ & FireStore.dFields+ ?~ ( FireStore.documentFields (fmap buildValue fields)+ )
+ src/Database/Firestore/Types.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Firestore.Types where++import Control.Lens (makePrisms)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Aeson (ToJSON (..))+import qualified Data.ByteString as BS+import qualified Data.HashMap.Strict as HM+import Data.Text (Text)+import Data.Time (UTCTime)+import GHC.Generics+import Network.Google (MonadGoogle)+import qualified Network.Google.Auth.Scope as Google++type FireStoreScope = '["https://www.googleapis.com/auth/cloud-platform", "https://www.googleapis.com/auth/datastore"]++data Document = Document+ { -- | Don't set it if you want FireStore to generate it for you+ name :: Maybe Text,+ createTime :: Maybe UTCTime,+ updateTime :: Maybe UTCTime,+ fields :: HM.HashMap Text Value+ }+ deriving (Show, Eq, Generic)++data Value+ = GeoPoint Double Double+ | Bytes BS.ByteString+ | Int Integer+ | Timestamp UTCTime+ | Double Double+ | String Text+ | Bool Bool+ | Map (HM.HashMap Text Value)+ | Array [Value]+ | Reference Text+ | Null+ -- Unknown Text+ deriving (Show, Eq, Generic)++makePrisms ''Value++instance ToJSON Value where+ toJSON (GeoPoint lat long) = toJSON [lat, long]+ toJSON (Bytes bs) = toJSON (show bs)+ toJSON (Int i) = toJSON i+ toJSON (Timestamp t) = toJSON t+ toJSON (Double d) = toJSON d+ toJSON (String t) = toJSON t+ toJSON (Bool b) = toJSON b+ toJSON (Map m) = toJSON m+ toJSON (Array xs) = toJSON xs+ toJSON (Reference t) = toJSON t+ toJSON Null = toJSON (Nothing :: Maybe ())++-- toJSON (Unknown v) = toJSON (show v)++instance ToJSON Document++-- | This is just a convenience monad that allows one to avoid all the gogol machinery.+newtype FireStore a = FireStore+ { _action :: Text -> forall m s. (Monad m, MonadGoogle s m, Google.HasScope' s FireStoreScope ~ True) => m a+ }+ deriving (Functor)++instance Applicative FireStore where+ pure a = FireStore $ const $ return a+ FireStore f <*> FireStore a = FireStore $ \projectName -> f projectName <*> a projectName++instance Monad FireStore where+ FireStore f >>= g = FireStore $ \projectName ->+ do+ f' <- f projectName+ _action (g f') projectName++instance MonadIO FireStore where+ liftIO a = FireStore $ const (liftIO a)++newtype PageToken = PageToken {_unPageToken :: Text}+ deriving (Show)
+ test/Main.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}++module Main where++import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Aeson.Encode.Pretty+import qualified Data.ByteString.Lazy.Char8 as BS+import qualified Data.HashMap.Internal.Strict as HM+import qualified Data.HashMap.Strict as HS+import Data.Text (Text)+import Database.Firestore+import Database.Firestore.Internal+import Debug.Trace (trace, traceId, traceShow, traceShowId)+import GHC.Generics (Generic)+import Generic.Random+import qualified Network.Google.FireStore.Types as FireStore+import System.IO.Unsafe (unsafePerformIO)+import System.Timeout (timeout)+import Test.QuickCheck+import Test.QuickCheck.Arbitrary (Arbitrary)+import Test.QuickCheck.Instances.ByteString+import Test.QuickCheck.Instances.Text ()+import Test.QuickCheck.Instances.Time+import Test.QuickCheck.Instances.UnorderedContainers++-- import++realTest :: IO ()+realTest = do+ env <- defaultEnvironment+ runFireStore env "carboncopy" $ do+ docs <- listAllDocuments "rss_subscriptions"+ -- (docs, _) <- listDocumentsOnePage "rss_subscriptions" Nothing -- :: IO (Result ([BotUser], Maybe NextPage))+ liftIO $ do+ print "---"+ BS.putStrLn $ encodePretty $ head docs+ print "---"+ print $ length docs+ BS.writeFile "test.json" $ encodePretty $ docs++-- instance Arbitrary (HS.HashMap Text Value) where+-- arbitrary = HS.fromList <$> arbitrary+-- shrink m = HS.fromList <$> shrink (HS.toList m)++-- instance Arbitrary FireStore.Value where+-- arbitrary = genericArbitraryRec uniform+-- shrink = genericShrink++instance Arbitrary Value where+ -- fixme+ arbitrary = genericArbitraryRec uniform `withBaseCase` (String <$> arbitrary)+ shrink = genericShrink++prop_roundtrip_value v = parseValue (buildValue v) == v++prop_roundtrip_value' v = buildValue (parseValue v) == v++main :: IO ()+main =+ do+ -- print "1"+ -- print $ parseValue $ FireStore.value+ -- print "2"++ -- print $ Array [Map (HM.fromList [("", GeoPoint 0.0 0.0)])]+ -- print $ parseValue . buildValue $ Array [Map (HM.fromList [("", GeoPoint 0.0 0.0)])]+ quickCheckWith (stdArgs {maxSize = 10}) $ prop_roundtrip_value+ realTest++-- quickCheck $ prop_roundtrip_value'