{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Tahoe.CHK.Upload (
    UploadResult (uploadResultReadCap, uploadResultExistingShares, uploadResultShareMap),
    Uploadable (..),
    Parameters (Parameters),
    defaultParameters,
    filesystemUploadable,
    filesystemUploadableWithConvergence,
    filesystemUploadableRandomConvergence,
    memoryUploadableWithConvergence,
    getConvergentKey,
    upload,
    store,
    prettyFormatSharemap,
    adjustSegmentSize,
    encryptAndEncode,
) where

import Control.Monad.Conc.Class (
    modifyIORefCAS,
 )

import Data.Maybe (
    fromJust,
 )

import Data.List (
    intersperse,
 )

import Data.IORef (
    newIORef,
 )

import qualified Data.Binary as Binary
import Data.ByteArray (ScrubbedBytes)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL

import Data.Text (
    Text,
    intercalate,
    pack,
 )
import qualified Data.Text as Text

import qualified Data.Set as Set

import qualified Data.Map.Strict as Map

import qualified Tahoe.CHK.Capability as Cap

import System.IO (
    IOMode (ReadMode),
    hFileSize,
    hSetBinaryMode,
    openBinaryFile,
    openFile,
 )

import Crypto.Cipher.AES (AES128)
import Crypto.Cipher.Types (BlockCipher, Cipher (cipherInit, cipherKeySize), KeySizeSpecifier (..))
import "cryptonite" Crypto.Random (getRandomBytes)

import Tahoe.CHK.Cipher (Key)
import Tahoe.CHK.Crypto (
    convergenceEncryptionHashLazy,
    storageIndexHash,
 )

import Tahoe.CHK.Server (
    ShareMap,
    StorageServer (..),
 )
import Tahoe.CHK.Types (
    Parameters (Parameters),
    ShareNum,
    Size,
    StorageIndex,
 )

import Tahoe.Util (nextMultipleOf)

import Crypto.Error (maybeCryptoError)
import Data.Tuple.Extra (thd3)
import Tahoe.CHK (
    encode,
 )
import Tahoe.CHK.Encrypt (encryptLazy)

-- Some data that can be uploaded.
data Uploadable = Uploadable
    { Uploadable -> Key AES128
uploadableKey :: Key AES128
    , Uploadable -> Size
uploadableSize :: Size
    , Uploadable -> Parameters
uploadableParameters :: Parameters
    , Uploadable -> Size -> IO ByteString
uploadableReadCleartext :: Integer -> IO B.ByteString
    }

-- The outcome of an attempt to upload an immutable.
data UploadResult = UploadResult
    { UploadResult -> Reader
uploadResultReadCap :: Cap.Reader
    , UploadResult -> Size
uploadResultExistingShares :: Integer
    , UploadResult -> ShareMap
uploadResultShareMap :: ShareMap
    }
    deriving (Int -> UploadResult -> ShowS
[UploadResult] -> ShowS
UploadResult -> String
(Int -> UploadResult -> ShowS)
-> (UploadResult -> String)
-> ([UploadResult] -> ShowS)
-> Show UploadResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UploadResult] -> ShowS
$cshowList :: [UploadResult] -> ShowS
show :: UploadResult -> String
$cshow :: UploadResult -> String
showsPrec :: Int -> UploadResult -> ShowS
$cshowsPrec :: Int -> UploadResult -> ShowS
Show)

-- Find shares that already exist on servers.
locateAllShareholders :: StorageIndex -> [StorageServer] -> IO ShareMap
locateAllShareholders :: ByteString -> [StorageServer] -> IO ShareMap
locateAllShareholders ByteString
storageIndex [StorageServer]
servers =
    (Set StorageServer -> Set StorageServer -> Set StorageServer)
-> [ShareMap] -> ShareMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Set StorageServer -> Set StorageServer -> Set StorageServer
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([ShareMap] -> ShareMap) -> IO [ShareMap] -> IO ShareMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StorageServer -> IO ShareMap) -> [StorageServer] -> IO [ShareMap]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM StorageServer -> IO ShareMap
getBuckets [StorageServer]
servers
  where
    getBuckets :: StorageServer -> IO ShareMap
    getBuckets :: StorageServer -> IO ShareMap
