{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
module TahoeLAFS.Storage.Backend.Filesystem (
FilesystemBackend (FilesystemBackend),
storageStartSegment,
partitionM,
pathOfShare,
incomingPathOf,
) where
import Control.Exception (
throwIO,
try,
tryJust,
)
import Control.Monad (unless, when)
import Control.Monad.Extra (concatMapM)
import Data.Bifunctor (Bifunctor (bimap, second))
import Data.ByteArray (constEq)
import Data.ByteString (
hPut,
readFile,
writeFile,
)
import qualified Data.ByteString as B
import qualified Data.List
import qualified Data.Map.Strict as Map
import Data.Maybe (
mapMaybe,
)
import qualified Data.Set as Set
import Data.Tuple.Extra ((&&&))
import System.Directory (
createDirectoryIfMissing,
doesPathExist,
listDirectory,
removeFile,
renameFile,
)
import System.FilePath (
takeDirectory,
(</>),
)
import System.IO (
Handle,
IOMode (ReadMode, ReadWriteMode),
SeekMode (AbsoluteSeek),
hSeek,
withBinaryFile,
)
import System.IO.Error (isDoesNotExistError)
import TahoeLAFS.Storage.API (
AllocateBuckets (..),
AllocationResult (..),
CBORSet (..),
Offset,
ReadResult,
ReadTestWriteResult (ReadTestWriteResult, readData, success),
ReadTestWriteVectors (ReadTestWriteVectors),
ReadVector (..),
ShareData,
ShareNumber,
Size,
StorageIndex,
TestVector (..),
TestWriteVectors (..),
UploadSecret (..),
Version (..),
Version1Parameters (..),
WriteEnablerSecret (..),
WriteVector (WriteVector),
shareNumber,
)
import qualified TahoeLAFS.Storage.API as Storage
import TahoeLAFS.Storage.Backend (
Backend (..),
WriteImmutableError (ImmutableShareAlreadyWritten, IncorrectUploadSecret, IncorrectWriteEnablerSecret),
withUploadSecret,
)
import Prelude hiding (
readFile,
writeFile,
)
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
-> String
-> Maybe [LeaseSecret]
-> AllocateBuckets
-> IO AllocationResult
createImmutableStorageIndex FilesystemBackend
backend String
storageIndex Maybe [LeaseSecret]
secrets AllocateBuckets
params =
Maybe [LeaseSecret]
-> (UploadSecret -> IO AllocationResult) -> IO AllocationResult
forall a. Maybe [LeaseSecret] -> (UploadSecret -> IO a) -> IO a
withUploadSecret Maybe [LeaseSecret]
secrets ((UploadSecret -> IO AllocationResult) -> IO AllocationResult)
-> (UploadSecret -> IO AllocationResult) -> IO AllocationResult
forall a b. (a -> b) -> a -> b
$ \UploadSecret
uploadSecret -> 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)
(ShareNumber -> IO ()) -> [ShareNumber] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ShareNumber -> UploadSecret -> IO ())
-> UploadSecret -> ShareNumber -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FilesystemBackend -> String -> ShareNumber -> UploadSecret -> IO ()
allocate FilesystemBackend
backend String
storageIndex) UploadSecret
uploadSecret) [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
-> String
-> ShareNumber
-> Maybe [LeaseSecret]
-> ApplicationVersion
-> QueryRange
-> IO ()
writeImmutableShare (FilesystemBackend String
root) String
storageIndex ShareNumber
shareNumber' Maybe [LeaseSecret]
secrets ApplicationVersion
shareData QueryRange
Nothing =
Maybe [LeaseSecret] -> (UploadSecret -> IO ()) -> IO ()
forall a. Maybe [LeaseSecret] -> (UploadSecret -> IO a) -> IO a
withUploadSecret Maybe [LeaseSecret]
secrets ((UploadSecret -> IO ()) -> IO ())
-> (UploadSecret -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UploadSecret
uploadSecret -> do
Bool
alreadyHave <- FilesystemBackend -> String -> ShareNumber -> IO Bool
haveShare (String -> FilesystemBackend
FilesystemBackend String
root) String
storageIndex ShareNumber
shareNumber'
if Bool
alreadyHave
then WriteImmutableError -> IO ()
forall e a. Exception e => e -> IO a
throwIO WriteImmutableError
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 -> UploadSecret -> IO ()
checkUploadSecret String
incomingSharePath UploadSecret
uploadSecret
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 -> IO ()
removeFile (ShowS
secretPath String
incomingSharePath)
String -> String -> IO ()
renameFile String
incomingSharePath String
finalSharePath
abortImmutableUpload :: FilesystemBackend
-> String -> ShareNumber -> Maybe [LeaseSecret] -> IO ()
abortImmutableUpload (FilesystemBackend String
root) String
storageIndex ShareNumber
shareNumber' Maybe [LeaseSecret]
secrets =
Maybe [LeaseSecret] -> (UploadSecret -> IO ()) -> IO ()
forall a. Maybe [LeaseSecret] -> (UploadSecret -> IO a) -> IO a
withUploadSecret Maybe [LeaseSecret]
secrets ((UploadSecret -> IO ()) -> IO ())
-> (UploadSecret -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UploadSecret
uploadSecret -> do
let incomingSharePath :: String
incomingSharePath = String -> String -> ShareNumber -> String
incomingPathOf String
root String
storageIndex ShareNumber
shareNumber'
String -> UploadSecret -> IO ()
checkUploadSecret String
incomingSharePath UploadSecret
uploadSecret
String -> IO ()
removeFile String
incomingSharePath
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
-> 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
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
-> WriteEnablerSecret
-> ReadTestWriteVectors
-> IO ReadTestWriteResult
readvAndTestvAndWritev
backend :: FilesystemBackend
backend@(FilesystemBackend String
root)
String
storageIndex
WriteEnablerSecret
secret
(ReadTestWriteVectors Map ShareNumber TestWriteVectors
testWritev [ReadVector]
readv) = do
WriteEnablerSecret -> String -> IO ()
checkWriteEnabler WriteEnablerSecret
secret (String -> ShowS
pathOfStorageIndex String
root String
storageIndex)
ReadResult
readData <- IO ReadResult
runAllReads
Bool
success <- ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (IO [Bool] -> IO Bool)
-> (Map ShareNumber TestWriteVectors -> IO [Bool])
-> Map ShareNumber TestWriteVectors
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ShareNumber, TestWriteVectors) -> IO [Bool])
-> [(ShareNumber, TestWriteVectors)] -> IO [Bool]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ((ShareNumber -> [TestVector] -> IO [Bool])
-> (ShareNumber, [TestVector]) -> IO [Bool]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ShareNumber -> [TestVector] -> IO [Bool]
checkTestVectors ((ShareNumber, [TestVector]) -> IO [Bool])
-> ((ShareNumber, TestWriteVectors) -> (ShareNumber, [TestVector]))
-> (ShareNumber, TestWriteVectors)
-> IO [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestWriteVectors -> [TestVector])
-> (ShareNumber, TestWriteVectors) -> (ShareNumber, [TestVector])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second TestWriteVectors -> [TestVector]
test) ([(ShareNumber, TestWriteVectors)] -> IO [Bool])
-> (Map ShareNumber TestWriteVectors
-> [(ShareNumber, TestWriteVectors)])
-> Map ShareNumber TestWriteVectors
-> IO [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ShareNumber TestWriteVectors
-> [(ShareNumber, TestWriteVectors)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map ShareNumber TestWriteVectors -> IO Bool)
-> Map ShareNumber TestWriteVectors -> IO Bool
forall a b. (a -> b) -> a -> b
$ Map ShareNumber TestWriteVectors
testWritev
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
success (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ((ShareNumber, TestWriteVectors) -> IO ())
-> [(ShareNumber, TestWriteVectors)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ShareNumber, TestWriteVectors) -> IO ()
applyWriteVectors ([(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)]
Map.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
success
, readData :: ReadResult
readData = ReadResult
readData
}
where
runAllReads :: IO ReadResult
runAllReads :: IO ReadResult
runAllReads = do
(CBORSet Set ShareNumber
allShareNumbers) <- FilesystemBackend -> String -> IO (CBORSet ShareNumber)
forall b. Backend b => b -> String -> IO (CBORSet ShareNumber)
getMutableShareNumbers FilesystemBackend
backend String
storageIndex
let allShareNumbers' :: [ShareNumber]
allShareNumbers' = Set ShareNumber -> [ShareNumber]
forall a. Set a -> [a]
Set.toList Set ShareNumber
allShareNumbers
[(ShareNumber, [ApplicationVersion])] -> ReadResult
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ShareNumber, [ApplicationVersion])] -> ReadResult)
-> ([[ApplicationVersion]]
-> [(ShareNumber, [ApplicationVersion])])
-> [[ApplicationVersion]]
-> ReadResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ShareNumber]
-> [[ApplicationVersion]] -> [(ShareNumber, [ApplicationVersion])]
forall a b. [a] -> [b] -> [(a, b)]
zip [ShareNumber]
allShareNumbers' ([[ApplicationVersion]] -> ReadResult)
-> IO [[ApplicationVersion]] -> IO ReadResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ShareNumber -> IO [ApplicationVersion])
-> [ShareNumber] -> IO [[ApplicationVersion]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ShareNumber -> IO [ApplicationVersion]
readvOneShare [ShareNumber]
allShareNumbers'
readvOneShare :: ShareNumber -> IO [ShareData]
readvOneShare :: ShareNumber -> IO [ApplicationVersion]
readvOneShare ShareNumber
shareNum =
(ReadVector -> IO ApplicationVersion)
-> [ReadVector] -> IO [ApplicationVersion]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Size -> Size -> IO ApplicationVersion)
-> (Size, Size) -> IO ApplicationVersion
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ShareNumber -> Size -> Size -> IO ApplicationVersion
readShare ShareNumber
shareNum) ((Size, Size) -> IO ApplicationVersion)
-> (ReadVector -> (Size, Size))
-> ReadVector
-> IO ApplicationVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReadVector -> Size
offset (ReadVector -> Size)
-> (ReadVector -> Size) -> ReadVector -> (Size, Size)
forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& ReadVector -> Size
readSize)) [ReadVector]
readv
checkTestVectors :: ShareNumber -> [TestVector] -> IO [Bool]
checkTestVectors :: ShareNumber -> [TestVector] -> IO [Bool]
checkTestVectors = (TestVector -> IO Bool) -> [TestVector] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TestVector -> IO Bool) -> [TestVector] -> IO [Bool])
-> (ShareNumber -> TestVector -> IO Bool)
-> ShareNumber
-> [TestVector]
-> IO [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShareNumber -> TestVector -> IO Bool
checkTestVector
checkTestVector :: ShareNumber -> TestVector -> IO Bool
checkTestVector :: ShareNumber -> TestVector -> IO Bool
checkTestVector ShareNumber
shareNum TestVector{Size
ApplicationVersion
TestOperator
specimen :: TestVector -> ApplicationVersion
operator :: TestVector -> TestOperator
testSize :: TestVector -> Size
testOffset :: TestVector -> Size
specimen :: ApplicationVersion
operator :: TestOperator
testSize :: Size
testOffset :: Size
..} = (ApplicationVersion
specimen ApplicationVersion -> ApplicationVersion -> Bool
forall a. Eq a => a -> a -> Bool
==) (ApplicationVersion -> Bool) -> IO ApplicationVersion -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShareNumber -> Size -> Size -> IO ApplicationVersion
readShare ShareNumber
shareNum Size
testOffset Size
testSize
readShare :: ShareNumber -> Offset -> Size -> IO ShareData
readShare :: ShareNumber -> Size -> Size -> IO ApplicationVersion
readShare ShareNumber
shareNum Size
offset Size
size = String
-> IOMode
-> (Handle -> IO ApplicationVersion)
-> IO ApplicationVersion
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
path IOMode
ReadMode ((Handle -> IO ApplicationVersion) -> IO ApplicationVersion)
-> (Handle -> IO ApplicationVersion) -> IO ApplicationVersion
forall a b. (a -> b) -> a -> b
$ \Handle
shareFile -> do
Handle -> SeekMode -> Size -> IO ()
hSeek Handle
shareFile SeekMode
AbsoluteSeek Size
offset
Handle -> Int -> IO ApplicationVersion
B.hGetSome Handle
shareFile (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
size)
where
path :: String
path = String -> String -> ShareNumber -> String
pathOfShare String
root String
storageIndex ShareNumber
shareNum
applyWriteVectors ::
(ShareNumber, TestWriteVectors) ->
IO ()
applyWriteVectors :: (ShareNumber, TestWriteVectors) -> IO ()
applyWriteVectors (ShareNumber
shareNumber', TestWriteVectors
testWriteVectors) =
(WriteVector -> IO ()) -> [WriteVector] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ShareNumber -> WriteVector -> IO ()
applyShareWrite ShareNumber
shareNumber') (TestWriteVectors -> [WriteVector]
write TestWriteVectors
testWriteVectors)
applyShareWrite ::
ShareNumber ->
WriteVector ->
IO ()
applyShareWrite :: ShareNumber -> WriteVector -> IO ()
applyShareWrite ShareNumber
shareNumber' (WriteVector Size
offset ApplicationVersion
shareData) = 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
sharePath :: String
sharePath = String -> String -> ShareNumber -> String
pathOfShare String
root String
storageIndex ShareNumber
shareNumber'
createParents :: Bool
createParents = Bool
True
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 ->
UploadSecret ->
IO ()
allocate :: FilesystemBackend -> String -> ShareNumber -> UploadSecret -> IO ()
allocate (FilesystemBackend String
root) String
storageIndex ShareNumber
shareNum (UploadSecret ApplicationVersion
secret) =
let sharePath :: String
sharePath = String -> String -> ShareNumber -> String
incomingPathOf String
root String
storageIndex ShareNumber
shareNum
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 (ShowS
secretPath String
sharePath) ApplicationVersion
secret
String -> ApplicationVersion -> IO ()
writeFile String
sharePath ApplicationVersion
""
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
secretPath :: FilePath -> FilePath
secretPath :: ShowS
secretPath = (String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".secret")
checkUploadSecret :: FilePath -> UploadSecret -> IO ()
checkUploadSecret :: String -> UploadSecret -> IO ()
checkUploadSecret String
sharePath (UploadSecret ApplicationVersion
uploadSecret) = do
Bool
matches <- ApplicationVersion -> ApplicationVersion -> Bool
forall bs1 bs2.
(ByteArrayAccess bs1, ByteArrayAccess bs2) =>
bs1 -> bs2 -> Bool
constEq ApplicationVersion
uploadSecret (ApplicationVersion -> Bool) -> IO ApplicationVersion -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ApplicationVersion
readFile (ShowS
secretPath String
sharePath)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
matches (WriteImmutableError -> IO ()
forall e a. Exception e => e -> IO a
throwIO WriteImmutableError
IncorrectUploadSecret)
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 = ([(a, Bool)] -> [a])
-> ([(a, Bool)] -> [a]) -> ([(a, Bool)], [(a, Bool)]) -> ([a], [a])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((a, Bool) -> a
forall a b. (a, b) -> a
fst ((a, Bool) -> a) -> [(a, Bool)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ((a, Bool) -> a
forall a b. (a, b) -> a
fst ((a, Bool) -> a) -> [(a, Bool)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([(a, Bool)], [(a, Bool)]) -> ([a], [a]))
-> ([Bool] -> ([(a, Bool)], [(a, Bool)])) -> [Bool] -> ([a], [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Bool) -> Bool) -> [(a, Bool)] -> ([(a, Bool)], [(a, Bool)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
Data.List.partition (a, Bool) -> Bool
forall a b. (a, b) -> b
snd ([(a, Bool)] -> ([(a, Bool)], [(a, Bool)]))
-> ([Bool] -> [(a, Bool)]) -> [Bool] -> ([(a, Bool)], [(a, Bool)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [Bool] -> [(a, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
items ([Bool] -> ([a], [a])) -> m [Bool] -> m ([a], [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m Bool) -> [a] -> m [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m Bool
pred' [a]
items
checkWriteEnabler :: WriteEnablerSecret -> FilePath -> IO ()
checkWriteEnabler :: WriteEnablerSecret -> String -> IO ()
checkWriteEnabler (WriteEnablerSecret ApplicationVersion
given) String
storageIndexPath = do
Either IOError ApplicationVersion
x <- IO ApplicationVersion -> IO (Either IOError ApplicationVersion)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ApplicationVersion -> IO (Either IOError ApplicationVersion))
-> (String -> IO ApplicationVersion)
-> String
-> IO (Either IOError ApplicationVersion)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ApplicationVersion
B.readFile (String -> IO (Either IOError ApplicationVersion))
-> String -> IO (Either IOError ApplicationVersion)
forall a b. (a -> b) -> a -> b
$ String
path
case Either IOError ApplicationVersion
x of
Left IOError
e
| IOError -> Bool
isDoesNotExistError IOError
e -> do
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory String
path)
String -> ApplicationVersion -> IO ()
B.writeFile String
path ApplicationVersion
given
| Bool
otherwise -> IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
e
Right ApplicationVersion
existing
| ApplicationVersion -> WriteEnablerSecret
WriteEnablerSecret ApplicationVersion
given WriteEnablerSecret -> WriteEnablerSecret -> Bool
forall a. Eq a => a -> a -> Bool
== ApplicationVersion -> WriteEnablerSecret
WriteEnablerSecret ApplicationVersion
existing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
otherwise -> WriteImmutableError -> IO ()
forall e a. Exception e => e -> IO a
throwIO WriteImmutableError
IncorrectWriteEnablerSecret
where
path :: String
path = ShowS
secretPath String
storageIndexPath