From 59831514e5c00f2e47400c6e5da615190a8e3b69 Mon Sep 17 00:00:00 2001 From: Samuel Evans-Powell Date: Wed, 27 Jan 2021 20:21:18 +0800 Subject: [PATCH] WIP2 --- metadata-lib/metadata-lib.cabal | 1 + metadata-lib/src/Cardano/Metadata/Server.hs | 20 +-- .../src/Cardano/Metadata/Server/Types.hs | 17 ++- .../src/Cardano/Metadata/Store/KeyValue.hs | 2 + .../Store/KeyValue/LockedSchema/Properties.hs | 9 ++ .../Cardano/Metadata/Store/KeyValue/Map.hs | 42 ++++++ .../src/Cardano/Metadata/Store/Simple.hs | 46 ++++++ .../src/Cardano/Metadata/Store/Types.hs | 29 ++++ .../test/Test/Cardano/Metadata/Server.hs | 138 +++++++++--------- metadata-lib/test/Test/Generators.hs | 15 +- 10 files changed, 218 insertions(+), 101 deletions(-) create mode 100644 metadata-lib/src/Cardano/Metadata/Store/KeyValue.hs create mode 100644 metadata-lib/src/Cardano/Metadata/Store/KeyValue/LockedSchema/Properties.hs create mode 100644 metadata-lib/src/Cardano/Metadata/Store/KeyValue/Map.hs create mode 100644 metadata-lib/src/Cardano/Metadata/Store/Simple.hs create mode 100644 metadata-lib/src/Cardano/Metadata/Store/Types.hs diff --git a/metadata-lib/metadata-lib.cabal b/metadata-lib/metadata-lib.cabal index 0f25e48..0890477 100644 --- a/metadata-lib/metadata-lib.cabal +++ b/metadata-lib/metadata-lib.cabal @@ -13,6 +13,7 @@ library exposed-modules: Cardano.Metadata.Server Cardano.Metadata.Server.Types Cardano.Metadata.Server.API + Cardano.Metadata.Store.KeyValue.Map build-depends: aeson , base diff --git a/metadata-lib/src/Cardano/Metadata/Server.hs b/metadata-lib/src/Cardano/Metadata/Server.hs index 7ccf33c..3b98a53 100644 --- a/metadata-lib/src/Cardano/Metadata/Server.hs +++ b/metadata-lib/src/Cardano/Metadata/Server.hs @@ -20,23 +20,9 @@ import Servant import Control.Exception.Safe (catchAny) import Cardano.Metadata.Server.Types +import Cardano.Metadata.Store.Types import Cardano.Metadata.Server.API --- | A set of functions that allows the user of this library to --- determine how metadata entries are retrieved. E.g. with postgres or --- with dynamo-db. -data ReadFns - = ReadFns { readEntry :: Subject -> IO (Either ReadError Entry) - -- ^ Given a subject, return an Entry - , readProperty :: Subject -> Text -> IO (Either ReadError PartialEntry) - -- ^ Return the given property for the given subject - , readBatch :: BatchRequest -> IO BatchResponse - -- ^ Service a batch request - } - -data ReadError = NoSubject Subject - | NoProperty Subject Text - -- | 'Network.Wai.Application' of the metadata server. -- -- The function takes a set of functions as an argument, that @@ -54,14 +40,14 @@ subjectHandler :: (Subject -> IO (Either ReadError Entry)) -> Subject -> Handler Entry -subjectHandler f subject = catchExceptions $ handleErrors =<< (liftIO $ f subject) +subjectHandler f subject = catchExceptions $ handleErrors =<< liftIO (f subject) propertyHandler :: (Subject -> Text -> IO (Either ReadError PartialEntry)) -> Subject -> Text -> Handler PartialEntry -propertyHandler f subject property = catchExceptions $ handleErrors =<< (liftIO $ f subject property) +propertyHandler f subject property = catchExceptions $ handleErrors =<< liftIO (f subject property) batchHandler :: (BatchRequest -> IO BatchResponse) diff --git a/metadata-lib/src/Cardano/Metadata/Server/Types.hs b/metadata-lib/src/Cardano/Metadata/Server/Types.hs index 82b2165..d63c116 100644 --- a/metadata-lib/src/Cardano/Metadata/Server/Types.hs +++ b/metadata-lib/src/Cardano/Metadata/Server/Types.hs @@ -40,7 +40,13 @@ data BatchRequest -- | Represents the response of a batch request. data BatchResponse = BatchResponse { bRespSubjects :: [PartialEntry] } - deriving (Eq, Show, Semigroup, Monoid) + deriving (Eq, Show) + +instance Semigroup BatchResponse where + (BatchResponse xs) <> (BatchResponse ys) = BatchResponse $ xs <> ys + +instance Monoid BatchResponse where + mempty = BatchResponse mempty -- | An entry in the metadata system. data EntryF f @@ -81,6 +87,15 @@ newtype Entry = Entry (EntryF Identity) newtype PartialEntry = PartialEntry (EntryF Maybe) deriving (Eq, Show) +availablePropertyNames :: [Text] +availablePropertyNames = + [ "subject" + , "owner" + , "name" + , "description" + , "preImage" + ] + instance ToJSON PartialEntry where toJSON (PartialEntry (EntryF subj owner name desc preImage)) = Aeson.Object . HM.fromList $ diff --git a/metadata-lib/src/Cardano/Metadata/Store/KeyValue.hs b/metadata-lib/src/Cardano/Metadata/Store/KeyValue.hs new file mode 100644 index 0000000..698fe3c --- /dev/null +++ b/metadata-lib/src/Cardano/Metadata/Store/KeyValue.hs @@ -0,0 +1,2 @@ + +module Cardano.Metadata.Store.KeyValue.Map where diff --git a/metadata-lib/src/Cardano/Metadata/Store/KeyValue/LockedSchema/Properties.hs b/metadata-lib/src/Cardano/Metadata/Store/KeyValue/LockedSchema/Properties.hs new file mode 100644 index 0000000..54dac01 --- /dev/null +++ b/metadata-lib/src/Cardano/Metadata/Store/KeyValue/LockedSchema/Properties.hs @@ -0,0 +1,9 @@ +module Cardano.Metadata.Store.KeyValue.LockedSchema.Properties where + +import Data.Map.Strict +import qualified Data.Map.Strict as M + +data KeyValueStore k v = KeyValueStore (Map k v) + +keys :: KeyValueStore k v -> [k] +keys = diff --git a/metadata-lib/src/Cardano/Metadata/Store/KeyValue/Map.hs b/metadata-lib/src/Cardano/Metadata/Store/KeyValue/Map.hs new file mode 100644 index 0000000..b94ddfd --- /dev/null +++ b/metadata-lib/src/Cardano/Metadata/Store/KeyValue/Map.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE RankNTypes #-} +module Cardano.Metadata.Store.KeyValue.Map where + +import Data.Map.Strict (Map) +import Control.Concurrent.MVar +import qualified Data.Map.Strict as Map + +newtype KeyValue k v = KeyValue (MVar (Map k v)) + +init :: Map k v -> IO (KeyValue k v) +init state = do + mVar <- newMVar state + pure (KeyValue mVar) + +read :: Ord k => k -> KeyValue k v -> IO (Maybe v) +read k (KeyValue mVar) = do + m <- readMVar mVar + pure $ Map.lookup k m + +write :: Ord k => k -> v -> KeyValue k v -> IO (KeyValue k v) +write k v = modifyKeyValue (Map.insert k v) + +delete :: Ord k => k -> KeyValue k v -> IO (KeyValue k v) +delete k = modifyKeyValue (Map.delete k) + +toList :: KeyValue k v -> IO [(k, v)] +toList (KeyValue mVar) = do + m <- readMVar mVar + pure $ Map.toList m + +-- update :: k -> (v -> v) -> KeyValue k v -> IO (KeyValue k v) + +modifyKeyValue :: (Map k v -> Map k v) -> KeyValue k v -> IO (KeyValue k v) +modifyKeyValue f (KeyValue mVar) = do + -- Take the MVar, then place an unevaluated thunk inside of it, so + -- we don't hold onto the MVar for long + m <- takeMVar mVar + let m' = f m + putMVar mVar m' + -- Force evaluation of the thunk so that we don't build up a large + -- chain of thunks + seq m' (pure (KeyValue mVar)) diff --git a/metadata-lib/src/Cardano/Metadata/Store/Simple.hs b/metadata-lib/src/Cardano/Metadata/Store/Simple.hs new file mode 100644 index 0000000..c091d39 --- /dev/null +++ b/metadata-lib/src/Cardano/Metadata/Store/Simple.hs @@ -0,0 +1,46 @@ + +module Cardano.Metadata.Store.Simple where + +import qualified Data.Map.Strict as M +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HM +import Data.Text (Text) + +import Cardano.Metadata.Server.Types +import Cardano.Metadata.Store.Types + +readFns :: ReadFns +readFns = + ReadFns + (pure . getEntryForSubject) + (\subj -> pure . getPartialEntryForProperty subj) + (pure . getBatch) + +getEntryForSubject :: Subject -> Either ReadError Entry +getEntryForSubject subj = case M.lookup subj dat of + Nothing -> Left $ NoSubject subj + Just e -> Right e + +getPartialEntryForProperty :: Subject -> Text -> Either ReadError PartialEntry +getPartialEntryForProperty subj prop = do + entry <- getEntryForSubject subj + getProperty subj prop entry + +getProperty :: Subject -> Text -> Entry -> Either ReadError PartialEntry +getProperty subj prop entry = + case Aeson.toJSON entry of + (Aeson.Object obj) -> case HM.lookup prop obj of + Nothing -> Left $ NoProperty subj prop + Just p -> case Aeson.fromJSON (Aeson.Object $ HM.fromList [("subject", Aeson.String subj), (prop, p)]) of + Aeson.Error str -> error $ "JSON parsing error: " <> str + Aeson.Success x -> Right x + otherwise -> error "Entry isn't a JSON Object but should be." + +getBatch :: BatchRequest -> BatchResponse +getBatch (BatchRequest subjs props) = + BatchResponse $ + flip foldMap subjs $ \subj -> + flip foldMap props $ \prop -> + case getPartialEntryForProperty subj prop of + Left _err -> [] + Right x -> [x] diff --git a/metadata-lib/src/Cardano/Metadata/Store/Types.hs b/metadata-lib/src/Cardano/Metadata/Store/Types.hs new file mode 100644 index 0000000..9dbfd7a --- /dev/null +++ b/metadata-lib/src/Cardano/Metadata/Store/Types.hs @@ -0,0 +1,29 @@ +module Cardano.Metadata.Store.Types where + +import Data.Text (Text) + +import Cardano.Metadata.Server.Types + +-- | A set of functions that allows the user of this library to +-- determine how metadata entries are retrieved. E.g. with postgres or +-- with dynamo-db. +data ReadFns + = ReadFns { readEntry :: Subject -> IO (Either ReadError Entry) + -- ^ Given a subject, return an Entry + , readProperty :: Subject -> Text -> IO (Either ReadError PartialEntry) + -- ^ Return the given property for the given subject + , readBatch :: BatchRequest -> IO BatchResponse + -- ^ Service a batch request + } + +data ReadError = NoSubject Subject + | NoProperty Subject Text + +data WriteFns + = WriteFns { writeEntry :: Entry -> IO () + -- ^ Given an entry, write it to the data store + , removeEntry :: Subject -> IO () + -- ^ Given a subject, remove it's entry from the data store + , writeBatch :: [Entry] -> IO () + , removeAll :: IO () + } diff --git a/metadata-lib/test/Test/Cardano/Metadata/Server.hs b/metadata-lib/test/Test/Cardano/Metadata/Server.hs index 5252a80..6a3f586 100644 --- a/metadata-lib/test/Test/Cardano/Metadata/Server.hs +++ b/metadata-lib/test/Test/Cardano/Metadata/Server.hs @@ -5,6 +5,7 @@ module Test.Cardano.Metadata.Server ( tests + , testsFns ) where import Data.List (delete, find, sort) @@ -14,6 +15,7 @@ import Data.Traversable import Data.Functor.Identity (Identity(Identity)) import Data.Proxy (Proxy(Proxy)) import Data.Text (Text) +import Data.Word import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.Text as T import qualified Data.Aeson as Aeson @@ -42,6 +44,7 @@ import qualified Test.Generators as Gen import Cardano.Metadata.Server import Cardano.Metadata.Server.Types +import Cardano.Metadata.Store.KeyValue.Map withMetadataServerApp :: ReadFns -> (Warp.Port -> IO ()) -> IO () withMetadataServerApp readFns action = @@ -49,84 +52,73 @@ withMetadataServerApp readFns action = -- started and is being properly shutdown. Warp.testWithApplication (pure $ webApp readFns) action -tests :: IO TestTree -tests = do - eg <- liftIO $ testSpec "eg" spec_eg - pure $ - testGroup "Servant server tests" - [ eg - ] +-- tests :: IO TestTree +-- tests = do +-- eg <- liftIO $ testSpec "eg" spec_eg +-- pure $ +-- testGroup "Servant server tests" +-- [ eg +-- ] -spec_eg :: Spec -spec_eg = do - let - testData = M.fromList - [ ("3", Entry $ EntryF "3" (Identity $ Owner mempty mempty) (Identity $ Property "n" []) (Identity $ Property "d" []) (Identity $ PreImage "x" SHA256)) - ] +-- spec_eg :: Spec +-- spec_eg = do +-- let +-- testData = M.fromList +-- [ ("3", Entry $ EntryF "3" (Identity $ Owner mempty mempty) (Identity $ Property "n" []) (Identity $ Property "d" []) (Identity $ PreImage "x" SHA256)) +-- ] - around (withMetadataServerApp (readFnsSimple testData)) $ do - let getSubject :<|> getSubjectProperties :<|> getProperty :<|> getBatch = client (Proxy :: Proxy MetadataServerAPI) - baseUrl <- runIO $ parseBaseUrl "http://localhost" - manager <- runIO $ newManager defaultManagerSettings - let clientEnv port = mkClientEnv manager (baseUrl { baseUrlPort = port }) +-- around (withMetadataServerApp (readFnsSimple testData)) $ do +-- let getSubject :<|> getSubjectProperties :<|> getProperty :<|> getBatch = client (Proxy :: Proxy MetadataServerAPI) +-- baseUrl <- runIO $ parseBaseUrl "http://localhost" +-- manager <- runIO $ newManager defaultManagerSettings +-- let clientEnv port = mkClientEnv manager (baseUrl { baseUrlPort = port }) + +-- describe "GET /subject/{subject}" $ do +-- it "should return the subject" $ \port -> do +-- result <- runClientM (getSubject "3") (clientEnv port) +-- result `shouldBe` (Right $ Entry $ EntryF "3" (Identity $ Owner mempty mempty) (Identity $ Property "n" []) (Identity $ Property "d" []) (Identity $ PreImage "x" SHA256)) +-- describe "GET /subject/{subject}/properties" $ do +-- it "should return the subject" $ \port -> do +-- result <- runClientM (getSubject "3") (clientEnv port) +-- result `shouldBe` (Right $ Entry $ EntryF "3" (Identity $ Owner mempty mempty) (Identity $ Property "n" []) (Identity $ Property "d" []) (Identity $ PreImage "x" SHA256)) +-- describe "GET /subject/{subject}/property/{property}" $ do +-- it "should return the subject's property" $ \port -> do +-- result <- runClientM (getProperty "3" "owner") (clientEnv port) +-- result `shouldBe` (Right $ PartialEntry $ EntryF "3" (Just $ Owner mempty mempty) Nothing Nothing Nothing) +-- describe "GET /query" $ do +-- it "should return empty response if subject not found" $ \port -> do +-- result <- runClientM (getBatch $ BatchRequest ["3"] ["owner"]) (clientEnv port) +-- result `shouldBe` (Right $ BatchResponse []) +-- it "should return empty response if subject found but property not" $ \port -> do +-- result <- runClientM (getBatch $ BatchRequest ["3"] ["owner"]) (clientEnv port) +-- result `shouldBe` (Right $ BatchResponse []) +-- it "should ignore properties not found, returning properties that were found" $ \port -> do +-- result <- runClientM (getBatch $ BatchRequest ["3"] ["owner"]) (clientEnv port) +-- result `shouldBe` (Right $ BatchResponse []) +-- it "should return a batch response" $ \port -> do +-- result <- runClientM (getBatch $ BatchRequest ["3"] ["owner"]) (clientEnv port) +-- result `shouldBe` (Right $ BatchResponse []) - describe "GET /subject/{subject}" $ do - it "should return the subject" $ \port -> do - result <- runClientM (getSubject "3") (clientEnv port) - result `shouldBe` (Right $ Entry $ EntryF "3" (Identity $ Owner mempty mempty) (Identity $ Property "n" []) (Identity $ Property "d" []) (Identity $ PreImage "x" SHA256)) - describe "GET /subject/{subject}/properties" $ do - it "should return the subject" $ \port -> do - result <- runClientM (getSubject "3") (clientEnv port) - result `shouldBe` (Right $ Entry $ EntryF "3" (Identity $ Owner mempty mempty) (Identity $ Property "n" []) (Identity $ Property "d" []) (Identity $ PreImage "x" SHA256)) - describe "GET /subject/{subject}/property/{property}" $ do - it "should return the subject's property" $ \port -> do - result <- runClientM (getProperty "3" "owner") (clientEnv port) - result `shouldBe` (Right $ PartialEntry $ EntryF "3" (Just $ Owner mempty mempty) Nothing Nothing Nothing) - describe "GET /query" $ do - it "should return empty response if subject not found" $ \port -> do - result <- runClientM (getBatch $ BatchRequest ["3"] ["owner"]) (clientEnv port) - result `shouldBe` (Right $ BatchResponse []) - it "should return empty response if subject found but property not" $ \port -> do - result <- runClientM (getBatch $ BatchRequest ["3"] ["owner"]) (clientEnv port) - result `shouldBe` (Right $ BatchResponse []) - it "should ignore properties not found, returning properties that were found" $ \port -> do - result <- runClientM (getBatch $ BatchRequest ["3"] ["owner"]) (clientEnv port) - result `shouldBe` (Right $ BatchResponse []) - it "should return a batch response" $ \port -> do - result <- runClientM (getBatch $ BatchRequest ["3"] ["owner"]) (clientEnv port) - result `shouldBe` (Right $ BatchResponse []) +testsFns :: Gen (KeyValue Word8 Word8) -> TestTree +testsFns genKvs = do + testGroup "Data store property tests" + [ testProperty "x" (prop_x genKvs) + ] + +prop_x :: Gen (KeyValue Word8 Word8) -> H.Property +prop_x genKvs = property $ do + kvs <- forAll $ genKvs -readFnsSimple :: Map Subject Entry -> ReadFns -readFnsSimple dat = ReadFns - (pure . getEntryForSubject) - (\subj -> pure . getPartialEntryForProperty subj) - (pure . getBatch) + let + newKey = 1 + newValue = 12 + + kvs' <- liftIO $ write newKey newValue kvs + original <- liftIO $ toList kvs - where - getEntryForSubject :: Subject -> Either ReadError Entry - getEntryForSubject subj = case M.lookup subj dat of - Nothing -> Left $ NoSubject subj - Just e -> Right e + toList kvs' === M.toList (M.insert newKey newValue (M.fromList (toList kvs))) - getPartialEntryForProperty :: Subject -> Text -> Either ReadError PartialEntry - getPartialEntryForProperty subj prop = do - entry <- getEntryForSubject subj - getProperty subj prop entry - getProperty :: Subject -> Text -> Entry -> Either ReadError PartialEntry - getProperty subj prop entry = - case Aeson.toJSON entry of - (Aeson.Object obj) -> case HM.lookup prop obj of - Nothing -> Left $ NoProperty subj prop - Just p -> case Aeson.fromJSON (Aeson.Object $ HM.fromList [("subject", Aeson.String subj), (prop, p)]) of - Aeson.Error str -> error $ "JSON parsing error: " <> str - Aeson.Success x -> Right x - otherwise -> error "Entry isn't a JSON Object but should be." - getBatch :: BatchRequest -> BatchResponse - getBatch (BatchRequest subjs props) = BatchResponse $ - either (const []) mconcat $ - forM subjs $ \subj -> - forM props $ \prop -> - case getPartialEntryForProperty subj prop of - _ -> + + diff --git a/metadata-lib/test/Test/Generators.hs b/metadata-lib/test/Test/Generators.hs index 0d25fec..a8117e4 100644 --- a/metadata-lib/test/Test/Generators.hs +++ b/metadata-lib/test/Test/Generators.hs @@ -69,11 +69,11 @@ batchRequest = <$> Gen.list (Range.linear 0 20) subject <*> Gen.list (Range.linear 0 10) name --- anyProperty :: Gen AnyProperty --- anyProperty = Gen.choice [ PropertyPreImage <$> preImage --- , PropertyOwner <$> owner --- , PropertyGeneric <$> name <*> metadataProperty --- ] +batchRequestFor :: [Subject] -> Gen BatchRequest +batchRequestFor subjects = do + subjs <- Gen.list (Range.linear 1 (length subjects)) $ Gen.choice (pure <$> subjects) + props <- Gen.list (Range.linear 0 (length availablePropertyNames)) $ Gen.choice (pure <$> availablePropertyNames) + pure $ BatchRequest subjs props partialEntry :: Gen PartialEntry partialEntry = do @@ -86,10 +86,5 @@ partialEntry = do <*> Gen.maybe preImage ) --- anyPropertyWithKey :: Gen (Text, AnyProperty) --- anyPropertyWithKey = do --- prop <- anyProperty --- pure (anyPropertyJSONKey prop, prop) - batchResponse :: Gen BatchResponse batchResponse = BatchResponse <$> Gen.list (Range.linear 0 20) partialEntry