getBuckets StorageServer
s = do
        Set Int
buckets <- StorageServer -> ByteString -> IO (Set Int)
storageServerGetBuckets StorageServer
s ByteString
storageIndex
        ShareMap -> IO ShareMap
forall (m :: * -> *) a. Monad m => a -> m a
return (ShareMap -> IO ShareMap) -> ShareMap -> IO ShareMap
forall a b. (a -> b) -> a -> b
$ (Int -> Set StorageServer) -> Set Int -> ShareMap
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (Set StorageServer -> Int -> Set StorageServer
forall a b. a -> b -> a
const (Set StorageServer -> Int -> Set StorageServer)
-> Set StorageServer -> Int -> Set StorageServer
forall a b. (a -> b) -> a -> b
$ StorageServer -> Set StorageServer
forall a. a -> Set a
Set.singleton StorageServer
s) Set Int
buckets

planSharePlacement :: Parameters -> StorageIndex -> ShareMap -> [StorageServer] -> ShareMap
planSharePlacement :: Parameters -> ByteString -> ShareMap -> [StorageServer] -> ShareMap
planSharePlacement (Parameters Size
_ Total
total Int
_ Total
_) ByteString
_storageIndex ShareMap
_currentShares [StorageServer]
servers =
    [(Int, Set StorageServer)] -> ShareMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Int
shareNum, StorageServer -> Set StorageServer
forall a. a -> Set a
Set.singleton StorageServer
server)
        | (Int
shareNum, StorageServer
server) <- [Int] -> [StorageServer] -> [(Int, StorageServer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 .. (Total -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Total
total Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)] ([StorageServer] -> [StorageServer]
forall a. [a] -> [a]
cycle [StorageServer]
servers)
        ]

-- Upload some immutable share data to some buckets on some servers.
--
-- XXX TODO This writes the raw share data to a file with no server-side
-- bookkeeping.  This may not be intrinsically bad but it makes the share
-- files incompatible with the Tahoe-LAFS storage server on-disk state.  This
-- may not be intrinsically bad either but interop testing would be much
-- easier if the on-disk state were compatible.
uploadImmutableShares ::
    StorageIndex ->
    [(ShareNum, StorageServer, BL.ByteString)] ->
    IO ()
uploadImmutableShares :: ByteString -> [(Int, StorageServer, ByteString)] -> IO ()
uploadImmutableShares ByteString
storageIndex [(Int, StorageServer, ByteString)]
uploads =
    Size -> IO ()
uploadChunks Size
0
  where
    -- How much data to upload to each server per request.
    chunkSize :: Size
chunkSize = Size
1024 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
1024

    -- Upload the chunk of each share at `offset` to the corresponding server
    -- and then proceed to the chunks at the next offset.
    uploadChunks :: Size -> IO ()
uploadChunks Size
offset = do
        Bool
res <- Size -> ByteString -> Size -> IO Bool
uploadChunk Size
chunkSize ByteString
storageIndex Size
offset
        if Bool
res
            then Size -> IO ()
uploadChunks (Size
offset Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
chunkSize)
            else () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    uploadChunk ::
        Integer ->
        StorageIndex ->
        Integer ->
        IO Bool
    uploadChunk :: Size -> ByteString -> Size -> IO Bool
uploadChunk Size
size ByteString
storageIndex' Size
offset =
        if (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString
"" ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/=) [ByteString]
chunks
            then ((Int, StorageServer, ByteString) -> IO ())
