|
| 1 | +{-# LANGUAGE DeriveAnyClass #-} |
| 2 | +{-# LANGUAGE FlexibleContexts #-} |
| 3 | +{-# LANGUAGE FlexibleInstances #-} |
| 4 | +{-# LANGUAGE GADTs #-} |
| 5 | +{-# LANGUAGE GeneralizedNewtypeDeriving #-} |
| 6 | +{-# LANGUAGE IncoherentInstances #-} |
| 7 | +{-# LANGUAGE MultiParamTypeClasses #-} |
| 8 | +{-# LANGUAGE OverloadedStrings #-} |
| 9 | +{-# LANGUAGE QuasiQuotes #-} |
| 10 | +{-# LANGUAGE RecordWildCards #-} |
| 11 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 12 | +{-# LANGUAGE TemplateHaskell #-} |
| 13 | +{-# LANGUAGE TupleSections #-} |
| 14 | +{-# LANGUAGE TypeFamilies #-} |
| 15 | + |
| 16 | +module Cardano.Metadata.Store.File |
| 17 | + ( read |
| 18 | + , write |
| 19 | + , update |
| 20 | + , delete |
| 21 | + , empty |
| 22 | + , toList |
| 23 | + , init |
| 24 | + , fileStore |
| 25 | + ) where |
| 26 | + |
| 27 | +import Cardano.Metadata.Store.Types |
| 28 | +import Control.Exception.Safe |
| 29 | +import Control.Monad.Reader |
| 30 | +import Data.Aeson |
| 31 | + ( FromJSON, FromJSONKey, ToJSON, ToJSONKey ) |
| 32 | +import qualified Data.Aeson as Aeson |
| 33 | +import qualified Data.Aeson.Encoding.Internal as Aeson |
| 34 | +import qualified Data.Aeson.Types as Aeson |
| 35 | +import Data.Coerce |
| 36 | + ( coerce ) |
| 37 | +import Data.Maybe |
| 38 | + ( catMaybes, fromMaybe ) |
| 39 | +import Data.Text |
| 40 | + ( Text ) |
| 41 | +import qualified Data.Text as T |
| 42 | +import qualified Data.Text.Lazy as TL |
| 43 | +import qualified Data.Text.Lazy.Encoding as TLE |
| 44 | +import Prelude hiding |
| 45 | + ( init, read ) |
| 46 | +import System.Directory |
| 47 | +import System.FilePath.Posix |
| 48 | + ( takeFileName ) |
| 49 | + |
| 50 | +data PostgresKeyValueException = UniqueKeyConstraintViolated |
| 51 | + | FailedToDecodeJSONValue String Text |
| 52 | + deriving (Eq, Show, Exception) |
| 53 | + |
| 54 | +data KeyValue k v = KeyValue { _kvFolder :: FilePath } |
| 55 | + |
| 56 | +init |
| 57 | + :: FilePath |
| 58 | + -- ^ Folder containing metadata entries |
| 59 | + -> IO (KeyValue k v) |
| 60 | + -- ^ Resulting key-value store |
| 61 | +init = pure . KeyValue |
| 62 | + |
| 63 | +fileStore |
| 64 | + :: ( ToJSONKey k |
| 65 | + , ToJSON v |
| 66 | + , FromJSONKey k |
| 67 | + , FromJSON v |
| 68 | + ) |
| 69 | + => FilePath |
| 70 | + -- ^ Folder containing metadata entries |
| 71 | + -> IO (StoreInterface k v) |
| 72 | +fileStore folder = do |
| 73 | + let kvs = KeyValue folder |
| 74 | + pure $ StoreInterface (\k -> read k kvs) |
| 75 | + (\ks -> readBatch ks kvs) |
| 76 | + (\k v -> write k v kvs) |
| 77 | + (\k -> delete k kvs) |
| 78 | + (\f k -> update f k kvs) |
| 79 | + (toList kvs) |
| 80 | + (empty kvs) |
| 81 | + |
| 82 | +-- | Ensure file path is within folder. |
| 83 | +safeFilePath :: ToJSONKey k => KeyValue k v -> k -> FilePath |
| 84 | +safeFilePath (KeyValue folder) k = |
| 85 | + let |
| 86 | + -- Disallow user to enter a sub-directory or a parent directory by |
| 87 | + -- limiting the requested path to a file name. I.e. "../x.txt" and |
| 88 | + -- "inner/x.txt" are normalised to "x.txt" to restrict the user |
| 89 | + -- from looking outside the specified folder. |
| 90 | + raw :: FilePath |
| 91 | + raw = takeFileName . T.unpack $ toJSONKeyText k |
| 92 | + in |
| 93 | + folder <> "/" <> raw |
| 94 | + |
| 95 | +withFileIfExists :: ToJSONKey k => KeyValue k v -> k -> (FilePath -> IO r) -> IO (Maybe r) |
| 96 | +withFileIfExists kvs k f = do |
| 97 | + let safe = safeFilePath kvs k |
| 98 | + exists <- doesFileExist safe |
| 99 | + if exists |
| 100 | + then do |
| 101 | + r <- f safe |
| 102 | + pure $ Just r |
| 103 | + else pure Nothing |
| 104 | + |
| 105 | +read :: (ToJSONKey k, FromJSON v) => k -> KeyValue k v -> IO (Maybe v) |
| 106 | +read k kvs = do |
| 107 | + withFileIfExists kvs k $ \safe -> |
| 108 | + Aeson.eitherDecodeFileStrict' safe |
| 109 | + >>= (\v -> handleJSONDecodeError (T.pack safe) v) |
| 110 | + |
| 111 | +readBatch :: (ToJSONKey k, FromJSON v) => [k] -> KeyValue k v -> IO [v] |
| 112 | +readBatch [] _kvs = pure [] |
| 113 | +readBatch ks kvs = fmap catMaybes $ forM ks (\k -> read k kvs) |
| 114 | + |
| 115 | +write :: (ToJSONKey k, ToJSON v) => k -> v -> KeyValue k v -> IO () |
| 116 | +write k v kvs = |
| 117 | + let |
| 118 | + safe = safeFilePath kvs k |
| 119 | + in |
| 120 | + Aeson.encodeFile safe v |
| 121 | + |
| 122 | +delete :: ToJSONKey k => k -> KeyValue k v -> IO () |
| 123 | +delete k kvs = |
| 124 | + fromMaybe () <$> withFileIfExists kvs k removeFile |
| 125 | + |
| 126 | +update :: (ToJSONKey k, ToJSON v, FromJSON v) => (v -> Maybe v) -> k -> KeyValue k v -> IO () |
| 127 | +update fv k kvs = do |
| 128 | + mv <- read k kvs |
| 129 | + case mv of |
| 130 | + Nothing -> pure () |
| 131 | + Just v -> case fv v of |
| 132 | + Nothing -> delete k kvs |
| 133 | + Just newValue -> write k newValue kvs |
| 134 | + |
| 135 | +toList :: (ToJSONKey k, FromJSONKey k, FromJSON v) => KeyValue k v -> IO [(k, v)] |
| 136 | +toList kvs@(KeyValue folder) = do |
| 137 | + ks <- fmap (fmap T.pack) $ listDirectory folder |
| 138 | + forM ks $ \kText -> do |
| 139 | + k <- handleJSONDecodeError kText $ decodeJSONKey kText |
| 140 | + mV <- read k kvs |
| 141 | + pure $ maybe (error $ "Unable to find file with name '" <> (T.unpack $ toJSONKeyText k) <> "'") (k,) mV |
| 142 | + |
| 143 | +empty :: (FromJSONKey k, ToJSONKey k) => KeyValue k v -> IO () |
| 144 | +empty kvs@(KeyValue folder) = do |
| 145 | + ks <- fmap (fmap T.pack) $ listDirectory folder |
| 146 | + void . forM ks $ \kText -> do |
| 147 | + k <- handleJSONDecodeError undefined $ decodeJSONKey kText |
| 148 | + delete k kvs |
| 149 | + |
| 150 | +handleJSONDecodeError :: Text -> Either String a -> IO a |
| 151 | +handleJSONDecodeError t = either (\err -> throw $ FailedToDecodeJSONValue err t) pure |
| 152 | + |
| 153 | +toJSONKeyText :: ToJSONKey k => k -> Text |
| 154 | +toJSONKeyText k = |
| 155 | + case Aeson.toJSONKey of |
| 156 | + Aeson.ToJSONKeyText f _ -> f k |
| 157 | + Aeson.ToJSONKeyValue _ f -> TL.toStrict $ TLE.decodeUtf8 $ Aeson.encodingToLazyByteString $ f k |
| 158 | + |
| 159 | +decodeJSONKey :: FromJSONKey k => Text -> Either String k |
| 160 | +decodeJSONKey t = case Aeson.fromJSONKey of |
| 161 | + Aeson.FromJSONKeyCoerce -> pure $ coerce t |
| 162 | + Aeson.FromJSONKeyText f -> pure $ f t |
| 163 | + Aeson.FromJSONKeyTextParser p -> Aeson.parseEither p t |
| 164 | + Aeson.FromJSONKeyValue pv -> do |
| 165 | + (v :: Aeson.Value) <- Aeson.eitherDecode (TLE.encodeUtf8 . TL.fromStrict $ t) |
| 166 | + Aeson.parseEither pv v |
0 commit comments