diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,1 @@ +* 0.0.1 - Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/benchmark/Bench.hs b/benchmark/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Bench.hs @@ -0,0 +1,9 @@ +module Main (main) where + +import Criterion.Main (bgroup, defaultMain) +import qualified MainBench + +main :: IO () +main = defaultMain + [ bgroup "API" HuskBench.benchmarks + ] diff --git a/firebase-database.cabal b/firebase-database.cabal new file mode 100644 --- /dev/null +++ b/firebase-database.cabal @@ -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 +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 diff --git a/src/Network/Google/Firebase.hs b/src/Network/Google/Firebase.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Firebase.hs @@ -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 diff --git a/src/Network/Google/Firebase/Events.hs b/src/Network/Google/Firebase/Events.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Firebase/Events.hs @@ -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 diff --git a/src/Network/Google/Firebase/Types.hs b/src/Network/Google/Firebase/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Firebase/Types.hs @@ -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 + diff --git a/src/Network/Google/Firebase/Util.hs b/src/Network/Google/Firebase/Util.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Firebase/Util.hs @@ -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) + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}