-> [(Int, StorageServer, ByteString)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Size -> ByteString -> (Int, StorageServer, ByteString) -> IO ()
uploadOneChunk Size
offset ByteString
storageIndex') [(Int, StorageServer, ByteString)]
uploads IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
            else Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      where
        chunks :: [ByteString]
chunks = ((Int, StorageServer, ByteString) -> ByteString)
-> [(Int, StorageServer, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Int64 -> ByteString -> ByteString
BL.take (Size -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
size) (ByteString -> ByteString)
-> ((Int, StorageServer, ByteString) -> ByteString)
-> (Int, StorageServer, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> ByteString -> ByteString
BL.drop (Size -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
offset) (ByteString -> ByteString)
-> ((Int, StorageServer, ByteString) -> ByteString)
-> (Int, StorageServer, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, StorageServer, ByteString) -> ByteString
forall a b c. (a, b, c) -> c
thd3) [(Int, StorageServer, ByteString)]
uploads

    uploadOneChunk :: Size -> ByteString -> (Int, StorageServer, ByteString) -> IO ()
uploadOneChunk Size
offset ByteString
storageIndex' (Int
shareNum, StorageServer
server, ByteString
shareData) =
        StorageServer -> ByteString -> Int -> Size -> ByteString -> IO ()
storageServerWrite StorageServer
server ByteString
storageIndex' Int
shareNum Size
offset (ByteString -> ByteString
BL.toStrict ByteString
shareData)

{- | Encrypt and encode some application data to some ZFEC shares and upload
 them to some servers.
-}
store ::
    -- | The servers to consider using.
    [StorageServer] ->
    -- | The application data to operate on.
    Uploadable ->
    -- | The result of the attempt.
    IO UploadResult
store :: [StorageServer] -> Uploadable -> IO UploadResult
store [StorageServer]
servers uploadable :: Uploadable
uploadable@(Uploadable Key AES128
key Size
_ Parameters
params Size -> IO ByteString
_) =
    Uploadable -> IO ([ByteString], Reader)
encryptAndEncode Uploadable
uploadable IO ([ByteString], Reader)
-> (([ByteString], Reader) -> IO UploadResult) -> IO UploadResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [StorageServer]
-> Key AES128
-> Parameters
-> ([ByteString], Reader)
-> IO UploadResult
upload [StorageServer]
servers Key AES128
key Parameters
params

{- | Given some cleartext and some encoding parameters: encrypt and encode some
 shares that can later be used to reconstruct the cleartext.
-}
encryptAndEncode ::
    -- | The application data to encrypt and encode.
    Uploadable ->
    -- | An action to get an action that can be repeatedly evaluated to get
    -- share data.  As long as there is more share data, it evaluates to Left.
    -- When shares are done, it evaluates to Right.
    IO ([BL.ByteString], Cap.Reader)
encryptAndEncode :: Uploadable -> IO ([ByteString], Reader)
encryptAndEncode (Uploadable Key AES128
readKey Size
_ Parameters
params Size -> IO ByteString
read') = do
    ByteString
plaintext <- (Size -> IO ByteString) -> IO ByteString
readAll Size -> IO ByteString
read'
    let ciphertext :: ByteString
ciphertext = Key AES128 -> ByteString -> ByteString
forall cipher.
BlockCipher cipher =>
cipher -> ByteString -> ByteString
encryptLazy Key AES128
readKey ByteString
plaintext
    ([Share]
shares, Reader
cap) <- Key AES128 -> Parameters -> ByteString -> IO ([Share], Reader)
encode Key AES128
readKey Parameters
params ByteString
ciphertext
    ([ByteString], Reader) -> IO ([ByteString], Reader)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Share -> ByteString) -> [Share] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Share -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode [Share]
shares, Reader
cap)
  where
    readAll :: (Integer -> IO B.ByteString) -> IO BL.ByteString
    readAll :: (Size -> IO ByteString) -> IO ByteString
readAll Size -> IO ByteString
f = do
        ByteString
bs <- ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Size -> IO ByteString
f (Size
1024 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
32)
        if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
""
            then ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
""
            else (ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Size -> IO ByteString) -> IO ByteString
readAll Size -> IO ByteString
f

{- | Given some cleartext, some encoding parameters, and some servers:
 encrypt, encode, and upload some shares that can later be used to
 reconstruct the cleartext.

 This replaces allmydata.immutable.upload.Uploader.upload.
-}
upload ::
    -- | The servers to consider uploading shares to.
    [StorageServer] ->
    -- | The encryption key (to derive the storage index).
    Key AES128 ->
    -- | The encoding parameters (XXX only for happy, right?)
    Parameters ->
    -- | The share data to upload.
    ([BL.ByteString], Cap.Reader) ->
    -- | Describe the outcome of the upload.
    IO UploadResult
upload :: [StorageServer]
-> Key AES128
-> Parameters
-> ([ByteString], Reader)
-> IO UploadResult
upload [StorageServer]
servers Key AES128
key Parameters
params ([ByteString], Reader)
encoded = do
    -- Decide where to put it
    ShareMap
existingShares <- ByteString -> [StorageServer] -> IO ShareMap
locateAllShareholders ByteString
storageIndex [StorageServer]
servers
    let targets :: ShareMap
targets = Parameters -> ShareMap -> ShareMap
targetServers Parameters
params ShareMap
existingShares

    -- Go
    let ([ByteString]
streams, Reader
cap) = ([ByteString], Reader)
encoded
    ByteString -> [(Int, StorageServer, ByteString)] -> IO ()
uploadImmutableShares ByteString
storageIndex (ShareMap -> [ByteString] -> [(Int, StorageServer, ByteString)]
uploads ShareMap
targets [ByteString]
streams)

    UploadResult -> IO UploadResult
forall (m :: * -> *) a. Monad m => a -> m a
return (UploadResult -> IO UploadResult)
-> UploadResult -> IO UploadResult
forall a b. (a -> b) -> a -> b
$
        UploadResult :: Reader -> Size -> ShareMap -> UploadResult
UploadResult
            { uploadResultReadCap :: Reader
uploadResultReadCap = Reader
cap
            , uploadResultExistingShares :: Size
uploadResultExistingShares = Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Size) -> Int -> Size
forall a b. (a -> b) -> a -> b
$ ShareMap -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ShareMap
existingShares
            , uploadResultShareMap :: ShareMap
uploadResultShareMap = ShareMap
targets
            }
  where
    storageIndex :: StorageIndex
    storageIndex :: ByteString
