Merge branch 'clean-up-capabilities' into 'main'

Turn WhichShare into an associated type family See merge request !7

Merge branch 'clean-up-capabilities' into 'main'
8d47a5ab · Shae Erisson · b51c2a1b · 134fbbc0 · 8d47a5ab · 8d47a5ab
Commit 8d47a5ab authored 1 year ago by Shae Erisson
--- a/cabal.project
+++ b/cabal.project
@@ -5,6 +5,7 @@ packages: .
          https://whetstone.private.storage/privatestorage/tahoe-ssk/-/archive/0.2.0.0/tahoe-ssk-0.2.0.0.tar.gz
          https://whetstone.private.storage/privatestorage/tahoe-chk/-/archive/0.1.0.1/tahoe-chk-0.1.0.1.tar.gz
          https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/archive/0.3.0.0/tahoe-great-black-swamp-0.3.0.0.tar.gz
+          ../tahoe-directory
 package zlib
        -- Turn on discovery of the underlying zlib using pkg-config.  This

--- a/cabal.project.freeze
+++ b/cabal.project.freeze
+active-repositories: hackage.haskell.org:merge
+constraints: any.Cabal ==3.2.1.0,
+             any.HUnit ==1.6.2.0,
+             any.OneTuple ==0.3.1,
+             any.QuickCheck ==2.14.3,
+             QuickCheck -old-random +templatehaskell,
+             any.StateVar ==1.2.2,
+             any.adjunctions ==4.4.2,
+             any.aeson ==2.1.2.1,
+             aeson -cffi +ordered-keymap,
+             any.aeson-pretty ==0.8.9,
+             aeson-pretty -lib-only,
+             any.ansi-terminal ==0.11.5,
+             ansi-terminal -example +win32-2-13-1,
+             any.ansi-terminal-types ==0.11.5,
+             any.ansi-wl-pprint ==1.0.2,
+             ansi-wl-pprint -example,
+             any.appar ==0.1.8,
+             any.array ==0.5.4.0,
+             any.asn1-encoding ==0.9.6,
+             any.asn1-parse ==0.9.5,
+             any.asn1-types ==0.3.4,
+             any.assoc ==1.1,
+             assoc +tagged,
+             any.async ==2.2.4,
+             async -bench,
+             any.atomic-primops ==0.8.4,
+             atomic-primops -debug,
+             any.attoparsec ==0.14.4,
+             attoparsec -developer,
+             any.attoparsec-iso8601 ==1.1.0.0,
+             any.auto-update ==0.1.6,
+             any.barbies ==2.0.4.0,
+             any.base ==4.14.3.0,
+             any.base-compat ==0.12.2,
+             any.base-compat-batteries ==0.12.2,
+             any.base-orphans ==0.9.0,
+             any.base32 ==0.2.2.0,
+             any.base64-bytestring ==1.2.1.0,
+             any.basement ==0.0.15,
+             any.bifunctors ==5.5.15,
+             bifunctors +semigroups +tagged,
+             any.binary ==0.8.8.0,
+             any.bitvec ==1.1.4.0,
+             bitvec -libgmp,
+             any.blaze-builder ==0.4.2.2,
+             any.blaze-html ==0.9.1.2,
+             any.blaze-markup ==0.8.2.8,
+             any.boring ==0.2.1,
+             boring +tagged,
+             any.bsb-http-chunked ==0.0.0.4,
+             any.byteorder ==1.0.4,
+             any.bytestring ==0.10.12.0,
+             any.bytestring-builder ==0.10.8.2.0,
+             bytestring-builder +bytestring_has_builder,
+             any.cabal-doctest ==1.0.9,
+             any.call-stack ==0.4.0,
+             any.case-insensitive ==1.2.1.0,
+             any.cborg ==0.2.9.0,
+             cborg +optimize-gmp,
+             any.cborg-json ==0.2.5.0,
+             any.cereal ==0.5.8.3,
+             cereal -bytestring-builder,
+             any.charset ==0.3.9,
+             any.cipher-aes128 ==0.7.0.6,
+             cipher-aes128 -test,
+             any.clock ==0.8.3,
+             clock -llvm,
+             any.cmdargs ==0.10.22,
+             cmdargs +quotation -testprog,
+             any.colour ==2.3.6,
+             any.comonad ==5.0.8,
+             comonad +containers +distributive +indexed-traversable,
+             any.concurrency ==1.11.0.2,
+             any.concurrent-output ==1.10.18,
+             any.conduit ==1.3.5,
+             any.connection ==0.3.1,
+             any.constraints ==0.13.4,
+             any.containers ==0.6.5.1,
+             any.contravariant ==1.5.5,
+             contravariant +semigroups +statevar +tagged,
+             any.cookie ==0.4.6,
+             any.crypto-api ==0.13.3,
+             crypto-api -all_cpolys,
+             any.cryptonite ==0.30,
+             cryptonite -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq -support_pclmuldq +support_rdrand -support_sse +use_target_attributes,
+             any.data-array-byte ==0.1.0.1,
+             any.data-default-class ==0.1.2.0,
+             any.data-fix ==0.3.2,
+             any.dec ==0.0.5,
+             any.deepseq ==1.4.4.0,
+             any.deriving-aeson ==0.2.9,
+             any.directory ==1.3.6.0,
+             any.distributive ==0.6.2.1,
+             distributive +semigroups +tagged,
+             any.dlist ==1.0,
+             dlist -werror,
+             any.easy-file ==0.2.5,
+             any.entropy ==0.4.1.10,
+             entropy -donotgetentropy,
+             any.erf ==2.0.0.0,
+             any.exceptions ==0.10.4,
+             any.extra ==1.7.13,
+             any.fast-logger ==3.2.1,
+             any.fec ==0.1.1,
+             any.file-embed ==0.0.15.0,
+             any.filepath ==1.4.2.1,
+             any.foldable1-classes-compat ==0.1,
+             foldable1-classes-compat +tagged,
+             any.foldl ==1.4.14,
+             any.free ==5.1.10,
+             any.generically ==0.1.1,
+             any.ghc-boot-th ==8.10.7,
+             any.ghc-prim ==0.6.1,
+             any.half ==0.3.1,
+             any.happy ==1.20.1.1,
+             any.hashable ==1.4.2.0,
+             hashable +integer-gmp -random-initial-seed,
+             any.haskell-lexer ==1.1.1,
+             any.hedgehog ==1.2,
+             any.hourglass ==0.2.12,
+             any.hsc2hs ==0.68.9,
+             hsc2hs -in-ghc-tree,
+             any.http-api-data ==0.5,
+             http-api-data -use-text-show,
+             any.http-client ==0.7.13.1,
+             http-client +network-uri,
+             any.http-client-tls ==0.3.6.1,
+             any.http-date ==0.0.11,
+             any.http-media ==0.8.0.0,
+             any.http-types ==0.12.3,
+             any.http2 ==4.1.2,
+             http2 -devel -h2spec,
+             any.indexed-traversable ==0.1.2.1,
+             any.indexed-traversable-instances ==0.1.1.2,
+             any.integer-gmp ==1.0.3.0,
+             any.integer-logarithms ==1.0.3.1,
+             integer-logarithms -check-bounds +integer-gmp,
+             any.invariant ==0.6.1,
+             any.iproute ==1.7.12,
+             any.kan-extensions ==5.2.5,
+             any.lens ==5.2.2,
+             lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy,
+             any.libyaml ==0.1.2,
+             libyaml -no-unicode -system-libyaml,
+             any.lifted-async ==0.10.2.4,
+             any.lifted-base ==0.2.3.12,
+             any.megaparsec ==9.2.1,
+             megaparsec -dev,
+             any.memory ==0.18.0,
+             memory +support_bytestring +support_deepseq,
+             any.mime-types ==0.1.1.0,
+             any.mmorph ==1.2.0,
+             any.monad-control ==1.0.3.1,
+             any.monad-loops ==0.4.3,
+             monad-loops +base4,
+             any.mono-traversable ==1.0.15.3,
+             any.mtl ==2.2.2,
+             any.network ==3.1.4.0,
+             network -devel,
+             any.network-byte-order ==0.1.6,
+             any.network-uri ==2.6.4.2,
+             any.old-locale ==1.0.0.7,
+             any.old-time ==1.1.0.3,
+             any.optparse-applicative ==0.18.1.0,
+             optparse-applicative +process,
+             any.parallel ==3.2.2.0,
+             any.parsec ==3.1.14.0,
+             any.parser-combinators ==1.3.0,
+             parser-combinators -dev,
+             any.parsers ==0.12.11,
+             parsers +attoparsec +binary +parsec,
+             any.pem ==0.2.4,
+             any.pretty ==1.1.3.6,
+             any.pretty-show ==1.10,
+             any.prettyprinter ==1.7.1,
+             prettyprinter -buildreadme +text,
+             any.prettyprinter-ansi-terminal ==1.1.3,
+             any.prettyprinter-compat-ansi-wl-pprint ==1.0.2,
+             any.primitive ==0.8.0.0,
+             any.process ==1.6.13.2,
+             any.profunctors ==5.6.2,
+             any.psqueues ==0.2.7.3,
+             any.random ==1.2.1.1,
+             any.recv ==0.1.0,
+             any.reflection ==2.1.7,
+             reflection -slow +template-haskell,
+             any.resourcet ==1.2.6,
+             any.rts ==1.0.1,
+             any.safe ==0.3.19,
+             any.safe-exceptions ==0.1.7.3,
+             any.scientific ==0.3.7.0,
+             scientific -bytestring-builder -integer-simple,
+             any.semialign ==1.3,
+             semialign +semigroupoids,
+             any.semigroupoids ==5.3.7,
+             semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,
+             any.semigroups ==0.20,
+             semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers,
+             any.serialise ==0.2.6.0,
+             serialise +newtime15,
+             any.servant ==0.19.1,
+             any.servant-client ==0.19,
+             any.servant-client-core ==0.19,
+             any.servant-docs ==0.12,
+             any.servant-foreign ==0.15.4,
+             any.servant-js ==0.9.4.2,
+             servant-js -example,
+             any.servant-server ==0.19.2,
+             any.simple-sendfile ==0.2.31,
+             simple-sendfile +allow-bsd -fallback,
+             any.singleton-bool ==0.1.6,
+             any.socks ==0.6.1,
+             any.some ==1.0.5,
+             some +newtype-unsafe,
+             any.sop-core ==0.5.0.2,
+             any.split ==0.2.3.5,
+             any.splitmix ==0.1.0.4,
+             splitmix -optimised-mixer,
+             any.stm ==2.5.0.1,
+             any.streaming-commons ==0.2.2.6,
+             streaming-commons -use-bytestring-builder,
+             any.strict ==0.5,
+             any.string-conversions ==0.4.0.1,
+             any.tagged ==0.8.7,
+             tagged +deepseq +transformers,
+             any.tahoe-chk ==0.1.0.1,
+             any.tahoe-great-black-swamp ==0.3.0.0,
+             any.tahoe-ssk ==0.2.0.0,
+             any.tasty ==1.4.3,
+             tasty +unix,
+             any.tasty-hedgehog ==1.4.0.1,
+             any.tasty-hunit ==0.10.0.3,
+             any.template-haskell ==2.16.0.0,
+             any.terminal-size ==0.3.4,
+             any.text ==1.2.4.1,
+             any.text-short ==0.1.5,
+             text-short -asserts,
+             any.th-abstraction ==0.5.0.0,
+             any.th-compat ==0.1.4,
+             any.these ==1.2,
+             any.time ==1.9.3,
+             any.time-compat ==1.9.6.1,
+             time-compat -old-locale,
+             any.time-manager ==0.0.0,
+             any.tls ==1.6.0,
+             tls +compat -hans +network,
+             any.tls-session-manager ==0.0.4,
+             any.transformers ==0.5.6.2,
+             any.transformers-base ==0.4.6,
+             transformers-base +orphaninstances,
+             any.transformers-compat ==0.7.2,
+             transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
+             any.tree-diff ==0.3.0.1,
+             any.type-equality ==1,
+             any.universe-base ==1.1.3.1,
+             any.unix ==2.7.2.2,
+             any.unix-compat ==0.7,
+             unix-compat -old-time,
+             any.unix-time ==0.4.9,
+             any.unliftio ==0.2.24.0,
+             any.unliftio-core ==0.2.1.0,
+             any.unordered-containers ==0.2.19.1,
+             unordered-containers -debug,
+             any.utf8-string ==1.0.2,
+             any.utility-ht ==0.0.17,
+             any.uuid-types ==1.0.5,
+             any.vault ==0.3.1.5,
+             vault +useghc,
+             any.vector ==0.13.0.0,
+             vector +boundschecks -internalchecks -unsafechecks -wall,
+             any.vector-algorithms ==0.9.0.1,
+             vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks,
+             any.vector-stream ==0.1.0.0,
+             any.void ==0.7.3,
+             void -safe,
+             any.wai ==3.2.3,
+             any.wai-app-static ==3.1.7.4,
+             wai-app-static +cryptonite -print,
+             any.wai-extra ==3.1.13.0,
+             wai-extra -build-example,
+             any.wai-logger ==2.4.0,
+             any.warp ==3.3.25,
+             warp +allow-sendfilefd -network-bytestring -warp-debug +x509,
+             any.warp-tls ==3.3.6,
+             any.witherable ==0.4.2,
+             any.wl-pprint-annotated ==0.1.0.1,
+             any.word8 ==0.1.3,
+             any.x509 ==1.7.7,
+             any.x509-store ==1.6.9,
+             any.x509-system ==1.6.7,
+             any.x509-validation ==1.6.12,
+             any.yaml ==0.11.11.0,
+             yaml +no-examples +no-exe,
+             any.zlib ==0.6.3.0,
+             zlib -bundled-c-zlib -non-blocking-ffi +pkg-config
+index-state: hackage.haskell.org 2023-06-02T14:54:08Z
--- a/download-sdmf/Main.hs
+++ b/download-sdmf/Main.hs
+{-# LANGUAGE FlexibleContexts #-}
 module Main where
 import qualified Data.ByteString as B

--- a/src/Tahoe/Download.hs
+++ b/src/Tahoe/Download.hs
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 {- | A high-level interface to downloading share data as bytes from storage
 servers.
@@ -18,7 +18,7 @@ module Tahoe.Download (
 import Control.Exception (Exception (displayException), SomeException, try)
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import Data.Bifunctor (Bifunctor (first, second))
-import Data.Binary (Word16, decodeOrFail)
+import Data.Binary (Word16)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as LB
 import Data.Either (partitionEithers, rights)
@@ -37,13 +37,20 @@ import Tahoe.Download.Internal.Mutable
 type DownloadTask = (ShareNum, StorageServer)
 -- | A downloaded share
-type Share = (ShareNum, LB.ByteString)
+type DownloadedShare = (ShareNum, LB.ByteString)
 {- | Recover the application data associated with a given capability from the
 given servers, if possible.
 -}
 download ::
-    (MonadIO m, Verifiable verifyCap, Readable readCap verifyCap) =>
+    -- To download, we require a capability for which there is a Readable
+    -- instance because are also going to decrypt the ciphertext.  A different
+    -- download interface that skips decryption could settle for a capability
+    -- with a Verifiable instance.  We also require that the Verifier type for
+    -- the read capability has a Verifiable instance because Verifiable is
+    -- what gives us the ability to locate the shares.  If we located
+    -- separately from decrypting this might be simpler.
+    (MonadIO m, Readable readCap, Verifiable v, Verifier readCap ~ v) =>
    -- | Information about the servers from which to consider downloading shares
    -- representing the application data.
    Map.Map StorageServerID StorageServerAnnouncement ->
@@ -99,17 +106,6 @@ firstRightM f op (x : xs) = do
  where
    recurse = firstRightM f op xs
-{- | Deserialize some bytes representing some kind of share to that kind of
- share, if possible.
-}
-bytesToShare :: LB.ByteString -> Either DeserializeError WhichShare
-bytesToShare bytes = do
-    case decodeOrFail bytes of
-        Right (_, _, r) -> Right $ CHK r
-        Left _ -> case decodeOrFail bytes of
-            Right (_, _, r) -> Right $ SDMF r
-            Left _ -> Left UnknownDeserializeError
 {- | Execute each download task sequentially and return only the successful
 results.
 -}
@@ -120,7 +116,7 @@ executeDownloadTasks ::
    -- | The downloads to attempt.
    [DownloadTask] ->
    -- | The results of all successful downloads.
-    m [Share]
+    m [DownloadedShare]
 executeDownloadTasks storageIndex tasks = do
    downloadResults <- mapM (downloadShare storageIndex) tasks
    pure . rights $ inject <$> downloadResults
@@ -163,16 +159,16 @@ locateShares servers lookupServer storageIndex required =
 decode them and decrypt the contents of possible.
 -}
 decodeShares ::
-    (MonadIO m, Readable readCap verifyCap) =>
+    (MonadIO m, Readable readCap, Verifiable v, v ~ Verifier readCap) =>
    -- | The read capability which allows the contents to be decrypted.
    readCap ->
    -- | The results of downloading the shares.
-    [Share] ->
+    [DownloadedShare] ->
    Int ->
    m (Either DownloadError LB.ByteString)
 decodeShares r shares required = do
    -- Filter down to shares we actually got.
-    let fewerShares :: [(ShareNum, Either DeserializeError WhichShare)] = second bytesToShare <$> shares
+    let fewerShares = second (deserializeShare (getVerifiable r)) <$> shares
        onlyDecoded = rights $ (\(a, b) -> (fromIntegral a,) <$> b) <$> fewerShares
    if length onlyDecoded < required
        then pure $ Left NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = fromIntegral required, notEnoughDecodedSharesFound = length onlyDecoded}

--- a/src/Tahoe/Download/Internal/Capability.hs
+++ b/src/Tahoe/Download/Internal/Capability.hs
-{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TypeFamilies #-}
 module Tahoe.Download.Internal.Capability where
 import Control.Monad.IO.Class
 import Data.Bifunctor (Bifunctor (..))
 import Data.Binary (decodeOrFail)
+import Data.Binary.Get (ByteOffset)
 import qualified Data.ByteString.Lazy as LB
 import qualified Data.Set as Set
 import qualified Tahoe.CHK
@@ -17,16 +18,11 @@ import Tahoe.Download.Internal.Client
 import qualified Tahoe.SDMF as SDMF
 import qualified Tahoe.SDMF.Internal.Keys as SDMF.Keys
-{- | Represent the kind of share to operate on.  This forms a closed world of
- share types.  It might eventually be interesting to make an open world
- variation instead.
-}
-data WhichShare
-    = CHK {unWhichCHK :: Tahoe.CHK.Share.Share}
-    | SDMF {unWhichSDMF :: SDMF.Share}
 -- | A capability which confers the ability to locate and verify some stored data.
 class Verifiable v where
+    -- | Represent the type of share to operate on.
+    type ShareT v
    -- | Ask a storage server which share numbers related to this capability it
    -- is holding.  This is an unverified result and the storage server could
    -- present incorrect information.  Even if it correctly reports that it
@@ -40,40 +36,63 @@ class Verifiable v where
    -- | Get the location information for shares of this capability.
    getStorageIndex :: v -> StorageIndex
-class (Verifiable v) => Readable r v | r -> v where
+    -- | Deserialize some bytes representing some kind of share to the kind of
+    -- share associated with this capability type, if possible.
+    deserializeShare ::
+        -- | A type witness revealing what type of share to decode to.
+        v ->
+        -- | The bytes of the serialized share.
+        LB.ByteString ->
+        Either (LB.ByteString, ByteOffset, String) (ShareT v)
+{- | A capability which confers the ability to recover plaintext from
+ ciphertext.
+-}
+class Readable r where
+    -- | Represent the type of a Verifiable associated with the Readable.
+    type Verifier r
    -- | Attentuate the capability.
-    getVerifiable :: r -> v
+    getVerifiable :: r -> Verifier r
    -- | Interpret the required number of shares to recover the plaintext.
    --
    -- Note: might want to split the two functions below out of decodeShare
    --
-    -- shareToCipherText :: r -> [(Int, WhichShare)] -> LB.ByteString
+    -- shareToCipherText :: r -> [(Int, ShareT r)] -> LB.ByteString
    --
    -- cipherTextToPlainText :: r -> LB.ByteString -> LB.ByteString
-    decodeShare :: MonadIO m => r -> [(Int, WhichShare)] -> m (Either DownloadError LB.ByteString)
+    decodeShare :: MonadIO m => r -> [(Int, ShareT (Verifier r))] -> m (Either DownloadError LB.ByteString)
 instance Verifiable CHK.Verifier where
+    type ShareT CHK.Verifier = Tahoe.CHK.Share.Share
    getShareNumbers v s = liftIO $ storageServerGetBuckets s (CHK.storageIndex v)
    getStorageIndex CHK.Verifier{storageIndex} = storageIndex
    -- CHK is pure, we don't have to ask the StorageServer
    getRequiredTotal CHK.Verifier{required, total} _ = pure $ pure (fromIntegral required, fromIntegral total)
+    deserializeShare _ = fmap (\(_, _, c) -> c) . decodeOrFail
 {- | A capability which confers the ability to interpret some stored data to
 recover the original plaintext.  Additionally, it can be attentuated to a
 Verifiable.
 -}
-instance Readable CHK.Reader CHK.Verifier where
+instance Readable CHK.Reader where
+    type Verifier CHK.Reader = CHK.Verifier
    getVerifiable = CHK.verifier
    decodeShare r shareList = do
-        cipherText <- liftIO $ Tahoe.CHK.decode r (second unWhichCHK <$> shareList)
+        cipherText <- liftIO $ Tahoe.CHK.decode r shareList
        case cipherText of
            Nothing -> pure $ Left ShareDecodingFailed
            Just ct ->
                pure . Right $ Tahoe.CHK.Encrypt.decrypt (CHK.readKey r) ct
 instance Verifiable SDMF.Verifier where
+    type ShareT SDMF.Verifier = SDMF.Share
    getShareNumbers v s = liftIO $ storageServerGetBuckets s (SDMF.Keys.unStorageIndex $ SDMF.verifierStorageIndex v)
    getStorageIndex = SDMF.Keys.unStorageIndex . SDMF.verifierStorageIndex
    getRequiredTotal SDMF.Verifier{..} ss = do
@@ -82,10 +101,13 @@ instance Verifiable SDMF.Verifier where
            Left _ -> pure Nothing
            Right (_, _, sh) -> pure $ pure (fromIntegral $ SDMF.shareRequiredShares sh, fromIntegral $ SDMF.shareTotalShares sh)
-instance Readable SDMF.Reader SDMF.Verifier where
+    deserializeShare _ = fmap (\(_, _, c) -> c) . decodeOrFail
+instance Readable SDMF.Reader where
+    type Verifier SDMF.Reader = SDMF.Verifier
    getVerifiable = SDMF.readerVerifier
    decodeShare r shareList = do
-        cipherText <- Right <$> liftIO (SDMF.decode r (bimap fromIntegral unWhichSDMF <$> shareList))
+        cipherText <- Right <$> liftIO (SDMF.decode r (first fromIntegral <$> shareList))
        case cipherText of
            Left _ -> pure $ Left ShareDecodingFailed
            Right ct -> do
@@ -94,7 +116,7 @@ instance Readable SDMF.Reader SDMF.Verifier where
                pure . Right $ SDMF.decrypt readKey iv ct
              where
                readKey = SDMF.readerReadKey r
-                iv = SDMF.shareIV (unWhichSDMF . snd . head $ shareList)
+                iv = SDMF.shareIV (snd . head $ shareList)
 print' :: MonadIO m => String -> m ()
 -- print' = liftIO . putStrLn