diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Storage.hs | 12 | ||||
| -rw-r--r-- | src/Storage/Internal.hs | 10 | ||||
| -rw-r--r-- | src/Test.hs | 34 |
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 |