diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/firestore.cabal b/firestore.cabal new file mode 100644 --- /dev/null +++ b/firestore.cabal @@ -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. +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 diff --git a/src/Database/Firestore.hs b/src/Database/Firestore.hs new file mode 100644 --- /dev/null +++ b/src/Database/Firestore.hs @@ -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 diff --git a/src/Database/Firestore/Internal.hs b/src/Database/Firestore/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/Firestore/Internal.hs @@ -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) + ) diff --git a/src/Database/Firestore/Types.hs b/src/Database/Firestore/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Firestore/Types.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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'