WIP2

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

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)

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 $

metadata-lib/src/Cardano/Metadata/Store/KeyValue.hs

@@ -0,0 +1,2 @@
+
+module Cardano.Metadata.Store.KeyValue.Map where

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 =

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))

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]

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 ()
+             }

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,91 +44,81 @@ 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 =
   -- testWithApplication makes sure the action is executed after the server has
   -- 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
-              _ -> 
+
+