storageIndex = Key AES128 -> ByteString
storageIndexHash Key AES128
key

    targetServers :: Parameters -> ShareMap -> ShareMap
    targetServers :: Parameters -> ShareMap -> ShareMap
targetServers Parameters
parameters ShareMap
existingShares = Parameters -> ByteString -> ShareMap -> [StorageServer] -> ShareMap
planSharePlacement Parameters
parameters ByteString
storageIndex ShareMap
existingShares [StorageServer]
servers

    -- Adapt a stream of share data to a stream of share data annotated with
    -- server placement decision.
    uploads ::
        ShareMap ->
        [BL.ByteString] ->
        [(ShareNum, StorageServer, BL.ByteString)]
    uploads :: ShareMap -> [ByteString] -> [(Int, StorageServer, ByteString)]
uploads ShareMap
goal [ByteString]
shareDatav = (Int
 -> Set StorageServer
 -> [(Int, StorageServer, ByteString)]
 -> [(Int, StorageServer, ByteString)])
-> [(Int, StorageServer, ByteString)]
-> ShareMap
-> [(Int, StorageServer, ByteString)]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey ([ByteString]
-> Int
-> Set StorageServer
-> [(Int, StorageServer, ByteString)]
-> [(Int, StorageServer, ByteString)]
makeUpload [ByteString]
shareDatav) [] ShareMap
goal
      where
        makeUpload ::
            [BL.ByteString] ->
            ShareNum ->
            Set.Set StorageServer ->
            [(ShareNum, StorageServer, BL.ByteString)] ->
            [(ShareNum, StorageServer, BL.ByteString)]
        makeUpload :: [ByteString]
-> Int
-> Set StorageServer
-> [(Int, StorageServer, ByteString)]
-> [(Int, StorageServer, ByteString)]
makeUpload [ByteString]
shareDatav' Int
num Set StorageServer
servers' [(Int, StorageServer, ByteString)]
soFar =
            [ ( Int
num
              , StorageServer
server
              , [ByteString]
shareDatav' [ByteString] -> Int -> ByteString
forall a. [a] -> Int -> a
!! Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
num
              )
            | StorageServer
server <- Set StorageServer -> [StorageServer]
forall a. Set a -> [a]
Set.elems Set StorageServer
servers'
            ]
                [(Int, StorageServer, ByteString)]
-> [(Int, StorageServer, ByteString)]
-> [(Int, StorageServer, ByteString)]
forall a. [a] -> [a] -> [a]
++ [(Int, StorageServer, ByteString)]
soFar

