{-# 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,
 )

{- | Create a storage server backed by a certain directory which already
 exists.
-}
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

    -- Get the path to the directory where shares for the given storage
    -- index should be written.
    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

    -- Get the path to the file where data for the given share of the given
    -- storage index should be written.
    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

{- | Create a storage server backed by a certain directory which may or may
 not already exist.
-}
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

-- | Create a storage server backed only by in-memory data.
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
..}

{- | Create a StorageServer that discards writes to it and throws errors on
 reads.
-}
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