Use file-based store instead of Postgres DB

cabal-nix.project

@@ -2,8 +2,10 @@ packages:
   ./metadata-lib
   ./metadata-server
   ./metadata-store-postgres
+  ./metadata-store-file
   ./metadata-webhook
   ./metadata-validator-github
   ./token-metadata-creator
+  ./metadata-sync
 tests: True
 benchmarks: True

cabal.project

@@ -5,8 +5,10 @@ packages:
   ./metadata-server
   ./metadata-webhook
   ./metadata-store-postgres
+  ./metadata-store-file
   ./metadata-validator-github
   ./token-metadata-creator
+  ./metadata-sync
 
 package metadata-lib
   tests: True
@@ -26,6 +28,9 @@ package metadata-validator-github
 package token-metadata-creator
   tests: True
 
+package metadata-sync
+  tests: True
+
 -- ---------------------------------------------------------
 -- Disable all tests belonging to dependencies
 

default.nix

@@ -92,6 +92,7 @@ let
     inherit (project.hsPkgs.metadata-server.identifier) version;
     inherit (project.hsPkgs.metadata-server.components.exes) metadata-server;
     inherit (project.hsPkgs.metadata-webhook.components.exes) metadata-webhook;
+    inherit (project.hsPkgs.metadata-sync.components.exes) metadata-sync;
     inherit (project.hsPkgs.metadata-validator-github.components.exes) metadata-validator-github;
     inherit (project.hsPkgs.token-metadata-creator.components.exes) token-metadata-creator;
     inherit (project) metadata-validator-github-tarball token-metadata-creator-tarball;

metadata-lib/src/Test/Cardano/Metadata/Generators.hs

@@ -75,7 +75,7 @@ complexType =
   <*> Gen.map (Range.linear 0 20) ((,) <$> key <*> val)
 
 complexKey :: MonadGen m => m ComplexKey
-complexKey = unSubject <$> subject
+complexKey = Gen.text (Range.linear 1 255) Gen.alphaNum
 
 complexKeyVals :: MonadGen m => m [(ComplexKey, ComplexType)]
 complexKeyVals = Gen.list (Range.linear 0 20) ((,) <$> complexKey <*> complexType)
@@ -246,12 +246,12 @@ validationMetadata' = do
   validationMetadataSignedWith skey subj
 
 propertyName :: MonadGen m => m PropertyName
-propertyName = PropertyName <$> Gen.text (Range.linear 1 64) Gen.unicodeAll
+propertyName = PropertyName <$> Gen.text (Range.linear 1 64) Gen.unicode
 
 propertyValue :: MonadGen m => m Aeson.Value
 propertyValue =
   Gen.recursive Gen.choice