defaultParameters :: Parameters
defaultParameters :: Parameters
defaultParameters = Size -> Total -> Int -> Total -> Parameters
Parameters (Size
128 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
1024) Total
10 Int
7 Total
3

-- The adjustment implemented in
-- allmydata.immutable.upload.BaseUploadable.get_all_encoding_parameters
adjustSegmentSize :: Parameters -> Size -> Parameters
adjustSegmentSize :: Parameters -> Size -> Parameters
adjustSegmentSize (Parameters Size
segmentSize Total
total Int
happy Total
required) Size
dataSize =
    Size -> Total -> Int -> Total -> Parameters
Parameters (Size -> Size
effectiveSegmentSize Size
dataSize) Total
total Int
happy Total
required
  where
    effectiveSegmentSize :: Size -> Size
effectiveSegmentSize =
        -- For small files, shrink the segment size to avoid wasting space.
        -- Also make the shrunk value a multiple of required shares or the
        -- encoding doesn't work.
        Total -> Size -> Size
forall m v. (Integral m, Integral v) => m -> v -> v
nextMultipleOf Total
required (Size -> Size) -> (Size -> Size) -> Size -> Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> Size -> Size
forall a. Ord a => a -> a -> a
min Size
segmentSize

-- Create an uploadable with the given key.
filesystemUploadable :: Key AES128 -> FilePath -> Parameters -> IO Uploadable
filesystemUploadable :: Key AES128 -> String -> Parameters -> IO Uploadable
filesystemUploadable Key AES128
key String
path Parameters
params = do
    Handle
fhandle <- String -> IOMode -> IO Handle
openBinaryFile String
path IOMode
ReadMode
    Size
fsize <- Handle -> IO Size
hFileSize Handle
fhandle
    Uploadable -> IO Uploadable
forall (m :: * -> *) a. Monad m => a -> m a
return (Uploadable -> IO Uploadable) -> Uploadable -> IO Uploadable
forall a b. (a -> b) -> a -> b
$
        Uploadable :: Key AES128
-> Size -> Parameters -> (Size -> IO ByteString) -> Uploadable
Uploadable
            { uploadableKey :: Key AES128
uploadableKey = Key AES128
key
            , uploadableSize :: Size
uploadableSize = Size
fsize
            , uploadableParameters :: Parameters
uploadableParameters = Parameters -> Size -> Parameters
adjustSegmentSize Parameters
params Size
fsize
            , -- TODO Consider replacing this with a lazy bytestring or a list of bytestrings
              uploadableReadCleartext :: Size -> IO ByteString
uploadableReadCleartext = Handle -> Int -> IO ByteString
B.hGet Handle
fhandle (Int -> IO ByteString) -> (Size -> Int) -> Size -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
            }

filesystemUploadableWithConvergence :: B.ByteString -> FilePath -> Parameters -> IO Uploadable
filesystemUploadableWithConvergence :: ByteString -> String -> Parameters -> IO Uploadable
filesystemUploadableWithConvergence ByteString
secret String
uploadablePath Parameters
params = do
    -- Allow getConvergentKey to use lazy ByteString to read and hash the
    -- uploadable by letting the handle remain open past the end of this
    -- function.  lazy ByteString will close the handle.
    Handle
uploadableHandle <- String -> IOMode -> IO Handle
openFile String
uploadablePath IOMode
ReadMode
    Handle -> Bool -> IO ()
hSetBinaryMode Handle
uploadableHandle Bool
True

    -- Annoyingly, adjust the segment size here so that the convergence secret
    -- is computed based on the adjusted value.  This is what Tahoe-LAFS does so
    -- it is necessary to arrive at the same converged key.  Whether this part
    -- of the construction is actually important aside from interop, I don't
    -- know.
    Size
size <- Handle -> IO Size
hFileSize Handle
uploadableHandle
    ByteString
content <- Handle -> IO ByteString
BL.hGetContents Handle
uploadableHandle

    ByteString -> Size -> ByteString -> Parameters -> IO Uploadable
memoryUploadableWithConvergence ByteString
secret Size
size ByteString
content Parameters
params

