summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Storage.hs12
-rw-r--r--src/Storage/Internal.hs10
-rw-r--r--src/Test.hs34
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