-    [ Aeson.String <$> Gen.text (Range.linear 1 64) Gen.unicodeAll
+    [ Aeson.String <$> Gen.text (Range.linear 1 64) Gen.unicode
     , Aeson.Number <$> fromIntegral <$> Gen.word8 Range.constantBounded
     , Aeson.Bool <$> Gen.bool
     , pure $ Aeson.Null

metadata-server/metadata-server.cabal

@@ -19,7 +19,7 @@ executable metadata-server
                      , lens
                      , lens-aeson
                      , metadata-lib
-                     , metadata-store-postgres
+                     , metadata-store-file
                      , monad-logger
                      , mtl
                      , persistent-postgresql
@@ -40,6 +40,7 @@ executable metadata-server
                         -Wincomplete-uni-patterns
                         -Wno-unsafe
                         -threaded
+                        -rtsopts
 
   other-modules:        Paths_metadata_server
                         Config

metadata-server/src/Config.hs

@@ -2,7 +2,7 @@ module Config where
 
 import Options.Applicative
 
-import Cardano.Metadata.Store.Postgres.Config
+import Cardano.Metadata.Store.File.Config
     ( Opts, parseOpts )
 
 opts :: ParserInfo Opts

metadata-server/src/Main.hs

@@ -21,25 +21,19 @@ import qualified Options.Applicative as Opt
 
 import Cardano.Metadata.Server
     ( webApp )
-import qualified Cardano.Metadata.Store.Postgres as Store
-import Cardano.Metadata.Store.Postgres.Config
-    ( Opts (..), pgConnectionString )
+import qualified Cardano.Metadata.Store.File as Store
+import Cardano.Metadata.Store.File.Config
+    ( Opts (..) )
 import Config
     ( opts )
 
 main :: IO ()
 main = do
-  options@(Opts { optDbConnections = numDbConns
-                , optDbMetadataTableName = tableName
+  options@(Opts { optMetadataLocation = folder
                 , optServerPort = port
                 }) <- Opt.execParser opts
 
-  let pgConnString = pgConnectionString options
-  putStrLn $ "Connecting to database using connection string: " <> BC.unpack pgConnString
-  runStdoutLoggingT $
-    Postgresql.withPostgresqlPool pgConnString numDbConns $ \pool -> liftIO $ do
-      putStrLn $ "Initializing table '" <> tableName <> "'."
-      intf <- Store.postgresStore pool (T.pack tableName)
-
-      putStrLn $ "Metadata server is starting on port " <> show port <> "."
-      liftIO $ Warp.run port (webApp intf)
+  putStrLn $ "Using file store at: " <> folder
+  intf <- Store.fileStore folder
+  putStrLn $ "Metadata server is starting on port " <> show port <> "."
+  liftIO $ Warp.run port (webApp intf)

metadata-store-file/metadata-store-file.cabal

@@ -0,0 +1,88 @@
+cabal-version:       >=1.10
+name:                metadata-store-file
+version:             0.1.0.0
+author:              Samuel Evans-Powell
+maintainer:          [email protected]
+build-type:          Simple
+extra-source-files:  CHANGELOG
+
+library
+  hs-source-dirs:      src
+
+  exposed-modules:     Cardano.Metadata.Store.File
+                       Cardano.Metadata.Store.File.Config
+
+  build-depends:       aeson
+                     , base
+                     , bytestring
+                     , containers
+                     , directory
+                     , metadata-lib
+                     , mtl
+                     , filepath
+                     , optparse-applicative
+                     , safe-exceptions
+                     , scientific
+                     , text
+                     , unordered-containers
+                     , warp
+
+  ghc-options:          -Wall
+                        -Wincomplete-record-updates
+                        -Wincomplete-uni-patterns
+                        -Wincomplete-patterns
+                        -Wredundant-constraints
+                        -Wpartial-fields
+                        -Wcompat
+                        -rtsopts
+
+test-suite integration-tests 
+  hs-source-dirs:       test
+  main-is:              Main.hs
+  type:                 exitcode-stdio-1.0
+
+  build-depends:  base >=4.12 && <5
+                , HUnit
+                , QuickCheck
+                , aeson
+                , aeson-pretty
+                , base
+                , bytestring
+                , casing
+                , containers
+                , directory
+                , hedgehog
+                , hspec
+                , http-client
+                , lens
+                , lens-aeson
+                , metadata-lib
+                , metadata-store-file
+                , monad-logger
+                , mtl
+                , raw-strings-qq
+                , resource-pool
+                , safe-exceptions
+                , scientific
+                , servant
+                , servant-client
+                , servant-server
+                , smallcheck
+                , tagged
+                , tasty
+                , tasty-hedgehog
+                , tasty-hspec
+                , tasty-hunit
+                , tasty-quickcheck
+                , text
+                , unordered-containers
+                , wai
+                , warp
+
+  ghc-options:          -Wall
+                        -Wincomplete-record-updates
+                        -Wincomplete-uni-patterns
+                        -Wincomplete-patterns
+                        -Wredundant-constraints
+                        -Wpartial-fields
+                        -Wcompat

metadata-store-file/src/Cardano/Metadata/Store/File.hs

@@ -0,0 +1,166 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE IncoherentInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Cardano.Metadata.Store.File
+  ( read
+  , write
+  , update
+  , delete
+  , empty
+  , toList
+  , init
+  , fileStore
+  ) where
+
+import Cardano.Metadata.Store.Types
+import Control.Exception.Safe
+import Control.Monad.Reader
+import Data.Aeson
+    ( FromJSON, FromJSONKey, ToJSON, ToJSONKey )
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Encoding.Internal as Aeson
+import qualified Data.Aeson.Types as Aeson
+import Data.Coerce
+    ( coerce )
+import Data.Maybe
+    ( catMaybes, fromMaybe )
+import Data.Text
+    ( Text )
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TLE
+import Prelude hiding
+    ( init, read )
+import System.Directory
+import System.FilePath.Posix
+    ( takeFileName )
+
+data PostgresKeyValueException = UniqueKeyConstraintViolated
+                               | FailedToDecodeJSONValue String Text
+  deriving (Eq, Show, Exception)
+
+data KeyValue k v = KeyValue { _kvFolder :: FilePath }
+
+init
+  :: FilePath
+  -- ^ Folder containing metadata entries
+  -> IO (KeyValue k v)
+  -- ^ Resulting key-value store
+init = pure . KeyValue
+
+fileStore
+  :: ( ToJSONKey k
+     , ToJSON v
+     , FromJSONKey k
+     , FromJSON v
+     )
+  => FilePath
+  -- ^ Folder containing metadata entries
+  -> IO (StoreInterface k v)
+fileStore folder = do
+  let kvs = KeyValue folder
+  pure $ StoreInterface (\k   -> read k kvs)
+                        (\ks  -> readBatch ks kvs)
+                        (\k v -> write k v kvs)
+                        (\k   -> delete k kvs)
+                        (\f k -> update f k kvs)
+                        (toList kvs)
+                        (empty kvs)
+
+-- | Ensure file path is within folder.
+safeFilePath :: ToJSONKey k => KeyValue k v -> k -> FilePath
+safeFilePath (KeyValue folder) k =
+  let
+    -- Disallow user to enter a sub-directory or a parent directory by
+    -- limiting the requested path to a file name. I.e. "../x.txt" and
+    -- "inner/x.txt" are normalised to "x.txt" to restrict the user
+    -- from looking outside the specified folder.
+    raw :: FilePath
+    raw = takeFileName . T.unpack $ toJSONKeyText k
+  in
+    folder <> "/" <> raw
+
+withFileIfExists :: ToJSONKey k => KeyValue k v -> k -> (FilePath -> IO r) -> IO (Maybe r)
+withFileIfExists kvs k f = do
+  let safe = safeFilePath kvs k
+  exists <- doesFileExist safe
+  if exists
+    then do
+      r <- f safe
+      pure $ Just r
+    else pure Nothing
+
+read :: (ToJSONKey k, FromJSON v) => k -> KeyValue k v -> IO (Maybe v)
+read k kvs = do
+  withFileIfExists kvs k $ \safe ->
+    Aeson.eitherDecodeFileStrict' safe
+      >>= (\v -> handleJSONDecodeError (T.pack safe) v) 
+
+readBatch :: (ToJSONKey k, FromJSON v) => [k] -> KeyValue k v -> IO [v]
+readBatch [] _kvs = pure []
+readBatch ks kvs  = fmap catMaybes $ forM ks (\k -> read k kvs)
+
+write :: (ToJSONKey k, ToJSON v) => k -> v -> KeyValue k v -> IO ()
+write k v kvs =
+  let
+    safe = safeFilePath kvs k
+  in
+    Aeson.encodeFile safe v
+
+delete :: ToJSONKey k => k -> KeyValue k v -> IO ()
+delete k kvs = 
+  fromMaybe () <$> withFileIfExists kvs k removeFile 
+
+update :: (ToJSONKey k, ToJSON v, FromJSON v) => (v -> Maybe v) -> k -> KeyValue k v -> IO ()
+update fv k kvs = do
+  mv <- read k kvs
+  case mv of
+    Nothing -> pure ()
+    Just v  -> case fv v of
+      Nothing       -> delete k kvs
+      Just newValue -> write k newValue kvs
+
+toList :: (ToJSONKey k, FromJSONKey k, FromJSON v) => KeyValue k v -> IO [(k, v)]
+toList kvs@(KeyValue folder) = do
+  ks <- fmap (fmap T.pack) $ listDirectory folder
+  forM ks $ \kText -> do
+    k <- handleJSONDecodeError kText $ decodeJSONKey kText
+    mV <- read k kvs
+    pure $ maybe (error $ "Unable to find file with name '" <> (T.unpack $ toJSONKeyText k) <> "'") (k,) mV
+
+empty :: (FromJSONKey k, ToJSONKey k) => KeyValue k v -> IO ()
+empty kvs@(KeyValue folder) = do
+  ks <- fmap (fmap T.pack) $ listDirectory folder
+  void . forM ks $ \kText -> do
+    k <- handleJSONDecodeError undefined $ decodeJSONKey kText
+    delete k kvs
+
+handleJSONDecodeError :: Text -> Either String a -> IO a
+handleJSONDecodeError t = either (\err -> throw $ FailedToDecodeJSONValue err t) pure
+
+toJSONKeyText :: ToJSONKey k => k -> Text
+toJSONKeyText k =
+  case Aeson.toJSONKey of
+    Aeson.ToJSONKeyText  f _ -> f k
+    Aeson.ToJSONKeyValue _ f -> TL.toStrict $ TLE.decodeUtf8 $ Aeson.encodingToLazyByteString $ f k
+
+decodeJSONKey :: FromJSONKey k => Text -> Either String k
+decodeJSONKey t = case Aeson.fromJSONKey of
+  Aeson.FromJSONKeyCoerce -> pure $ coerce t
+  Aeson.FromJSONKeyText f -> pure $ f t
+  Aeson.FromJSONKeyTextParser p -> Aeson.parseEither p t
+  Aeson.FromJSONKeyValue pv -> do
+    (v :: Aeson.Value) <- Aeson.eitherDecode (TLE.encodeUtf8 . TL.fromStrict $ t)
+    Aeson.parseEither pv v

metadata-store-file/src/Cardano/Metadata/Store/File/Config.hs

@@ -0,0 +1,15 @@
+module Cardano.Metadata.Store.File.Config where
+
+import qualified Network.Wai.Handler.Warp as Warp
+import Options.Applicative
+
+data Opts = Opts
+    { optMetadataLocation :: FilePath
+    , optServerPort       :: Warp.Port
+    }
+    deriving (Eq, Show)
+
+parseOpts :: Parser Opts
+parseOpts = Opts
+  <$> strOption (long "folder" <> metavar "FOLDER" <> help "Folder containing the metadata entries")
+  <*> option auto (short 'p' <> long "port" <> metavar "PORT" <> showDefault <> value 8080 <> help "Port to run the metadata web server on")