-- TODO Consider lazy bytestring here instead
memoryUploadableWithConvergence :: B.ByteString -> Integer -> BL.ByteString -> Parameters -> IO Uploadable
memoryUploadableWithConvergence :: ByteString -> Size -> ByteString -> Parameters -> IO Uploadable
memoryUploadableWithConvergence ByteString
secret Size
size ByteString
content Parameters
params =
    let key :: Key AES128
key = ByteString -> Parameters -> ByteString -> Key AES128
getConvergentKey ByteString
secret (Parameters -> Size -> Parameters
adjustSegmentSize Parameters
params Size
size) ByteString
content
     in Key AES128 -> Size -> ByteString -> Parameters -> IO Uploadable
memoryUploadable Key AES128
key Size
size ByteString
content Parameters
params

memoryUploadable :: Key AES128 -> Integer -> BL.ByteString -> Parameters -> IO Uploadable
memoryUploadable :: Key AES128 -> Size -> ByteString -> Parameters -> IO Uploadable
memoryUploadable Key AES128
key Size
size ByteString
content Parameters
params =
    let makeReader :: BL.ByteString -> IO (Integer -> IO BL.ByteString)
        makeReader :: ByteString -> IO (Size -> IO ByteString)
makeReader ByteString
allContent =
            let cas :: Int64 -> ByteString -> (ByteString, ByteString)
cas Int64
len ByteString
content' = (Int64 -> ByteString -> ByteString
BL.drop Int64
len ByteString
content', Int64 -> ByteString -> ByteString
BL.take Int64
len ByteString
content')
             in do
                    IORef ByteString
contentRef <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef ByteString
allContent
                    (Size -> IO ByteString) -> IO (Size -> IO ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Size -> IO ByteString) -> IO (Size -> IO ByteString))
-> (Size -> IO ByteString) -> IO (Size -> IO ByteString)
forall a b. (a -> b) -> a -> b
$ (IORef IO ByteString
-> (ByteString -> (ByteString, ByteString)) -> IO ByteString
forall (m :: * -> *) a b.
MonadConc m =>
IORef m a -> (a -> (a, b)) -> m b
modifyIORefCAS IORef ByteString
IORef IO ByteString
contentRef ((ByteString -> (ByteString, ByteString)) -> IO ByteString)
-> (Int64 -> ByteString -> (ByteString, ByteString))
-> Int64
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> ByteString -> (ByteString, ByteString)
cas) (Int64 -> IO ByteString)
-> (Size -> Int64) -> Size -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
     in do
            Size -> IO ByteString
reader <- ByteString -> IO (Size -> IO ByteString)
makeReader ByteString
content
            Uploadable -> IO Uploadable
forall (m :: * -> *) a. Monad m => a -> m a
return (Uploadable -> IO Uploadable) -> Uploadable -> IO Uploadable
forall a b. (a -> b) -> a -> b
$
                Uploadable :: Key AES128
-> Size -> Parameters -> (Size -> IO ByteString) -> Uploadable
Uploadable
                    { uploadableKey :: Key AES128
uploadableKey = Key AES128
key
                    , uploadableSize :: Size
uploadableSize = Size
size
                    , uploadableParameters :: Parameters
uploadableParameters = Parameters -> Size -> Parameters
adjustSegmentSize Parameters
params Size
size
                    , -- TODO Consider replacing this with a lazy bytestring or a list of bytestrings
                      uploadableReadCleartext :: Size -> IO ByteString
uploadableReadCleartext = (ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (IO ByteString -> IO ByteString)
-> (Size -> IO ByteString) -> Size -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> IO ByteString
reader
                    }

-- allmydata.immutable.upload.FileHandle._get_encryption_key_convergent
getConvergentKey :: B.ByteString -> Parameters -> BL.ByteString -> Key AES128
getConvergentKey :: ByteString -> Parameters -> ByteString -> Key AES128
getConvergentKey ByteString
secret Parameters
params ByteString
content =
    Maybe (Key AES128) -> Key AES128
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Key AES128) -> Key AES128)
-> (ByteString -> Maybe (Key AES128)) -> ByteString -> Key AES128
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoFailable (Key AES128) -> Maybe (Key AES128)
forall a. CryptoFailable a -> Maybe a
maybeCryptoError (CryptoFailable (Key AES128) -> Maybe (Key AES128))
-> (ByteString -> CryptoFailable (Key AES128))
-> ByteString
-> Maybe (Key AES128)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> CryptoFailable (Key AES128)
forall cipher key.
(Cipher cipher, ByteArray key) =>
key -> CryptoFailable cipher
cipherInit (ByteString -> Key AES128) -> ByteString -> Key AES128
forall a b. (a -> b) -> a -> b
$ ByteString -> Parameters -> ByteString -> ByteString
convergenceEncryptionHashLazy ByteString
secret Parameters
params ByteString
content

