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

-- 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 -> 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
                }

    -- 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
-> 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

    -- TODO Handle ranges.
    -- TODO Make sure the share storage was allocated.
    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
            -- TODO implement readv and testv parts.  implement secrets part.
            ((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'

-- 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 a space to write data for an incoming share.
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']

-- Create spaces to write data for several incoming shares.
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 [] []
    -- re-reverse them to maintain input order
    ([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)