{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Tahoe.Server (
nullStorageServer,
memoryStorageServer,
directoryStorageServer,
directoryStorageServer',
) where
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
import Control.Exception (
Exception,
catch,
throwIO,
)
import Tahoe.CHK.Server (
StorageServer (..),
)
import Tahoe.CHK.Types (
Offset,
ShareNum,
StorageIndex,
)
import Data.IORef (
IORef,
modifyIORef',
newIORef,
readIORef,
)
import System.Directory (
createDirectoryIfMissing,
listDirectory,
)
import System.FilePath (
(</>),
)
import qualified Data.ByteString as BS
import Data.ByteString.Base32 (encodeBase32Unpadded)
import qualified Data.Text as T
import System.IO (
IOMode (..),
SeekMode (..),
hSeek,
withBinaryFile,
)
import System.IO.Error (
isDoesNotExistError,
)
directoryStorageServer :: FilePath -> StorageServer
directoryStorageServer :: FilePath -> StorageServer
directoryStorageServer FilePath
serverRoot =
StorageServer :: StorageServerID
-> (StorageIndex -> ShareNum -> Offset -> StorageIndex -> IO ())
-> (StorageIndex -> ShareNum -> IO StorageIndex)
-> (StorageIndex -> IO (Set ShareNum))
-> StorageServer
StorageServer
{ storageServerID :: StorageServerID
storageServerID = FilePath -> StorageServerID
T.pack FilePath
serverRoot
, storageServerWrite :: StorageIndex -> ShareNum -> Offset -> StorageIndex -> IO ()
storageServerWrite = FilePath
-> StorageIndex -> ShareNum -> Offset -> StorageIndex -> IO ()
writeShareDataAt FilePath
serverRoot
, storageServerRead :: StorageIndex -> ShareNum -> IO StorageIndex
storageServerRead = \StorageIndex
index ShareNum
sharenum ->
FilePath
-> IOMode -> (Handle -> IO StorageIndex) -> IO StorageIndex
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile (FilePath -> StorageIndex -> ShareNum -> FilePath
sharePath FilePath
serverRoot StorageIndex
index ShareNum
sharenum) IOMode
ReadMode Handle -> IO StorageIndex
BS.hGetContents
, storageServerGetBuckets :: StorageIndex -> IO (Set ShareNum)
storageServerGetBuckets = StorageIndex -> IO (Set ShareNum)
getBuckets
}
where
writeShareDataAt :: FilePath -> StorageIndex -> ShareNum -> Offset -> BS.ByteString -> IO ()
writeShareDataAt :: FilePath
-> StorageIndex -> ShareNum -> Offset -> StorageIndex -> IO ()
writeShareDataAt FilePath
shareRoot' StorageIndex
storageIndex ShareNum
shareNum Offset
offset StorageIndex
xs = do
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> StorageIndex -> FilePath
bucketPath FilePath
shareRoot' StorageIndex
storageIndex)
FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile (FilePath -> StorageIndex -> ShareNum -> FilePath
sharePath FilePath
shareRoot' StorageIndex
storageIndex ShareNum
shareNum) IOMode
ReadWriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
f ->
Handle -> SeekMode -> Offset -> IO ()
hSeek Handle
f SeekMode
AbsoluteSeek Offset
offset IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> StorageIndex -> IO ()
BS.hPut Handle
f StorageIndex
xs
bucketPath :: FilePath -> StorageIndex -> FilePath
bucketPath :: FilePath -> StorageIndex -> FilePath
bucketPath FilePath
root StorageIndex
storageIndex = FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
bucketName
where
bucketName :: FilePath
bucketName = FilePath
"shares" FilePath -> FilePath -> FilePath
</> FilePath
shortPiece FilePath -> FilePath -> FilePath
</> FilePath
fullName
fullName :: FilePath
fullName = StorageServerID -> FilePath
T.unpack (StorageServerID -> FilePath)
-> (StorageIndex -> StorageServerID) -> StorageIndex -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorageServerID -> StorageServerID
T.toLower (StorageServerID -> StorageServerID)
-> (StorageIndex -> StorageServerID)
-> StorageIndex
-> StorageServerID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorageIndex -> StorageServerID
encodeBase32Unpadded (StorageIndex -> FilePath) -> StorageIndex -> FilePath
forall a b. (a -> b) -> a -> b
$ StorageIndex
storageIndex
shortPiece :: FilePath
shortPiece = ShareNum -> FilePath -> FilePath
forall a. ShareNum -> [a] -> [a]
take ShareNum
2 FilePath
fullName
sharePath :: FilePath -> StorageIndex -> ShareNum -> FilePath
sharePath :: FilePath -> StorageIndex -> ShareNum -> FilePath
sharePath FilePath
root StorageIndex
storageIndex ShareNum
shareNum =
FilePath -> StorageIndex -> FilePath
bucketPath FilePath
root StorageIndex
storageIndex FilePath -> FilePath -> FilePath
</> ShareNum -> FilePath
forall a. Show a => a -> FilePath
show ShareNum
shareNum
getBuckets :: StorageIndex -> IO (Set.Set ShareNum)
getBuckets :: StorageIndex -> IO (Set ShareNum)
getBuckets StorageIndex
storageIndex =
IO (Set ShareNum)
readShareFilenames IO (Set ShareNum)
-> (IOError -> IO (Set ShareNum)) -> IO (Set ShareNum)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO (Set ShareNum)
forall a. IOError -> IO (Set a)
doesNotExist
where
readShareFilenames :: IO (Set ShareNum)
readShareFilenames =
[ShareNum] -> Set ShareNum
forall a. Ord a => [a] -> Set a
Set.fromList ([ShareNum] -> Set ShareNum)
-> ([FilePath] -> [ShareNum]) -> [FilePath] -> Set ShareNum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> ShareNum) -> [FilePath] -> [ShareNum]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> ShareNum
forall a. Read a => FilePath -> a
read ([FilePath] -> Set ShareNum) -> IO [FilePath] -> IO (Set ShareNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
listDirectory (FilePath -> StorageIndex -> FilePath
bucketPath FilePath
serverRoot StorageIndex
storageIndex)
doesNotExist :: IOError -> IO (Set a)
doesNotExist IOError
e =
if IOError -> Bool
isDoesNotExistError IOError
e
then Set a -> IO (Set a)
forall (m :: * -> *) a. Monad m => a -> m a
return Set a
forall a. Set a
Set.empty
else IOError -> IO (Set a)
forall a. IOError -> IO a
ioError IOError
e
directoryStorageServer' :: FilePath -> IO StorageServer
directoryStorageServer' :: FilePath -> IO StorageServer
directoryStorageServer' FilePath
shareRoot = do
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
shareRoot
StorageServer -> IO StorageServer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StorageServer -> IO StorageServer)
-> StorageServer -> IO StorageServer
forall a b. (a -> b) -> a -> b
$ FilePath -> StorageServer
directoryStorageServer FilePath
shareRoot
memoryStorageServer :: IO StorageServer
memoryStorageServer :: IO StorageServer
memoryStorageServer = do
IORef (Map (StorageIndex, ShareNum) StorageIndex)
shares :: IORef (M.Map (StorageIndex, ShareNum) BS.ByteString) <- Map (StorageIndex, ShareNum) StorageIndex
-> IO (IORef (Map (StorageIndex, ShareNum) StorageIndex))
forall a. a -> IO (IORef a)
newIORef Map (StorageIndex, ShareNum) StorageIndex
forall a. Monoid a => a
mempty
let storageServerID :: StorageServerID
storageServerID = StorageServerID
"memory"
storageServerWrite :: StorageIndex -> ShareNum -> Offset -> StorageIndex -> IO ()
storageServerWrite StorageIndex
index ShareNum
sharenum Offset
offset StorageIndex
sharedata =
IORef (Map (StorageIndex, ShareNum) StorageIndex)
-> (Map (StorageIndex, ShareNum) StorageIndex
-> Map (StorageIndex, ShareNum) StorageIndex)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map (StorageIndex, ShareNum) StorageIndex)
shares ((Map (StorageIndex, ShareNum) StorageIndex
-> Map (StorageIndex, ShareNum) StorageIndex)
-> IO ())
-> (Map (StorageIndex, ShareNum) StorageIndex
-> Map (StorageIndex, ShareNum) StorageIndex)
-> IO ()
forall a b. (a -> b) -> a -> b
$ (Maybe StorageIndex -> Maybe StorageIndex)
-> (StorageIndex, ShareNum)
-> Map (StorageIndex, ShareNum) StorageIndex
-> Map (StorageIndex, ShareNum) StorageIndex
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (Offset -> StorageIndex -> Maybe StorageIndex -> Maybe StorageIndex
appendBytes Offset
offset StorageIndex
sharedata) (StorageIndex
index, ShareNum
sharenum)
appendBytes :: Offset -> BS.ByteString -> Maybe BS.ByteString -> Maybe BS.ByteString
appendBytes :: Offset -> StorageIndex -> Maybe StorageIndex -> Maybe StorageIndex
appendBytes Offset
0 StorageIndex
sharedata Maybe StorageIndex
Nothing = StorageIndex -> Maybe StorageIndex
forall a. a -> Maybe a
Just StorageIndex
sharedata
appendBytes Offset
n StorageIndex
_sharedata Maybe StorageIndex
Nothing =
FilePath -> Maybe StorageIndex
forall a. HasCallStack => FilePath -> a
error (FilePath -> Maybe StorageIndex) -> FilePath -> Maybe StorageIndex
forall a b. (a -> b) -> a -> b
$
FilePath
"memoryStorageServer appendBytes requires append-only usage; 0 bytes written but offset is "
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Offset -> FilePath
forall a. Show a => a -> FilePath
show Offset
n
appendBytes Offset
n StorageIndex
sharedata (Just StorageIndex
existing)
| ShareNum -> Offset
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StorageIndex -> ShareNum
BS.length StorageIndex
existing) Offset -> Offset -> Bool
forall a. Eq a => a -> a -> Bool
/= Offset
n =
FilePath -> Maybe StorageIndex
forall a. HasCallStack => FilePath -> a
error (FilePath -> Maybe StorageIndex) -> FilePath -> Maybe StorageIndex
forall a b. (a -> b) -> a -> b
$
FilePath
"memoryStorageServer appendBytes requires append-only usage; "
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ShareNum -> FilePath
forall a. Show a => a -> FilePath
show (StorageIndex -> ShareNum
BS.length StorageIndex
existing)
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" bytes written but offset is "
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Offset -> FilePath
forall a. Show a => a -> FilePath
show Offset
n
| Bool
otherwise = StorageIndex -> Maybe StorageIndex
forall a. a -> Maybe a
Just (StorageIndex
existing StorageIndex -> StorageIndex -> StorageIndex
forall a. Semigroup a => a -> a -> a
<> StorageIndex
sharedata)
storageServerRead :: StorageIndex -> ShareNum -> IO BS.ByteString
storageServerRead :: StorageIndex -> ShareNum -> IO StorageIndex
storageServerRead StorageIndex
index ShareNum
sharenum =
StorageIndex -> Maybe StorageIndex -> StorageIndex
forall a. a -> Maybe a -> a
fromMaybe StorageIndex
"" (Maybe StorageIndex -> StorageIndex)
-> (Map (StorageIndex, ShareNum) StorageIndex
-> Maybe StorageIndex)
-> Map (StorageIndex, ShareNum) StorageIndex
-> StorageIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StorageIndex, ShareNum)
-> Map (StorageIndex, ShareNum) StorageIndex -> Maybe StorageIndex
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (StorageIndex
index, ShareNum
sharenum) (Map (StorageIndex, ShareNum) StorageIndex -> StorageIndex)
-> IO (Map (StorageIndex, ShareNum) StorageIndex)
-> IO StorageIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map (StorageIndex, ShareNum) StorageIndex)
-> IO (Map (StorageIndex, ShareNum) StorageIndex)
forall a. IORef a -> IO a
readIORef IORef (Map (StorageIndex, ShareNum) StorageIndex)
shares
storageServerGetBuckets :: StorageIndex -> IO (Set.Set ShareNum)
storageServerGetBuckets :: StorageIndex -> IO (Set ShareNum)
storageServerGetBuckets StorageIndex
index =
[ShareNum] -> Set ShareNum
forall a. Ord a => [a] -> Set a
Set.fromList ([ShareNum] -> Set ShareNum)
-> (Map (StorageIndex, ShareNum) StorageIndex -> [ShareNum])
-> Map (StorageIndex, ShareNum) StorageIndex
-> Set ShareNum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((StorageIndex, ShareNum) -> ShareNum)
-> [(StorageIndex, ShareNum)] -> [ShareNum]
forall a b. (a -> b) -> [a] -> [b]
map (StorageIndex, ShareNum) -> ShareNum
forall a b. (a, b) -> b
snd ([(StorageIndex, ShareNum)] -> [ShareNum])
-> (Map (StorageIndex, ShareNum) StorageIndex
-> [(StorageIndex, ShareNum)])
-> Map (StorageIndex, ShareNum) StorageIndex
-> [ShareNum]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((StorageIndex, ShareNum) -> Bool)
-> [(StorageIndex, ShareNum)] -> [(StorageIndex, ShareNum)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((StorageIndex -> StorageIndex -> Bool
forall a. Eq a => a -> a -> Bool
== StorageIndex
index) (StorageIndex -> Bool)
-> ((StorageIndex, ShareNum) -> StorageIndex)
-> (StorageIndex, ShareNum)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StorageIndex, ShareNum) -> StorageIndex
forall a b. (a, b) -> a
fst) ([(StorageIndex, ShareNum)] -> [(StorageIndex, ShareNum)])
-> (Map (StorageIndex, ShareNum) StorageIndex
-> [(StorageIndex, ShareNum)])
-> Map (StorageIndex, ShareNum) StorageIndex
-> [(StorageIndex, ShareNum)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (StorageIndex, ShareNum) StorageIndex
-> [(StorageIndex, ShareNum)]
forall k a. Map k a -> [k]
M.keys (Map (StorageIndex, ShareNum) StorageIndex -> Set ShareNum)
-> IO (Map (StorageIndex, ShareNum) StorageIndex)
-> IO (Set ShareNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map (StorageIndex, ShareNum) StorageIndex)
-> IO (Map (StorageIndex, ShareNum) StorageIndex)
forall a. IORef a -> IO a
readIORef IORef (Map (StorageIndex, ShareNum) StorageIndex)
shares
StorageServer -> IO StorageServer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StorageServer -> IO StorageServer)
-> StorageServer -> IO StorageServer
forall a b. (a -> b) -> a -> b
$ StorageServer :: StorageServerID
-> (StorageIndex -> ShareNum -> Offset -> StorageIndex -> IO ())
-> (StorageIndex -> ShareNum -> IO StorageIndex)
-> (StorageIndex -> IO (Set ShareNum))
-> StorageServer
StorageServer{StorageServerID
StorageIndex -> IO (Set ShareNum)
StorageIndex -> ShareNum -> IO StorageIndex
StorageIndex -> ShareNum -> Offset -> StorageIndex -> IO ()
storageServerGetBuckets :: StorageIndex -> IO (Set ShareNum)
storageServerRead :: StorageIndex -> ShareNum -> IO StorageIndex
storageServerWrite :: StorageIndex -> ShareNum -> Offset -> StorageIndex -> IO ()
storageServerID :: StorageServerID
storageServerGetBuckets :: StorageIndex -> IO (Set ShareNum)
storageServerRead :: StorageIndex -> ShareNum -> IO StorageIndex
storageServerWrite :: StorageIndex -> ShareNum -> Offset -> StorageIndex -> IO ()
storageServerID :: StorageServerID
..}
nullStorageServer :: StorageServer
nullStorageServer :: StorageServer
nullStorageServer =
StorageServer :: StorageServerID
-> (StorageIndex -> ShareNum -> Offset -> StorageIndex -> IO ())
-> (StorageIndex -> ShareNum -> IO StorageIndex)
-> (StorageIndex -> IO (Set ShareNum))
-> StorageServer
StorageServer
{ storageServerID :: StorageServerID
storageServerID = StorageServerID
"null-server"
, storageServerWrite :: StorageIndex -> ShareNum -> Offset -> StorageIndex -> IO ()
storageServerWrite = \StorageIndex
_index ShareNum
_sharenum Offset
_offset StorageIndex
_data -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, storageServerRead :: StorageIndex -> ShareNum -> IO StorageIndex
storageServerRead = \StorageIndex
_index ShareNum
_sharenum -> ReadError -> IO StorageIndex
forall e a. Exception e => e -> IO a
throwIO ReadError
IThrewYourDataAway
, storageServerGetBuckets :: StorageIndex -> IO (Set ShareNum)
storageServerGetBuckets = \StorageIndex
_index -> Set ShareNum -> IO (Set ShareNum)
forall (m :: * -> *) a. Monad m => a -> m a
return Set ShareNum
forall a. Monoid a => a
mempty
}
data ReadError = IThrewYourDataAway deriving (ShareNum -> ReadError -> FilePath -> FilePath
[ReadError] -> FilePath -> FilePath
ReadError -> FilePath
(ShareNum -> ReadError -> FilePath -> FilePath)
-> (ReadError -> FilePath)
-> ([ReadError] -> FilePath -> FilePath)
-> Show ReadError
forall a.
(ShareNum -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [ReadError] -> FilePath -> FilePath
$cshowList :: [ReadError] -> FilePath -> FilePath
show :: ReadError -> FilePath
$cshow :: ReadError -> FilePath
showsPrec :: ShareNum -> ReadError -> FilePath -> FilePath
$cshowsPrec :: ShareNum -> ReadError -> FilePath -> FilePath
Show)
instance Exception ReadError