buildKeyIO :: forall cipher. BlockCipher cipher => IO (Key cipher)
buildKeyIO :: IO (Key cipher)
buildKeyIO = do
    ScrubbedBytes
keyBytes <- Int -> IO ScrubbedBytes
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes @IO @ScrubbedBytes Int
keySize
    Key cipher -> IO (Key cipher)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key cipher -> IO (Key cipher))
-> (ScrubbedBytes -> Key cipher)
-> ScrubbedBytes
-> IO (Key cipher)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Key cipher) -> Key cipher
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Key cipher) -> Key cipher)
-> (ScrubbedBytes -> Maybe (Key cipher))
-> ScrubbedBytes
-> Key cipher
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoFailable (Key cipher) -> Maybe (Key cipher)
forall a. CryptoFailable a -> Maybe a
maybeCryptoError (CryptoFailable (Key cipher) -> Maybe (Key cipher))
-> (ScrubbedBytes -> CryptoFailable (Key cipher))
-> ScrubbedBytes
-> Maybe (Key cipher)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScrubbedBytes -> CryptoFailable (Key cipher)
forall cipher key.
(Cipher cipher, ByteArray key) =>
key -> CryptoFailable cipher
cipherInit (ScrubbedBytes -> IO (Key cipher))
-> ScrubbedBytes -> IO (Key cipher)
forall a b. (a -> b) -> a -> b
$ ScrubbedBytes
keyBytes
  where
    keySize :: Int
keySize = case cipher -> KeySizeSpecifier
forall cipher. Cipher cipher => cipher -> KeySizeSpecifier
cipherKeySize @cipher cipher
forall a. HasCallStack => a
undefined of
        KeySizeRange Int
_ Int
high -> Int
high
        KeySizeEnum [] -> String -> Int
forall a. HasCallStack => String -> a
error String
"no key sizes!"
        KeySizeEnum (Int
s : [Int]
_) -> Int
s
        KeySizeFixed Int
s -> Int
s

-- Create an uploadable with a random key.
filesystemUploadableRandomConvergence :: FilePath -> Parameters -> IO Uploadable
filesystemUploadableRandomConvergence :: String -> Parameters -> IO Uploadable
filesystemUploadableRandomConvergence String
path Parameters
params = do
    Key AES128
key <- IO (Key AES128)
forall cipher. BlockCipher cipher => IO (Key cipher)
buildKeyIO :: IO (Key AES128)
    Key AES128 -> String -> Parameters -> IO Uploadable
filesystemUploadable Key AES128
key String
path Parameters
params

prettyFormatSharemap :: ShareMap -> Text
prettyFormatSharemap :: ShareMap -> Text
prettyFormatSharemap ShareMap
sharemap =
    Text -> [Text] -> Text
intercalate
        Text
"\n"
        [ [Text] -> Text
Text.concat [Text
"\t", (Int, Set StorageServer) -> Text
showElem (Int, Set StorageServer)
elem']
        | (Int, Set StorageServer)
elem' <- ShareMap -> [(Int, Set StorageServer)]
forall k a. Map k a -> [(k, a)]
Map.toList ShareMap
sharemap
        ]
  where
    showElem :: (ShareNum, Set.Set StorageServer) -> Text
    showElem :: (Int, Set StorageServer) -> Text
showElem (Int
shareNum, Set StorageServer
servers) =
        [Text] -> Text
Text.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
            [ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
shareNum
            , Text
":"
            ]
                [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
", " ((StorageServer -> Text) -> [StorageServer] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map StorageServer -> Text
storageServerID (Set StorageServer -> [StorageServer]
forall a. Set a -> [a]
Set.toList Set StorageServer
servers))