{-# 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 (Show) versionString :: Storage.ApplicationVersion versionString = "tahoe-lafs (gbs) 0.1.0" -- Copied from the Python implementation. Kind of arbitrary. maxMutableShareSize :: Storage.Size maxMutableShareSize = 69_105 * 1_000 * 1_000 * 1_000 * 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 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 = 1_000_000_000 return Version { applicationVersion = versionString , parameters = Version1Parameters { maximumImmutableShareSize = available , maximumMutableShareSize = maxMutableShareSize , -- TODO: Copy the "reserved space" feature of the Python -- implementation. availableSpace = available } } createImmutableStorageIndex :: FilesystemBackend -> StorageIndex -> AllocateBuckets -> IO AllocationResult createImmutableStorageIndex backend storageIndex params = do let exists = haveShare backend storageIndex (alreadyHave, allocated) <- partitionM exists (shareNumbers params) allocatev backend storageIndex allocated return AllocationResult { alreadyHave = alreadyHave , allocated = 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 -> StorageIndex -> ShareNumber -> ShareData -> Maybe ByteRanges -> IO () writeImmutableShare (FilesystemBackend root) storageIndex shareNumber' shareData Nothing = do alreadyHave <- haveShare (FilesystemBackend root) storageIndex shareNumber' if alreadyHave then throwIO ImmutableShareAlreadyWritten else do let finalSharePath = pathOfShare root storageIndex shareNumber' let incomingSharePath = incomingPathOf root storageIndex shareNumber' writeFile incomingSharePath shareData let createParents = True createDirectoryIfMissing createParents $ takeDirectory finalSharePath renameFile incomingSharePath finalSharePath getImmutableShareNumbers :: FilesystemBackend -> StorageIndex -> IO (CBORSet ShareNumber) getImmutableShareNumbers (FilesystemBackend root) storageIndex = do let storageIndexPath = pathOfStorageIndex root storageIndex storageIndexChildren <- tryJust (Just . isDoesNotExistError) $ listDirectory storageIndexPath let sharePaths = case storageIndexChildren of Left _ -> [] Right children -> children return $ CBORSet . Set.fromList $ mapMaybe (shareNumber . read) sharePaths -- TODO Handle ranges. -- TODO Make sure the share storage was allocated. readImmutableShare :: FilesystemBackend -> StorageIndex -> ShareNumber -> QueryRange -> IO Storage.ShareData readImmutableShare (FilesystemBackend root) storageIndex shareNum _qr = let _storageIndexPath = pathOfStorageIndex root storageIndex readShare = readFile . pathOfShare root storageIndex in readShare shareNum createMutableStorageIndex = createImmutableStorageIndex getMutableShareNumbers = getImmutableShareNumbers readvAndTestvAndWritev (FilesystemBackend root) storageIndex (ReadTestWriteVectors _secrets testWritev _readv) = do -- TODO implement readv and testv parts. implement secrets part. mapM_ (applyWriteVectors root storageIndex) $ toList testWritev return ReadTestWriteResult { success = True , readData = mempty } where applyWriteVectors :: FilePath -> StorageIndex -> (ShareNumber, TestWriteVectors) -> IO () applyWriteVectors _root _storageIndex (shareNumber', testWriteVectors) = mapM_ (applyShareWrite root storageIndex shareNumber') (write testWriteVectors) applyShareWrite :: FilePath -> StorageIndex -> ShareNumber -> WriteVector -> IO () applyShareWrite _root _storageIndex shareNumber' (WriteVector offset shareData) = let sharePath = pathOfShare root storageIndex shareNumber' createParents = True in do createDirectoryIfMissing createParents $ takeDirectory sharePath withBinaryFile sharePath ReadWriteMode (writeAtPosition offset shareData) where writeAtPosition :: Offset -> ShareData -> Handle -> IO () writeAtPosition _offset shareData' handle = do hSeek handle AbsoluteSeek offset hPut handle 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 path) storageIndex shareNumber' = doesPathExist $ pathOfShare path storageIndex 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 root storageIndex = root "shares" storageStartSegment storageIndex storageIndex pathOfShare :: FilePath -> StorageIndex -> ShareNumber -> FilePath pathOfShare root storageIndex shareNumber' = pathOfStorageIndex root storageIndex show (Storage.toInteger shareNumber') incomingPathOf :: FilePath -> StorageIndex -> ShareNumber -> FilePath incomingPathOf root storageIndex shareNumber' = root "shares" "incoming" storageStartSegment storageIndex storageIndex show (Storage.toInteger shareNumber') storageStartSegment :: StorageIndex -> FilePath storageStartSegment [] = fail "illegal short storage index" storageStartSegment [_] = storageStartSegment [] storageStartSegment (a : b : _) = [a, b] -- Create a space to write data for an incoming share. allocate :: FilesystemBackend -> StorageIndex -> ShareNumber -> IO () allocate backend storageIndex shareNumber' = allocatev backend storageIndex [shareNumber'] -- Create spaces to write data for several incoming shares. allocatev :: FilesystemBackend -> StorageIndex -> [ShareNumber] -> IO () allocatev _backend _storageIndex [] = return () allocatev (FilesystemBackend root) storageIndex (shareNumber : rest) = let sharePath = incomingPathOf root storageIndex shareNumber shareDirectory = takeDirectory sharePath createParents = True in do createDirectoryIfMissing createParents shareDirectory writeFile sharePath "" allocatev (FilesystemBackend root) storageIndex rest return () partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) partitionM pred' items = do (yes, no) <- partitionM' pred' items [] [] -- re-reverse them to maintain input order return (reverse yes, reverse no) where partitionM' _ [] yes no = return (yes, no) partitionM' pred'' (item : rest) yes no = do result <- pred'' item if result then partitionM' pred'' rest (item : yes) no else partitionM' pred'' rest yes (item : no)