{-# 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"

-- Copied from the Python implementation.  Kind of arbitrary.
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

--  storage/
--  storage/shares/incoming
--    incoming/ holds temp dirs named $START/$STORAGEINDEX/$SHARENUM which will
--    be moved to storage/shares/$START/$STORAGEINDEX/$SHARENUM upon success
--  storage/shares/$START/$STORAGEINDEX
--  storage/shares/$START/$STORAGEINDEX/$SHARENUM

--  Where "$START" denotes the first 10 bits worth of $STORAGEINDEX (that's 2
--  base-32 chars).

instance Backend FilesystemBackend where
    version :: FilesystemBackend -> IO Version
version (FilesystemBackend String
_path) = do
        -- Hard-code some arbitrary amount of space.  There is a statvfs
        -- package that can inspect the system and tell us a more correct
        -- answer but it is somewhat unmaintained and fails to build in some
        -- important environments.
        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
                        , -- TODO: Copy the "reserved space" feature of the Python
                          -- implementation.
                          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
                    }

    -- TODO Handle ranges.
    -- TODO Make sure the share storage was allocated.
    -- TODO Don't allow target of rename to exist.
    -- TODO Concurrency
    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

    -- TODO Handle ranges.
    -- TODO Make sure the share storage was allocated.
    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'

-- Does the given backend have the complete share indicated?
haveShare ::
    FilesystemBackend -> -- The backend to check
    StorageIndex -> -- The storage index the share belongs to
    ShareNumber -> -- The number of the share
    IO Bool -- True if it has the share, False otherwise.
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 -> -- The storage backend root path
    StorageIndex -> -- The storage index to consider
    FilePath -- The path to the directory containing shares for the
    -- storage index.
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]

-- Create spaces to write data for several incoming shares.
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 ()

{- | Given the path of an immutable share, construct a path to use to hold the
 upload secret for that share.
-}
secretPath :: FilePath -> FilePath
secretPath :: ShowS
secretPath = (String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".secret")

{- | Compare the upload secret for an immutable share at a given path to a
 given upload secret and produce unit if and only if they are equal.

 If they are not, throw IncorrectUploadSecret.
-}
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)

-- | Partition a list based on the result of a monadic predicate.
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

{- | Throw IncorrectUploadSecret if the given secret does not match the
 existing secret for the given storage index path or succeed with () if it
 does.  If there is no secret yet, record the given one and succeed with ().
-}
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
                -- If there is no existing value, this check initializes it to the given
                -- value.
                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