Test: store command for arbitrary type and data

3 files changed, 41 insertions, 15 deletions

diff --git a/src/Storage.hs b/src/Storage.hs
index cc2476f..e1bce3c 100644
--- a/src/Storage.hs
+++ b/src/Storage.hs
@@ -52,14 +52,12 @@ module Storage (
     beginHistory, modifyHistory,
 ) where
 
-import Codec.Compression.Zlib
 import qualified Codec.MIME.Type as MIME
 import qualified Codec.MIME.Parse as MIME
 
 import Control.Applicative
 import Control.Arrow
 import Control.Concurrent
-import Control.DeepSeq
 import Control.Exception
 import Control.Monad
 import Control.Monad.Except
@@ -247,16 +245,6 @@ storeObject = unsafeStoreObject
 storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef
 storeRawBytes = unsafeStoreRawBytes
 
-unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c)
-unsafeStoreRawBytes st raw = do
-    let dgst = hashToRefDigest raw
-    case stBacking st of
-         StorageDir { dirPath = sdir } -> writeFileOnce (refPath sdir dgst) $ compress raw
-         StorageMemory { memObjs = tobjs } ->
-             dgst `deepseq` -- the TVar may be accessed when evaluating the data to be written
-                 modifyMVar_ tobjs (return . M.insert dgst raw)
-    return $ Ref st dgst
-
 serializeRecItem :: ByteString -> RecItem' c -> [ByteString]
 serializeRecItem name (RecInt x) = [name, BC.pack ":i", BC.singleton ' ', BC.pack (show x), BC.singleton '\n']
 serializeRecItem name (RecNum x) = [name, BC.pack ":n", BC.singleton ' ', BC.pack (showRatio x), BC.singleton '\n']
diff --git a/src/Storage/Internal.hs b/src/Storage/Internal.hs
index 1f093b0..04fdf0d 100644
--- a/src/Storage/Internal.hs
+++ b/src/Storage/Internal.hs
@@ -193,6 +193,16 @@ instance StorageCompleteness Partial where
     returnLoadResult = id
     ioLoadBytes (Ref st dgst) = maybe (Left dgst) Right <$> ioLoadBytesFromStorage st dgst
 
+unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c)
+unsafeStoreRawBytes st raw = do
+    let dgst = hashToRefDigest raw
+    case stBacking st of
+         StorageDir { dirPath = sdir } -> writeFileOnce (refPath sdir dgst) $ compress raw
+         StorageMemory { memObjs = tobjs } ->
+             dgst `deepseq` -- the TVar may be accessed when evaluating the data to be written
+                 modifyMVar_ tobjs (return . M.insert dgst raw)
+    return $ Ref st dgst
+
 ioLoadBytesFromStorage :: Storage' c -> RefDigest -> IO (Maybe BL.ByteString)
 ioLoadBytesFromStorage st dgst = loadCurrent st >>=
     \case Just bytes -> return $ Just bytes
diff --git a/src/Test.hs b/src/Test.hs
index 455eed5..2a8e0df 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -10,10 +10,14 @@ import Control.Monad.State
 
 import Crypto.Random
 
+import Data.ByteString qualified as B
+import Data.ByteString.Char8 qualified as BC
+import Data.ByteString.Lazy qualified as BL
 import Data.Foldable
 import Data.IP (fromSockAddr)
 import Data.Text (Text)
 import Data.Text qualified as T
+import Data.Text.Encoding
 import Data.Text.IO qualified as T
 import Data.Typeable
 
@@ -28,6 +32,7 @@ import PubKey
 import Service
 import State
 import Storage
+import Storage.Internal (unsafeStoreRawBytes)
 import Sync
 
 
@@ -58,8 +63,7 @@ data TestInput = TestInput
 runTestTool :: Storage -> IO ()
 runTestTool st = do
     out <- newMVar ()
-    let getLineMb = catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e)
-    let testLoop = liftIO getLineMb >>= \case
+    let testLoop = getLineMb >>= \case
             Just line -> do
                 case T.words line of
                     (cname:params)
@@ -75,6 +79,14 @@ runTestTool st = do
         Left x -> hPutStrLn stderr x
         Right () -> return ()
 
+getLineMb :: MonadIO m => m (Maybe Text)
+getLineMb = liftIO $ catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e)
+
+getLines :: MonadIO m => m [Text]
+getLines = getLineMb >>= \case
+    Just line | not (T.null line) -> (line:) <$> getLines
+    _ -> return []
+
 
 type Output = MVar ()
 
@@ -83,6 +95,11 @@ outLine mvar line = withMVar mvar $ \() -> do
     putStrLn line
     hFlush stdout
 
+cmdOut :: String -> Command
+cmdOut line = do
+    out <- asks tiOutput
+    liftIO $ outLine out line
+
 
 getPeer :: Text -> CommandM Peer
 getPeer spidx = do
@@ -159,7 +176,8 @@ type Command = CommandM ()
 
 commands :: [(Text, Command)]
 commands = map (T.pack *** id)
-    [ ("create-identity", cmdCreateIdentity)
+    [ ("store", cmdStore)
+    , ("create-identity", cmdCreateIdentity)
     , ("start-server", cmdStartServer)
     , ("watch-local-identity", cmdWatchLocalIdentity)
     , ("watch-shared-identity", cmdWatchSharedIdentity)
@@ -170,6 +188,16 @@ commands = map (T.pack *** id)
     , ("attach-reject", cmdAttachReject)
     ]
 
+cmdStore :: Command
+cmdStore = do
+    st <- asks tiStorage
+    [otype] <- asks tiParams
+    ls <- getLines
+
+    let cnt = encodeUtf8 $ T.unlines ls
+    ref <- liftIO $ unsafeStoreRawBytes st $ BL.fromChunks [encodeUtf8 otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt]
+    cmdOut $ "store-done " ++ show (refDigest ref)
+
 cmdCreateIdentity :: Command
 cmdCreateIdentity = do
     st <- asks tiStorage