Skip to content
Snippets Groups Projects
Commit 71f4ef0d authored by Jean-Paul Calderone's avatar Jean-Paul Calderone
Browse files

begin updating to newer -types and -testing

parent 6fb04198
No related branches found
No related tags found
No related merge requests found
Show whitespace changes
Inline Side-by-side
flake.lock
+ 8
− 8
View file @ 71f4ef0d
......@@ -284,11 +284,11 @@
]
},
"locked": {
"lastModified": 1699477067,
"narHash": "sha256-PwyrDMZXAhLb94XtRx2MIOz/77Zm5I7P8ag23WAFRPE=",
"lastModified": 1703181050,
"narHash": "sha256-wNGKEB9paN4YNngt+lZifdk6+um3zGnW55e9YpBDiPA=",
"ref": "main",
"rev": "1b34f87d90e3dbc61401ea46e4f02303c35aaf6d",
"revCount": 6,
"rev": "f2b91a3b92eb4886259871e86e6dc7d973fb81d8",
"revCount": 20,
"type": "git",
"url": "https://gitlab.com/tahoe-lafs/tahoe-great-black-swamp-testing"
},
......@@ -310,11 +310,11 @@
]
},
"locked": {
"lastModified": 1699453849,
"narHash": "sha256-7qqW8WwJ3yDrEsO9EfL9GxJo8piV5QeR7/GI9yYngaU=",
"lastModified": 1703180589,
"narHash": "sha256-smj9og81aJho3XdzhctG+/xHojjmwhpl3aHnwMk9UgE=",
"ref": "main",
"rev": "bb60f23c8660db38a2ff89ec731aaa3a08c9d7ba",
"revCount": 10,
"rev": "1551123111245223a204bd410f7ccba78aa82812",
"revCount": 13,
"type": "git",
"url": "https://gitlab.com/tahoe-lafs/tahoe-great-black-swamp-types"
},
......
src/TahoeLAFS/Storage/Backend/Memory.hs
+ 58
− 19
View file @ 71f4ef0d
......@@ -9,6 +9,7 @@ import Control.Exception (
import Control.Foldl.ByteString (Word8)
import Data.ByteArray (constEq)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import Data.Composition ((.:))
import Data.IORef (
IORef,
......@@ -16,11 +17,14 @@ import Data.IORef (
newIORef,
readIORef,
)
import Data.List (foldl')
import Data.Map.Merge.Strict (merge, preserveMissing, zipWithMatched)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, isNothing)
import Data.Monoid (All (All, getAll), First (First, getFirst))
import qualified Data.Set as Set
import Debug.Trace (trace)
import Network.HTTP.Types (ByteRange (ByteRangeFrom, ByteRangeFromTo, ByteRangeSuffix), ByteRanges)
import Tahoe.Storage.Backend (
AllocateBuckets (AllocateBuckets),
AllocationResult (..),
......@@ -54,7 +58,13 @@ import Prelude hiding (
map,
)
data ImmutableShare = Complete ShareData | Uploading UploadSecret ShareData
data PartialShare = PartialShare
{partialShareData :: LB.ByteString, partialShareWritten :: [Bool]}
emptyPartialShare :: Int -> PartialShare
emptyPartialShare size = PartialShare (LB.replicate (fromIntegral size) 0) (replicate size False)
data ImmutableShare = Complete ShareData | Uploading UploadSecret PartialShare
data Bucket = Bucket
{ bucketSize :: Size
......@@ -161,7 +171,7 @@ allocate storageIndex shareNumbers uploadSecret size backend@MemoryBackend{memor
-- The bucket we would allocate if there were no relevant existing state.
newBucket = Bucket size (Map.fromList (zip shareNumbers (repeat newUpload)))
newUpload = Uploading uploadSecret ""
newUpload = Uploading uploadSecret (emptyPartialShare (fromIntegral size))
abort ::
StorageIndex ->
......@@ -185,34 +195,62 @@ writeImm ::
StorageIndex ->
ShareNumber ->
UploadSecret ->
B.ByteString ->
ShareData ->
ByteRanges ->
MemoryBackend ->
(MemoryBackend, ())
writeImm storageIndex shareNum (UploadSecret uploadSecret) newData b@MemoryBackend{memoryBackendBuckets}
| isNothing share = throw ShareNotAllocated
| otherwise = (b{memoryBackendBuckets = updated}, ())
writeImm storageIndex shareNum (UploadSecret uploadSecret) newData ranges b@MemoryBackend{memoryBackendBuckets} =
(b{memoryBackendBuckets = updated}, ())
where
bucket = Map.lookup storageIndex memoryBackendBuckets
share = bucket >>= Map.lookup shareNum . bucketShares
size = bucketSize <$> bucket
updated = Map.adjust (\bkt -> bkt{bucketShares = Map.adjust writeToShare shareNum (bucketShares bkt)}) storageIndex memoryBackendBuckets
updated = case Map.lookup storageIndex memoryBackendBuckets of
Nothing -> throw ShareNotAllocated
Just _ -> Map.adjust (\bkt -> bkt{bucketShares = Map.adjust writeToShare shareNum (bucketShares bkt)}) storageIndex memoryBackendBuckets
writeToShare :: ImmutableShare -> ImmutableShare
writeToShare (Complete _) = throw ImmutableShareAlreadyWritten
writeToShare (Uploading (UploadSecret existingSecret) existingData)
| authorized =
(if Just True == (complete existingData newData <$> size) then Complete else Uploading (UploadSecret existingSecret)) (existingData <> newData)
| otherwise = throw IncorrectUploadSecret
writeToShare (Uploading (UploadSecret existingSecret) existing)
| not authorized = throw IncorrectUploadSecret
| isComplete newShare = Complete (LB.toStrict $ partialShareData newShare)
| otherwise = Uploading (UploadSecret existingSecret) newShare
where
newShare = foldl' integrate existing (splitAllByRanges newData ranges)
authorized = constEq existingSecret uploadSecret
isComplete (PartialShare _ ws) = and ws
splitAllByRanges :: ShareData -> [ByteRange] -> [(ShareData, ByteRange)]
splitAllByRanges "" [] = []
splitAllByRanges "" _ = error "splitAllRanges ran out of bytes, still have ranges"
splitAllByRanges bs (r : rs) = (left, r) : splitAllByRanges right rs
where
(left, right) = splitByRange bs r
splitAllByRanges _ [] = error "splitAllByRanges ran out of ranges, still have bytes"
splitByRange :: ShareData -> ByteRange -> (ShareData, ShareData)
splitByRange bs (ByteRangeFromTo start end) = B.splitAt (fromIntegral $ end - start + 1) bs
splitByRange bs (ByteRangeFrom _) = (bs, "")
splitByRange bs (ByteRangeSuffix suffixLength) = B.splitAt (fromIntegral suffixLength) bs
integrate :: PartialShare -> (ShareData, ByteRange) -> PartialShare
integrate PartialShare{partialShareData, partialShareWritten} (new, ByteRangeFromTo start end)
| or writtenInRange = throw ConflictingWrite
| otherwise = PartialShare (dataPrefix <> LB.fromStrict new <> dataSuffix) (writtenPrefix <> replicate numBytes True <> writtenSuffix)
where
numBytes = fromIntegral $ end - start + 1
(writtenPrefix, writtenMore) = splitAt (fromIntegral start) partialShareWritten
(writtenInRange, writtenSuffix) = splitAt numBytes writtenMore
complete x y = (B.length x + B.length y ==) . fromIntegral
(dataPrefix, dataMore) = LB.splitAt (fromIntegral start) partialShareData
(_, dataSuffix) = LB.splitAt (fromIntegral numBytes) dataMore
instance Show MemoryBackend where
show _ = "<MemoryBackend>"
{- | Somewhat seriously limit the amount of data we will accept to be held in
memory.
-}
maximumShareSize :: Integral i => i
maximumShareSize = fromIntegral (maxBound :: Int)
maximumShareSize = 1024 * 1024 * 100
makeVersionParams :: Integer -> Version1Parameters
makeVersionParams totalSize =
......@@ -296,10 +334,11 @@ instance Backend (IORef MemoryBackend) where
withUploadSecret secrets $ \secret ->
atomicModifyIORef' backend (abort storageIndex shareNumber secret)
writeImmutableShare backend storageIndex shareNumber secrets shareData Nothing = do
writeImmutableShare backend storageIndex shareNumber secrets shareData qrange =
withUploadSecret secrets $ \secret ->
atomicModifyIORef' backend (writeImm storageIndex shareNumber secret shareData)
writeImmutableShare _ _ _ _ _ _ = error "writeImmutableShare got bad input"
atomicModifyIORef' backend (writeImm storageIndex shareNumber secret shareData ranges)
where
ranges = fromMaybe [ByteRangeFromTo 0 (fromIntegral $ B.length shareData - 1)] qrange
adviseCorruptImmutableShare _backend _ _ _ =
return mempty
......
tahoe-great-black-swamp.cabal
+ 3
− 3
View file @ 71f4ef0d
......@@ -129,7 +129,7 @@ library
, servant-client >=0.16.0.1 && <0.21
, servant-docs >=0.11.4 && <0.14
, servant-server >=0.16.2 && <0.21
, tahoe-great-black-swamp-types >=0.4 && <0.5
, tahoe-great-black-swamp-types >=0.5 && <0.6
, tls >=1.5 && <2
, utf8-string >=1.0.1.1 && <1.1
, wai >=3.2.2.1 && <3.3
......@@ -235,8 +235,8 @@ test-suite http-tests
, servant >=0.16.2 && <0.21
, servant-client >=0.16.0.1 && <0.21
, tahoe-great-black-swamp
, tahoe-great-black-swamp-testing >=0.4 && <0.5
, tahoe-great-black-swamp-types >=0.4 && <0.5
, tahoe-great-black-swamp-testing >=0.5 && <0.6
, tahoe-great-black-swamp-types >=0.5 && <0.6
, temporary >=1.3 && <1.4
, tls >=1.5 && <2
, vector >=0.12.1.2 && <0.13
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment