{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
module TahoeLAFS.Storage.Backend.Filesystem (
FilesystemBackend (FilesystemBackend),
storageStartSegment,
partitionM,
pathOfShare,
incomingPathOf,
) where
import Prelude hiding (
readFile,
writeFile,
)
import Data.ByteString (
hPut,
readFile,
writeFile,
)
import qualified Data.Set as Set
import Network.HTTP.Types (
ByteRanges,
)
import Control.Exception (
throwIO,
tryJust,
)
import Data.Maybe (
mapMaybe,
)
import Data.Map.Strict (
fromList,
toList,
)
import System.IO (
Handle,
IOMode (ReadWriteMode),
SeekMode (AbsoluteSeek),
hSeek,
withBinaryFile,
)
import System.IO.Error (
isDoesNotExistError,
)
import System.FilePath (
takeDirectory,
(</>),
)
import System.Directory (
createDirectoryIfMissing,
doesPathExist,
listDirectory,
renameFile,
)
import TahoeLAFS.Storage.API (
AllocateBuckets (..),
AllocationResult (..),
CBORSet (..),
Offset,
QueryRange,
ReadTestWriteResult (ReadTestWriteResult, readData, success),
ReadTestWriteVectors (ReadTestWriteVectors),
ShareData,
ShareNumber,
StorageIndex,
TestWriteVectors (write),
Version (..),
Version1Parameters (..),
WriteVector (WriteVector),
shareNumber,
)
import qualified TahoeLAFS.Storage.API as Storage
import TahoeLAFS.Storage.Backend (
Backend (..),
ImmutableShareAlreadyWritten (ImmutableShareAlreadyWritten),
)
newtype FilesystemBackend = FilesystemBackend FilePath
deriving (Int -> FilesystemBackend -> ShowS
[FilesystemBackend] -> ShowS
FilesystemBackend -> String
(Int -> FilesystemBackend -> ShowS)
-> (FilesystemBackend -> String)
-> ([FilesystemBackend] -> ShowS)
-> Show FilesystemBackend
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FilesystemBackend] -> ShowS
$cshowList :: [FilesystemBackend] -> ShowS
show :: FilesystemBackend -> String
$cshow :: FilesystemBackend -> String
showsPrec :: Int -> FilesystemBackend -> ShowS
$cshowsPrec :: Int -> FilesystemBackend -> ShowS
Show)
versionString :: Storage.ApplicationVersion
versionString :: ApplicationVersion
versionString = ApplicationVersion
"tahoe-lafs (gbs) 0.1.0"
maxMutableShareSize :: Storage.Size
maxMutableShareSize :: Size
maxMutableShareSize = Size
69_105 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
1_000 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
1_000 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
1_000 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
1_000
instance Backend FilesystemBackend where
version :: FilesystemBackend -> IO Version
version (FilesystemBackend String
path) = do
let available :: Size
available = Size
1_000_000_000
Version -> IO Version
forall (m :: * -> *) a. Monad m => a -> m a
return
Version :: Version1Parameters -> ApplicationVersion -> Version
Version
{ applicationVersion :: ApplicationVersion
applicationVersion = ApplicationVersion
versionString
, parameters :: Version1Parameters
parameters =
Version1Parameters :: Size -> Size -> Size -> Version1Parameters
Version1Parameters
{ maximumImmutableShareSize :: Size
maximumImmutableShareSize = Size
available
, maximumMutableShareSize :: Size
maximumMutableShareSize = Size
maxMutableShareSize
,
availableSpace :: Size
availableSpace = Size
available
}
}
createImmutableStorageIndex :: FilesystemBackend -> StorageIndex -> AllocateBuckets -> IO AllocationResult
createImmutableStorageIndex :: FilesystemBackend
-> String -> AllocateBuckets -> IO AllocationResult
createImmutableStorageIndex FilesystemBackend
backend String
storageIndex AllocateBuckets
params = do
let exists :: ShareNumber -> IO Bool
exists = FilesystemBackend -> String -> ShareNumber -> IO Bool
haveShare FilesystemBackend
backend String
storageIndex
([ShareNumber]
alreadyHave, [ShareNumber]
allocated) <- (ShareNumber -> IO Bool)
-> [ShareNumber] -> IO ([ShareNumber], [ShareNumber])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM ShareNumber -> IO Bool
exists (AllocateBuckets -> [ShareNumber]
shareNumbers AllocateBuckets
params)
FilesystemBackend -> String -> [ShareNumber] -> IO ()
allocatev FilesystemBackend
backend String
storageIndex [ShareNumber]
allocated
AllocationResult -> IO AllocationResult
forall (m :: * -> *) a. Monad m => a -> m a
return
AllocationResult :: [ShareNumber] -> [ShareNumber] -> AllocationResult
AllocationResult
{ alreadyHave :: [ShareNumber]
alreadyHave = [ShareNumber]
alreadyHave
, allocated :: [ShareNumber]
allocated = [ShareNumber]
allocated
}
writeImmutableShare :: FilesystemBackend -> StorageIndex -> ShareNumber -> ShareData -> Maybe ByteRanges -> IO ()
writeImmutableShare :: FilesystemBackend
-> String
-> ShareNumber
-> ApplicationVersion
-> QueryRange
-> IO ()
writeImmutableShare (FilesystemBackend String
root) String
storageIndex ShareNumber
shareNumber' ApplicationVersion
shareData QueryRange
Nothing = do
Bool
alreadyHave <- FilesystemBackend -> String -> ShareNumber -> IO Bool
haveShare (String -> FilesystemBackend
FilesystemBackend String
root) String
storageIndex ShareNumber
shareNumber'
if Bool
alreadyHave
then ImmutableShareAlreadyWritten -> IO ()
forall e a. Exception e => e -> IO a
throwIO ImmutableShareAlreadyWritten
ImmutableShareAlreadyWritten
else do
let finalSharePath :: String
finalSharePath = String -> String -> ShareNumber -> String
pathOfShare String
root String
storageIndex ShareNumber
shareNumber'
let incomingSharePath :: String
incomingSharePath = String -> String -> ShareNumber -> String
incomingPathOf String
root String
storageIndex ShareNumber
shareNumber'
String -> ApplicationVersion -> IO ()
writeFile String
incomingSharePath ApplicationVersion
shareData
let createParents :: Bool
createParents = Bool
True
Bool -> String -> IO ()
createDirectoryIfMissing Bool
createParents (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
finalSharePath
String -> String -> IO ()
renameFile String
incomingSharePath String
finalSharePath
getImmutableShareNumbers :: FilesystemBackend -> StorageIndex -> IO (CBORSet ShareNumber)
getImmutableShareNumbers :: FilesystemBackend -> String -> IO (CBORSet ShareNumber)
getImmutableShareNumbers (FilesystemBackend String
root) String
storageIndex = do
let storageIndexPath :: String
storageIndexPath = String -> ShowS
pathOfStorageIndex String
root String
storageIndex
Either Bool [String]
storageIndexChildren <-
(IOError -> Maybe Bool) -> IO [String] -> IO (Either Bool [String])
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust (Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> (IOError -> Bool) -> IOError -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (IO [String] -> IO (Either Bool [String]))
-> IO [String] -> IO (Either Bool [String])
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
listDirectory String
storageIndexPath
let sharePaths :: [String]
sharePaths =
case Either Bool [String]
storageIndexChildren of
Left Bool
_ -> []
Right [String]
children -> [String]
children
CBORSet ShareNumber -> IO (CBORSet ShareNumber)
forall (m :: * -> *) a. Monad m => a -> m a
return (CBORSet ShareNumber -> IO (CBORSet ShareNumber))
-> CBORSet ShareNumber -> IO (CBORSet ShareNumber)
forall a b. (a -> b) -> a -> b
$ Set ShareNumber -> CBORSet ShareNumber
forall a. Set a -> CBORSet a
CBORSet (Set ShareNumber -> CBORSet ShareNumber)
-> ([ShareNumber] -> Set ShareNumber)
-> [ShareNumber]
-> CBORSet ShareNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ShareNumber] -> Set ShareNumber
forall a. Ord a => [a] -> Set a
Set.fromList ([ShareNumber] -> CBORSet ShareNumber)
-> [ShareNumber] -> CBORSet ShareNumber
forall a b. (a -> b) -> a -> b
$ (String -> Maybe ShareNumber) -> [String] -> [ShareNumber]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Size -> Maybe ShareNumber
shareNumber (Size -> Maybe ShareNumber)
-> (String -> Size) -> String -> Maybe ShareNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Size
forall a. Read a => String -> a
read) [String]
sharePaths
readImmutableShare :: FilesystemBackend -> StorageIndex -> ShareNumber -> QueryRange -> IO Storage.ShareData
readImmutableShare :: FilesystemBackend
-> String -> ShareNumber -> QueryRange -> IO ApplicationVersion
readImmutableShare (FilesystemBackend String
root) String
storageIndex ShareNumber
shareNum QueryRange
_qr =
let _storageIndexPath :: String
_storageIndexPath = String -> ShowS
pathOfStorageIndex String
root String
storageIndex
readShare :: ShareNumber -> IO ApplicationVersion
readShare = String -> IO ApplicationVersion
readFile (String -> IO ApplicationVersion)
-> (ShareNumber -> String) -> ShareNumber -> IO ApplicationVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ShareNumber -> String
pathOfShare String
root String
storageIndex
in ShareNumber -> IO ApplicationVersion
readShare ShareNumber
shareNum
createMutableStorageIndex :: FilesystemBackend
-> String -> AllocateBuckets -> IO AllocationResult
createMutableStorageIndex = FilesystemBackend
-> String -> AllocateBuckets -> IO AllocationResult
forall b.
Backend b =>
b -> String -> AllocateBuckets -> IO AllocationResult
createImmutableStorageIndex
getMutableShareNumbers :: FilesystemBackend -> String -> IO (CBORSet ShareNumber)
getMutableShareNumbers = FilesystemBackend -> String -> IO (CBORSet ShareNumber)
forall b. Backend b => b -> String -> IO (CBORSet ShareNumber)
getImmutableShareNumbers
readvAndTestvAndWritev :: FilesystemBackend
-> String -> ReadTestWriteVectors -> IO ReadTestWriteResult
readvAndTestvAndWritev
(FilesystemBackend String
root)
String
storageIndex
(ReadTestWriteVectors SlotSecrets
_secrets Map ShareNumber TestWriteVectors
testWritev [ReadVector]
_readv) = do
((ShareNumber, TestWriteVectors) -> IO ())
-> [(ShareNumber, TestWriteVectors)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> String -> (ShareNumber, TestWriteVectors) -> IO ()
applyWriteVectors String
root String
storageIndex) ([(ShareNumber, TestWriteVectors)] -> IO ())
-> [(ShareNumber, TestWriteVectors)] -> IO ()
forall a b. (a -> b) -> a -> b
$ Map ShareNumber TestWriteVectors
-> [(ShareNumber, TestWriteVectors)]
forall k a. Map k a -> [(k, a)]
toList Map ShareNumber TestWriteVectors
testWritev
ReadTestWriteResult -> IO ReadTestWriteResult
forall (m :: * -> *) a. Monad m => a -> m a
return
ReadTestWriteResult :: Bool -> ReadResult -> ReadTestWriteResult
ReadTestWriteResult
{ success :: Bool
success = Bool
True
, readData :: ReadResult
readData = ReadResult
forall a. Monoid a => a
mempty
}
where
applyWriteVectors ::
FilePath ->
StorageIndex ->
(ShareNumber, TestWriteVectors) ->
IO ()
applyWriteVectors :: String -> String -> (ShareNumber, TestWriteVectors) -> IO ()
applyWriteVectors String
_root String
_storageIndex (ShareNumber
shareNumber', TestWriteVectors
testWriteVectors) =
(WriteVector -> IO ()) -> [WriteVector] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> String -> ShareNumber -> WriteVector -> IO ()
applyShareWrite String
root String
storageIndex ShareNumber
shareNumber') (TestWriteVectors -> [WriteVector]
write TestWriteVectors
testWriteVectors)
applyShareWrite ::
FilePath ->
StorageIndex ->
ShareNumber ->
WriteVector ->
IO ()
applyShareWrite :: String -> String -> ShareNumber -> WriteVector -> IO ()
applyShareWrite String
_root String
_storageIndex ShareNumber
shareNumber' (WriteVector Size
offset ApplicationVersion
shareData) =
let sharePath :: String
sharePath = String -> String -> ShareNumber -> String
pathOfShare String
root String
storageIndex ShareNumber
shareNumber'
createParents :: Bool
createParents = Bool
True
in do
Bool -> String -> IO ()
createDirectoryIfMissing Bool
createParents (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
sharePath
String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
sharePath IOMode
ReadWriteMode (Size -> ApplicationVersion -> Handle -> IO ()
writeAtPosition Size
offset ApplicationVersion
shareData)
where
writeAtPosition ::
Offset ->
ShareData ->
Handle ->
IO ()
writeAtPosition :: Size -> ApplicationVersion -> Handle -> IO ()
writeAtPosition Size
_offset ApplicationVersion
shareData' Handle
handle = do
Handle -> SeekMode -> Size -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek Size
offset
Handle -> ApplicationVersion -> IO ()
hPut Handle
handle ApplicationVersion
shareData'
haveShare ::
FilesystemBackend ->
StorageIndex ->
ShareNumber ->
IO Bool
haveShare :: FilesystemBackend -> String -> ShareNumber -> IO Bool
haveShare (FilesystemBackend String
path) String
storageIndex ShareNumber
shareNumber' =
String -> IO Bool
doesPathExist (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ String -> String -> ShareNumber -> String
pathOfShare String
path String
storageIndex ShareNumber
shareNumber'
pathOfStorageIndex ::
FilePath ->
StorageIndex ->
FilePath
pathOfStorageIndex :: String -> ShowS
pathOfStorageIndex String
root String
storageIndex =
String
root String -> ShowS
</> String
"shares" String -> ShowS
</> ShowS
storageStartSegment String
storageIndex String -> ShowS
</> String
storageIndex
pathOfShare :: FilePath -> StorageIndex -> ShareNumber -> FilePath
pathOfShare :: String -> String -> ShareNumber -> String
pathOfShare String
root String
storageIndex ShareNumber
shareNumber' =
String -> ShowS
pathOfStorageIndex String
root String
storageIndex String -> ShowS
</> Size -> String
forall a. Show a => a -> String
show (ShareNumber -> Size
Storage.toInteger ShareNumber
shareNumber')
incomingPathOf :: FilePath -> StorageIndex -> ShareNumber -> FilePath
incomingPathOf :: String -> String -> ShareNumber -> String
incomingPathOf String
root String
storageIndex ShareNumber
shareNumber' =
String
root String -> ShowS
</> String
"shares" String -> ShowS
</> String
"incoming" String -> ShowS
</> ShowS
storageStartSegment String
storageIndex String -> ShowS
</> String
storageIndex String -> ShowS
</> Size -> String
forall a. Show a => a -> String
show (ShareNumber -> Size
Storage.toInteger ShareNumber
shareNumber')
storageStartSegment :: StorageIndex -> FilePath
storageStartSegment :: ShowS
storageStartSegment [] = ShowS
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"illegal short storage index"
storageStartSegment [Char
_] = ShowS
storageStartSegment []
storageStartSegment (Char
a : Char
b : String
_) = [Char
a, Char
b]
allocate ::
FilesystemBackend ->
StorageIndex ->
ShareNumber ->
IO ()
allocate :: FilesystemBackend -> String -> ShareNumber -> IO ()
allocate FilesystemBackend
backend String
storageIndex ShareNumber
shareNumber' =
FilesystemBackend -> String -> [ShareNumber] -> IO ()
allocatev FilesystemBackend
backend String
storageIndex [ShareNumber
shareNumber']
allocatev ::
FilesystemBackend ->
StorageIndex ->
[ShareNumber] ->
IO ()
allocatev :: FilesystemBackend -> String -> [ShareNumber] -> IO ()
allocatev FilesystemBackend
_backend String
_storageIndex [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
allocatev (FilesystemBackend String
root) String
storageIndex (ShareNumber
shareNumber : [ShareNumber]
rest) =
let sharePath :: String
sharePath = String -> String -> ShareNumber -> String
incomingPathOf String
root String
storageIndex ShareNumber
shareNumber
shareDirectory :: String
shareDirectory = ShowS
takeDirectory String
sharePath
createParents :: Bool
createParents = Bool
True
in do
Bool -> String -> IO ()
createDirectoryIfMissing Bool
createParents String
shareDirectory
String -> ApplicationVersion -> IO ()
writeFile String
sharePath ApplicationVersion
""
FilesystemBackend -> String -> [ShareNumber] -> IO ()
allocatev (String -> FilesystemBackend
FilesystemBackend String
root) String
storageIndex [ShareNumber]
rest
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM :: (a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
pred' [a]
items = do
([a]
yes, [a]
no) <- (a -> m Bool) -> [a] -> [a] -> [a] -> m ([a], [a])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> [a] -> [a] -> m ([a], [a])
partitionM' a -> m Bool
pred' [a]
items [] []
([a], [a]) -> m ([a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
yes, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
no)
where
partitionM' :: (a -> m Bool) -> [a] -> [a] -> [a] -> m ([a], [a])
partitionM' a -> m Bool
_ [] [a]
yes [a]
no = ([a], [a]) -> m ([a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
yes, [a]
no)
partitionM' a -> m Bool
pred'' (a
item : [a]
rest) [a]
yes [a]
no = do
Bool
result <- a -> m Bool
pred'' a
item
if Bool
result
then (a -> m Bool) -> [a] -> [a] -> [a] -> m ([a], [a])
partitionM' a -> m Bool
pred'' [a]
rest (a
item a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
yes) [a]
no
else (a -> m Bool) -> [a] -> [a] -> [a] -> m ([a], [a])
partitionM' a -> m Bool
pred'' [a]
rest [a]
yes (a
item a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
no)