firebase-database (empty) → 0.0.1
raw patch · 10 files changed
+923/−0 lines, 10 filesdep +HsOpenSSLdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HsOpenSSL, QuickCheck, aeson, attoparsec, base, bytestring, criterion, generic-random, hspec, http-client, http-client-tls, http-streams, http-types, io-streams, lens, mtl, nano-http, split, string-conversions, text, unordered-containers
Files
- ChangeLog.md +1/−0
- LICENSE +29/−0
- Setup.hs +2/−0
- benchmark/Bench.hs +9/−0
- firebase-database.cabal +89/−0
- src/Network/Google/Firebase.hs +122/−0
- src/Network/Google/Firebase/Events.hs +239/−0
- src/Network/Google/Firebase/Types.hs +296/−0
- src/Network/Google/Firebase/Util.hs +135/−0
- test/Spec.hs +1/−0
+ ChangeLog.md view
@@ -0,0 +1,1 @@+* 0.0.1 - Initial release.
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2018, nghamilton+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 the copyright holder nor the names of its+ 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 HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmark/Bench.hs view
@@ -0,0 +1,9 @@+module Main (main) where++import Criterion.Main (bgroup, defaultMain)+import qualified MainBench++main :: IO ()+main = defaultMain+ [ bgroup "API" HuskBench.benchmarks+ ]
+ firebase-database.cabal view
@@ -0,0 +1,89 @@+name: firebase-database+version: 0.0.1+synopsis: Google Firebase Database SDK+license: OtherLicense+license-file: LICENSE+author: Nick Hamilton+maintainer: Nick Hamilton <projects@nickhamilton.ninja>+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10+copyright: (c) 2018 Nick Hamilton +homepage: https://github.com/nghamilton/firebase-database+bug-reports: https://github.com/nghamilton/firebase-database/issues+stability: alpha+category: Network, Google, Cloud, Database+description:+ SDK for connecting to Google's Firebase Database, using Firebase REST endpoints. + .+ Uses Server-Sent Events (SSE) protocol to receive real-time updates from the Firebase server.++source-repository head+ type: git+ location: git://github.com/nghamilton/firebase-database.git++library+ default-extensions: OverloadedStrings+ , DuplicateRecordFields+ exposed-modules: Network.Google.Firebase,Network.Google.Firebase.Events+ other-modules: Network.Google.Firebase.Util,Network.Google.Firebase.Types+ ghc-options: -Wall+ build-depends: base >=4.8 && <5+ , generic-random == 0.4.1.0+ , http-streams == 0.8.5.3+ , io-streams >= 1.4.0.0 && < 1.5+ , http-client == 0.5.7.0+ , http-client-tls == 0.3.5.1+ , HsOpenSSL == 0.11.4.9+ , http-types == 0.9.1+ , aeson == 1.0.2.1+ , attoparsec == 0.13.1.0+ , text == 1.2.2.1+ , bytestring == 0.10.8.1+ , string-conversions == 0.4.0.1+ , unordered-containers == 0.2.8.0+ , lens == 4.15.1+ , mtl == 2.2.1+ , nano-http == 0.1.3+ , split == 0.2.3.2+ hs-source-dirs: src,test+ default-language: Haskell2010++test-suite tests+ default-extensions: OverloadedStrings+ , DuplicateRecordFields+ ghc-options: + type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: src,test+ other-modules: + build-depends: base >= 4.8 && < 5+ , hspec == 2.4.3+ , QuickCheck == 2.9.2+ , generic-random == 0.4.1.0+ , http-streams == 0.8.5.3+ , io-streams >= 1.4.0.0 && < 1.5+ , http-client == 0.5.7.0+ , http-client-tls == 0.3.5.1+ , HsOpenSSL == 0.11.4.9+ , http-types == 0.9.1+ , aeson == 1.0.2.1+ , attoparsec == 0.13.1.0+ , text == 1.2.2.1+ , bytestring == 0.10.8.1+ , string-conversions == 0.4.0.1+ , unordered-containers == 0.2.8.0+ , lens == 4.15.1+ , mtl == 2.2.1+ , nano-http == 0.1.3+ , split == 0.2.3.2+ default-language: Haskell2010++benchmark criterion+ default-extensions: OverloadedStrings+ type: exitcode-stdio-1.0+ main-is: Bench.hs+ hs-source-dirs: src,test,benchmark+ build-depends: base >= 4.8 && < 5+ , criterion+ default-language: Haskell2010
+ src/Network/Google/Firebase.hs view
@@ -0,0 +1,122 @@+-- Copyright Ralph Morton (c) 2016++-- 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 Ralph Morton 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.++{-# LANGUAGE TupleSections #-}++module Network.Google.Firebase(+ module Network.Google.Firebase.Types,+ query,+ key,+ get,+ put,+ post,+ patch,+ delete,+ sendMessage,+ getRules,+ setRules+) where++import Network.Google.Firebase.Types hiding (PUT,DELETE)++import Control.Applicative ((<$>))+import Control.Lens (view)+import Data.Aeson (FromJSON, ToJSON, encode)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.List (intercalate)+import Data.Maybe (catMaybes)+import Network.HTTP.Nano+import Network.HTTP.Types.URI (urlEncode)++query :: Query+query = Query Nothing Nothing Nothing Nothing++key :: ToJSON a => a -> Key+key = Key++get :: (FbHttpM m e r, HasFirebase r, FromJSON a) => Location -> Maybe Query -> m a+get loc mq = httpJSON =<< fbReq GET loc NoRequestData mq++put :: (FbHttpM m e r, HasFirebase r, ToJSON a) => Location -> a -> m ()+put loc dta = http' =<< fbReq PUT loc (mkJSONData dta) Nothing++post :: (FbHttpM m e r, HasFirebase r, ToJSON a) => Location -> a -> m FBID+post loc dta = unName <$> (httpJSON =<< fbReq POST loc (mkJSONData dta) Nothing)++patch :: (FbHttpM m e r, HasFirebase r, ToJSON a) => Location -> a -> m ()+patch loc dta = http' =<< fbReq (CustomMethod "PATCH") loc (mkJSONData dta) Nothing++delete :: (FbHttpM m e r, HasFirebase r) => Location -> m ()+delete loc = http' =<< fbReq DELETE loc NoRequestData Nothing++sendMessage :: (FbHttpM m e r, HasFirebase r, ToJSON a) => Message a -> m ()+sendMessage msg = do+ req <- buildReq POST googleCloudEndpoint (mkJSONData msg)+ apiKey <- view firebaseToken+ let req' = addHeaders [json, auth apiKey] req+ http' req'+ where+ json = ("Content-Type", "application/json")+ auth t = ("Authorization", "key=" ++ t)+ googleCloudEndpoint = "https://fcm.googleapis.com/fcm/send"++getRules :: (FbHttpM m e r, HasFirebase r, FromJSON a) => m a+getRules = httpJSON =<< fbReq GET ".settings/rules" NoRequestData Nothing++setRules :: (FbHttpM m e r, HasFirebase r, ToJSON a) => a -> m ()+setRules dta = http' =<< fbReq PUT ".settings/rules" (mkJSONData dta) Nothing++fbReq :: (FbHttpM m e r, HasFirebase r) => HttpMethod -> Location -> RequestData -> Maybe Query -> m Request+fbReq mthd loc dta mq = do+ baseURL <- view firebaseURL+ token <- view firebaseToken+ let qstr = maybe "" buildQuery mq+ let url = baseURL ++ loc ++ ".json?auth=" ++ token ++ "&" ++ qstr+ buildReq mthd url dta++buildQuery :: Query -> String+buildQuery q = intercalate "&" . fmap (uncurry toParam) $ catMaybes [orderByQ, startAtQ, endAtQ, limitQ $ limit q]+ where+ orderByQ = ("orderBy",) . show <$> orderBy q+ startAtQ = ("startAt",) . encodeK <$> startAt q+ endAtQ = ("endAt",) . encodeK <$> endAt q+ limitQ Nothing = Nothing+ limitQ (Just (LimitToFirst l)) = Just ("limitToFirst", show l)+ limitQ (Just (LimitToLast l)) = Just ("limitToLast", show l)++encodeK :: Key -> String+encodeK (Key a) = BL.unpack $ encode a++toParam :: String -> String -> String+toParam k v = k ++ "=" ++ (B.unpack . urlEncode False $ B.pack v)++---- end (c) Ralph Morton
+ src/Network/Google/Firebase/Events.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language ScopedTypeVariables #-}+{-# language TypeFamilies #-}++module Network.Google.Firebase.Events where++import Network.Google.Firebase as FB+import Network.Google.Firebase.Types+import Network.Google.Firebase.Util++import System.IO.Streams.Attoparsec.ByteString+import Control.Applicative+import Data.ByteString+import qualified Data.Attoparsec.ByteString.Char8 as AC+import qualified Data.Attoparsec.ByteString as AB+import Data.ByteString.Char8 as BSC (putStrLn)+import System.IO.Streams as Streams+import Control.Monad as M+import Data.Aeson+import Data.String.Conversions+import Data.Maybe+import qualified Data.List as L hiding (lookup)+import Network.Http.Client hiding (PUT, PATCH, DELETE)+import OpenSSL+import Control.Concurrent+import qualified Data.HashMap.Lazy as HM+import Data.List.Split+import GHC.TypeLits++-- connect to firebase server over https, and convert the event-stream to a Stream, saving it in the state+listen+ :: (KnownSymbol (FirebaseContext t), FirebaseData t)+ => String -> String -> FireState t -> IO ()+listen fbServer fbDataKey st =+ withOpenSSL $+ do ctx <- baselineContextSSL+ let loc = fbCtxFromState st ++ ".json?auth="+ logD $ cs $ "Listening on firebase location for updates: " <> loc+ withConnection (openConnectionSSL ctx (cs $ fbServer) 443) $+ (\c -> do+ let q =+ buildRequest1 $+ do http GET (cs $ loc ++ fbDataKey) >>+ setAccept "text/event-stream"+ sendRequest c q emptyBody+ receiveResponse+ c+ (\_ stream+ -- transform the stream into a stream of our desired FirebaseData type, and read an event+ -> do+ stream' <- transformStream stream+ -- fetch data for any UPDATE events in the stream and save to the state+ _ <- Streams.mapM_ (\t -> runF fbServer fbDataKey (fetchUpdates loc t)) stream'+ let loop = do+ mEvnt :: Maybe (Event t) <- Streams.read stream'+ case mEvnt of+ Just (Event {action = act+ ,id = i+ ,item = itm})+ -- update the database with the given event+ -> do+ updateDb st i itm+ logRecordUpdate act itm+ loop+ Just (INVALID msg) ->+ logW ("Invalid event encountered: " <> cs msg) >> loop+ Nothing -> logW "Nothing encountered in stream. EOS."+ loop))+ logW "Firebase connection closed."++updateDb+ :: FirebaseData t+ => FireState t -> FbId -> Maybe t -> IO ()+updateDb (FireState m) i Nothing = modifyMVar_ m (return . HM.delete i)+updateDb (FireState m) i (Just itm) = modifyMVar_ m (return . HM.insert i itm)++logRecordUpdate+ :: FirebaseData t+ => DataChangeType -> Maybe t -> IO ()+logRecordUpdate act itm = logD $ cs $ show itm ++ " (" ++ show act ++ ")"++-- run the parser over the bytestring stream from the server+-- nb: the Stream ByteSting returns 'chunks' that appear to correspond directly to actions+-- ... which makes the conversion from one stream to the other a little unnecessary, but safer?+transformStream+ :: FirebaseData t+ => InputStream ByteString -> IO (InputStream (Event t))+transformStream i =+ bytesToStreamEvents i >>= streamEventsToDataEvents >>= Streams.concatLists++-- logStreamData >>=+logStreamData :: InputStream ByteString -> IO ()+logStreamData i = Streams.peek i >>= (maybe (return ()) BSC.putStrLn)++-- converts byte stream into raw stream-event event types+bytesToStreamEvents+ :: FirebaseData t+ => InputStream ByteString -> IO (InputStream (StreamEvent t))+bytesToStreamEvents i = logStreamData i >> parserToInputStream parser i+ where+ parser = (AC.endOfInput >> pure Nothing) <|> pStreamEvent++-- converts raw stream-event event types into our data events (add/delete/update)+streamEventsToDataEvents+ :: FirebaseData t+ => InputStream (StreamEvent t) -> IO (InputStream [Event t])+streamEventsToDataEvents = Streams.map streamEventToDataEvent++-- need to get the latest data for any update event on an item+fetchUpdates+ :: (FbHttpM m e r, HasFirebase r, FirebaseData t)+ => String -> Event t -> m (Event t)+fetchUpdates _ e@(INVALID _) = return e+fetchUpdates loc evnt =+ case action evnt of+ UPDATE -> do+ itm <- FB.get loc Nothing+ return $+ evnt+ { item = Just itm+ }+ _ -> return evnt++streamEventToDataEvent+ :: FirebaseData t+ => StreamEvent t -> [Event t]+streamEventToDataEvent e =+ case streamEventType e of+ KEEP_ALIVE -> []+ CANCEL -> []+ AUTH_REVOKED -> []+ PUT -> convertFromStreamEvent' $ streamEventData e+ PATCH -> convertFromStreamEvent' $ streamEventData e+ where+ convertFromStreamEvent' (Right eventData) =+ convertFromStreamEvent+ (changeAction eventData)+ (changedData eventData) $+ path eventData+ convertFromStreamEvent' (Left err) =+ [ INVALID $+ "Event stream conversion of data, no event able to be produced: " <>+ (cs $ show err)+ ] -- Invalid condition, should only happen in PUT/PATCH msg if we have a stream corruption++-- stream events can contain a list of changed locations, and the action performed on them+convertFromStreamEvent+ :: FirebaseData t+ => DataChangeType+ -> Maybe (HM.HashMap FB.Location t)+ -> FB.Location+ -> [Event t]+convertFromStreamEvent act (Just ts) _ = L.map conv $ HM.toList ts+ where+ conv (loc, itm) =+ if validId -- for data security, getId of item must match the path being fetched+ then Event+ { action = act+ , id = locId+ , item = convertedItem+ }+ else INVALID $+ "Attempt to use invalid ID to update item:" <> (cs $ show loc) <>+ " (" <>+ (cs $ show act) <>+ ")"+ where+ mloc = idFromLoc loc+ validId = isJust mloc+ locId = fromJust mloc+ convertedItem =+ case act of+ ADD -> Just $ setId itm locId -- only ADD events have data available at this stage+ _ -> Nothing -- todo impl updates and other events+convertFromStreamEvent act Nothing loc -- No data supplied in the stream means it could be either UPDATE or DELETE+ =+ if validId+ then [ Event+ { action = act+ , id = locId+ , item = Nothing -- updated data needs to be retrieved manually from this location.. todo or can use generics here?+ }+ ]+ else [ INVALID $+ "Attempt to use invalid ID to update item:" <> (cs $ show loc) <>+ " (" <>+ (cs $ show act) <>+ ")"+ ]+ where+ mloc = idFromLoc loc+ validId = isJust mloc+ locId = fromJust mloc++idFromLoc :: FB.Location -> Maybe FbId+idFromLoc = (cs <$>) . headSafe . wordsBy (== '/')+ where+ headSafe [] = Nothing+ headSafe xs = Just $ L.head xs++-- Streams can have multiple stream events: put/patch/cancel/etc+pStreamEvent+ :: forall t.+ FirebaseData t+ => AB.Parser (Maybe (StreamEvent t))+pStreamEvent = do+ _ <- AC.string "event: "+ event <- pEventType+ AC.endOfLine+ _ <- AC.string "data: "+ edata <- pStreamEventData+ AC.endOfLine+ AC.endOfLine+ return $ Just $ StreamEvent event edata++pEventType :: AB.Parser StreamEventType+pEventType = do+ c <- AB.takeTill AC.isEndOfLine+ case c of+ "put" -> return PUT+ "patch" -> return PATCH+ "keep-alive" -> return KEEP_ALIVE+ "cancel" -> return CANCEL+ "auth_revoked" -> return AUTH_REVOKED+ _ -> mzero++-- The json decode will return a StreamEvent (with a Just t, or Left String if it was an error)+-- It will fail with an error if the 'data' element couldn't be parsed, ie if the data field was not a t or a null+-- ... this can happen if it was either a field name that was updated (not a whole data item) or a keep-alive+-- ... or if the app is writing data that doesn't conform to the backend (i.e missing fields, etc)+pStreamEventData+ :: forall t.+ (FromJSON t, FirebaseData t)+ => AB.Parser (Either String (StreamEventData t))+pStreamEventData = eitherDecodeStrict <$> AB.takeTill AC.isEndOfLine
+ src/Network/Google/Firebase/Types.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ConstraintKinds #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language ScopedTypeVariables #-}+{-# language TypeFamilies #-}++module Network.Google.Firebase.Types where++import Data.Aeson.Types+import Network.HTTP.Nano hiding (DELETE)+import Data.Text+import Data.String.Conversions+import GHC.Generics hiding (to)+import Data.HashMap.Lazy as HashMap+import Control.Applicative as Ap+import Data.Maybe+import Data.List.Split+import qualified Data.List as L+import Control.Concurrent+import Control.Applicative ((<$>))+import Control.Lens.TH+import Control.Monad (mzero)+import Control.Monad.Reader (MonadReader)+import Control.Monad.Except (MonadError)+import Control.Monad.Trans (MonadIO)+import qualified Data.Text.Internal as T+import Data.Proxy+import GHC.TypeLits++type family FirebaseContext a :: Symbol++class (Show a, ToJSON a, FromJSON a, KnownSymbol (FirebaseContext a)) =>+ FirebaseData a where+ getId :: a -> Maybe FirebaseId+ setId :: a -> Text -> a+ genId :: a -> IO (Maybe FirebaseId)+ fbLoc :: a -> Maybe Location+ fbCtx :: a -> Location+ getId _ = Nothing+ fbCtx _ = symbolVal (Proxy::Proxy (FirebaseContext a))+ fbLoc a = (fbCtx a <>) . cs <$> getId a++type FirebaseId = Text++data (FirebaseData t, Show t) =>+ Event t+ = Event { action :: DataChangeType+ , id :: Text+ , item :: Maybe t}+ | INVALID {reason::Text}+ deriving (Show)++data FirebaseData t =>+ StreamEvent t = StreamEvent+ { streamEventType :: StreamEventType+ , streamEventData :: Either String (StreamEventData t)+ } deriving (Show, Eq)++data StreamEventType+ = PUT+ | PATCH+ | KEEP_ALIVE+ | CANCEL+ | AUTH_REVOKED+ deriving (Show, Eq)++data FirebaseData t =>+ StreamEventData t = StreamEventData+ { path :: Location+ , changedData :: Maybe (HashMap Location t)+ , changeAction :: DataChangeType+ } deriving (Show, Eq)++data DataChangeType+ = ADD+ | DELETE+ | UPDATE+ deriving (Show, Generic, Eq)++type FbId = Text++type FireMap t = HashMap FbId t++data FirebaseData t =>+ FireState t =+ FireState (MVar (FireMap t))++instance ToJSON (Event t) where+ toJSON _ = Null++instance FromJSON (Event t) where+ parseJSON _ = Ap.empty++instance ToJSON DataChangeType++instance FromJSON DataChangeType++instance FirebaseData t =>+ FromJSON (StreamEventData t) where+ parseJSON (Object v) = pAddOne v <|> pAddAll v <|> pUpdateOrDelete v+ --parseJSON (Object v) = testp v+ parseJSON _ = Ap.empty++pAddOne :: FirebaseData t => Object -> Parser (StreamEventData t)+--pAddOne v | trace (show v) False = undefined+pAddOne v = do+ p <- v .: "path"+ itm :: t <- v .: "data"+ -- if the parse was successful, it was a single new item added+ return+ StreamEventData+ { path = p+ , changedData = mkData itm+ , changeAction = ADD+ } where+ mkData d = Just $ fromList $ L.map (\(i,d')->(cs $ fromJust i,d')) $ L.filter (\(i,_)->isJust i) [(getId d, d)]++pAddAll :: FirebaseData t => Object -> Parser (StreamEventData t)+--pAddAll v | trace (show v) False = undefined+pAddAll v = do+ p <- v .: "path"+ ds :: HashMap Location t <- v .: "data"+ -- if the parse was successful, it was multiple new data items added+ return+ StreamEventData+ { path = p+ , changedData = Just ds+ , changeAction = ADD+ }++pUpdateOrDelete :: FirebaseData t => Object -> Parser (StreamEventData t)+--pUpdateOrDelete v | trace (show v) False = undefined+pUpdateOrDelete v = do+ p <- v .: "path"+ mt :: Maybe Text <- v .: "data"+ -- if the parse was successful, it means it is a path to an updated field+ if isJust mt+ then return+ StreamEventData+ { path = p+ , changedData = Nothing+ , changeAction = UPDATE+ }+ -- otherwise it was a 'null' in the data+ else+ if isFieldDelete p+ -- if the path is in the form of /x/y/ then it is a field delete in an item+ -- .... so we need to request an item update+ then return+ StreamEventData+ { path = p+ , changedData = Nothing+ , changeAction = UPDATE+ }+ else return+ StreamEventData+ { path = p+ , changedData = Nothing+ , changeAction = DELETE+ }+ where+ isFieldDelete p = L.length (wordsBy (== '/') p) >= 2++data FirebaseError = CommsError String | InvalidLocation+ deriving (Show, Generic, Eq)++-- todo - create new method to accumulate error messages between alternative parser attempts so if the last parser fails it will return all error messages (i.e all Lefts concat'ed)+-- (<|>) :: Parser a -> Parser a -> Parser a+-- (<|>) p q = Parser $ \s ->+-- case parse p s of+-- [] -> parse q s+-- res -> res++-- testp :: FirebaseData t => Object -> Parser (StreamEventData t)+-- testp v = do+-- eres :: StreamEventData t <- pAddOne v+-- case eres of+-- Right res -> return $ Right res+-- Left e -> do+-- eres2 :: StreamEventData t <- pAddAll v+-- case eres2 of+-- Right res2 -> return $ Right res2+-- Left e2 -> do+-- eres3 :: StreamEventData t <- pUpdateOrDelete v+-- case eres3 of+-- Right res3 -> return $ Right res3+-- Left e3 -> return $ Left "EventData parse failed all data types: "<>e<>", "<>e2<>","<>e3+++--- Code below copyright: Copyright Ralph Morton (c) 2016++-- 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 Ralph Morton 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.++type Location = String+type FBID = String+type FbHttpM m e r = (MonadIO m, MonadError e m, MonadReader r m, AsHttpError e, HasHttpCfg r)++data Firebase = Firebase {+ _firebaseToken :: String,+ _firebaseURL :: String+}++-- |Representation of a Firebase name response to a POST+newtype Name = Name { unName :: String } deriving Show++instance FromJSON Name where+ parseJSON (Object v) = Name <$> v .: "name"+ parseJSON _ = mzero++data Query = Query {+ orderBy :: Maybe Location,+ startAt :: Maybe Key,+ endAt :: Maybe Key,+ limit :: Maybe Limit+}++data Message a = Message {+ to :: Maybe String,+ registrationIDs :: [String],+ collapseKey :: Maybe String,+ priority :: Priority,+ contentAvailable :: Maybe Bool,+ delayWhileIdle :: Maybe Bool,+ ttl :: Maybe Int,+ payload :: MessageBody a+}++instance ToJSON a => ToJSON (Message a) where+ toJSON Message {..} =+ omitNulls [ "to" .= toJSON to,+ "registration_ids" .= toJSON registrationIDs,+ "collapse_key" .= toJSON collapseKey,+ "priority" .= toJSON priority,+ "content_available" .= toJSON contentAvailable,+ "delay_while_idle" .= toJSON delayWhileIdle,+ "time_to_live" .= toJSON ttl,+ case payload of+ Notification x -> "notification" .= toJSON x+ Data x -> "data" .= toJSON x+ ]++data MessageBody a = Notification a | Data a++data Priority = Low | High++instance ToJSON Priority where+ toJSON Low = String "low"+ toJSON High = String "high"++data Limit = LimitToFirst Int | LimitToLast Int++data Key = forall a. ToJSON a => Key a++omitNulls :: [(T.Text, Value)] -> Value+omitNulls = object . L.filter notNull where+ notNull (_, Null) = False+ notNull _ = True++makeClassy ''Firebase+
+ src/Network/Google/Firebase/Util.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language ScopedTypeVariables #-}+{-# language TypeFamilies #-}++module Network.Google.Firebase.Util where++import Network.Google.Firebase.Types+import Network.Google.Firebase++import Prelude hiding (log)+import Data.String.Conversions+import System.IO+import Data.ByteString.Char8 as BS+import Control.Monad.Except+import Control.Monad.Reader+import Network.HTTP.Nano as Nano hiding (http, GET, PUT, PATCH)+import Control.Lens.Lens+import Data.Proxy+import GHC.TypeLits+import Data.HashMap.Lazy as HM+import Data.Aeson+import Control.Arrow++rightToMaybe :: Either b a -> Maybe a+rightToMaybe = either (const Nothing) Just++leftToMaybe :: Either b a -> Maybe b+leftToMaybe = either Just (const Nothing)++maybeToEither :: b -> Maybe a -> Either b a+maybeToEither _ (Just a) = Right a+maybeToEither b Nothing = Left b++log :: BS.ByteString -> BS.ByteString -> IO ()+log level d = BS.hPutStrLn stdout (level <> ": " <> d) >> hFlush stdout++logD :: ByteString -> IO ()+logD = log "DEBUG"++logI :: ByteString -> IO ()+logI = log "INFO"++logW :: ByteString -> IO ()+logW = log "WARN"++logE :: ByteString -> IO ()+logE = log "ERROR"++logWTF :: ByteString -> IO ()+logWTF = log "WTF"++fbCtxFromState :: forall a. KnownSymbol (FirebaseContext a) => FireState a -> String+fbCtxFromState _ = symbolVal (Proxy :: Proxy (FirebaseContext a))++fbEnv :: String -> String -> IO FBEnv+fbEnv url tok = do+ let fb = Firebase tok url+ mgr <- Nano.tlsManager+ let httpc = Nano.HttpCfg mgr+ return $ FBEnv fb httpc++fetch+ :: FirebaseData d+ => String -> String -> Maybe Location -> IO (Either FirebaseError d)+fetch _ _ Nothing = return $ Left InvalidLocation+fetch url tok (Just loc) = (fixError <$>) $ (runF url tok) $ get loc Nothing++persist+ :: (ToJSON d, FirebaseData d, Show d)+ => String -> String -> d -> IO (Either FirebaseError FirebaseId)+persist url tok = (fixError <$>) . (runF url tok). persist'++fixError :: Show e => Either e b -> Either FirebaseError b+fixError = left (\e->CommsError $ "Data update failed: "<>(cs $ show e))++runF :: String -> String -> FirebaseM t -> IO (Either Nano.HttpError t)+runF url tok a = do+ env <- fbEnv url tok+ runExceptT $ flip runReaderT env a++-- fix this mess+persist'+ :: (ToJSON d, FirebaseData d, Show d)+ => d -> FirebaseM FirebaseId+persist' d = do+ let lastMod = "6/6/6"::String+ let fbData =+ case toJSON d of+ Object j -> Object $ HM.insert "lastModified" (toJSON lastMod) j+ others -> others+ case fbLoc d of+ Just loc -> do+ put loc fbData+ case getId d of+ Just i -> return i+ Nothing -> undefined --arrgg+ Nothing -> do+ mnewId <- liftIO $ genId d+ case mnewId of+ Just newId -> do+ let loc = fbCtx d <> cs newId+ put loc fbData+ return newId+ Nothing -> cs <$> post (fbCtx d) fbData -- if no ID then we get FB to make us one++data FBEnv = FBEnv+ { fbInstance :: Firebase+ , fbHttpCfg :: Nano.HttpCfg+ }++instance Nano.HasHttpCfg FBEnv where+ httpCfg =+ lens+ fbHttpCfg+ (\te h ->+ te+ { fbHttpCfg = h+ })++instance HasFirebase FBEnv where+ firebase =+ lens+ fbInstance+ (\te f ->+ te+ { fbInstance = f+ })++--todo supply this to each method call, or create monad for us+type FirebaseM = ReaderT FBEnv (ExceptT Nano.HttpError IO)+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}