diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index 236b47d7160f841abe9e56c59f8d3604d4bf2f5b..89fb733f772f3e557fb0c224b40f13eb5a430e46 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -35,7 +35,7 @@ cabal-build-and-test:
# shortcoming of this approach is that the cache will grow without bounds
# as our dependencies change. It would be nice if there were a way to
# trim stale dependencies from it periodically.
- key: "v0-cabal"
+ key: "v1-cabal"
# Even if a build fails (eg because of a test suite failure or because the
# job timed out because building things took too long), there will be
@@ -56,7 +56,7 @@ cabal-build-and-test:
# This is only done in CI configuration because non-CI users probably
# want their local cabal configuration left alone.
cat >cabal.project.local <<EOF
- store-dir: $CI_PROJECT_DIR/.cabal
+ store-dir: $CI_PROJECT_DIR/.cabal/store
remote-repo-cache: $CI_PROJECT_DIR/.cabal/packages
EOF
nix run .#cabal-test
diff --git a/app/Main.hs b/app/Main.hs
index 80adaaa9cc056d1d0c5b3a06a22c48bd4ff2c3fe..2b87ca658b7f582f4d56e79fe8ba82b372be32ce 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,8 +1,5 @@
module Main where
-import qualified MyLib (someFunc)
-
main :: IO ()
main = do
putStrLn "Hello, Haskell!"
- MyLib.someFunc
diff --git a/cabal.project b/cabal.project
new file mode 100644
index 0000000000000000000000000000000000000000..c216d6e9ce25190cc1b5794854ce6eae5b300174
--- /dev/null
+++ b/cabal.project
@@ -0,0 +1,13 @@
+packages: .
+ -- These aren't released on hackage yet so we have to grab them
+ -- straight from the vcs host. Probably should do some releases
+ -- soon.
+ https://whetstone.private.storage/privatestorage/tahoe-chk/-/archive/0.1.0.0/tahoe-chk-0.1.0.0.tar.gz
+ https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/archive/0.1.0.1/tahoe-great-black-swamp-0.1.0.1.tar.gz
+
+package zlib
+ -- Turn on discovery of the underlying zlib using pkg-config. This
+ -- fixes build failures when the underlying zlib is not in the
+ -- traditional location but is discoverable with pkg-config. It might
+ -- break non-pkg-config platforms.
+ flags: +pkg-config
diff --git a/flake.lock b/flake.lock
index 6c3fe1bf377e3c0ad07f8a1f529aedca608f73a9..b268d888768c5de6920c637dcf97bfc0f341961f 100644
--- a/flake.lock
+++ b/flake.lock
@@ -16,6 +16,38 @@
"type": "github"
}
},
+ "flake-compat_2": {
+ "flake": false,
+ "locked": {
+ "lastModified": 1673956053,
+ "narHash": "sha256-4gtG9iQuiKITOjNQQeQIpoIB6b16fm+504Ch3sNKLd8=",
+ "owner": "edolstra",
+ "repo": "flake-compat",
+ "rev": "35bb57c0c8d8b62bbfd284272c928ceb64ddbde9",
+ "type": "github"
+ },
+ "original": {
+ "owner": "edolstra",
+ "repo": "flake-compat",
+ "type": "github"
+ }
+ },
+ "flake-compat_3": {
+ "flake": false,
+ "locked": {
+ "lastModified": 1673956053,
+ "narHash": "sha256-4gtG9iQuiKITOjNQQeQIpoIB6b16fm+504Ch3sNKLd8=",
+ "owner": "edolstra",
+ "repo": "flake-compat",
+ "rev": "35bb57c0c8d8b62bbfd284272c928ceb64ddbde9",
+ "type": "github"
+ },
+ "original": {
+ "owner": "edolstra",
+ "repo": "flake-compat",
+ "type": "github"
+ }
+ },
"flake-utils": {
"locked": {
"lastModified": 1667395993,
@@ -46,6 +78,66 @@
"type": "github"
}
},
+ "flake-utils_3": {
+ "locked": {
+ "lastModified": 1667395993,
+ "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "flake-utils_4": {
+ "locked": {
+ "lastModified": 1676283394,
+ "narHash": "sha256-XX2f9c3iySLCw54rJ/CZs+ZK6IQy7GXNY4nSOyu2QG4=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "3db36a8b464d0c4532ba1c7dda728f4576d6d073",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "flake-utils_5": {
+ "locked": {
+ "lastModified": 1676283394,
+ "narHash": "sha256-XX2f9c3iySLCw54rJ/CZs+ZK6IQy7GXNY4nSOyu2QG4=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "3db36a8b464d0c4532ba1c7dda728f4576d6d073",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "flake-utils_6": {
+ "locked": {
+ "lastModified": 1676283394,
+ "narHash": "sha256-XX2f9c3iySLCw54rJ/CZs+ZK6IQy7GXNY4nSOyu2QG4=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "3db36a8b464d0c4532ba1c7dda728f4576d6d073",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
"gitignore": {
"inputs": {
"nixpkgs": [
@@ -68,12 +160,100 @@
"type": "github"
}
},
+ "gitignore_2": {
+ "inputs": {
+ "nixpkgs": [
+ "tahoe-chk",
+ "hs-flake-utils",
+ "pre-commit-hooks",
+ "nixpkgs"
+ ]
+ },
+ "locked": {
+ "lastModified": 1660459072,
+ "narHash": "sha256-8DFJjXG8zqoONA1vXtgeKXy68KdJL5UaXR8NtVMUbx8=",
+ "owner": "hercules-ci",
+ "repo": "gitignore.nix",
+ "rev": "a20de23b925fd8264fd7fad6454652e142fd7f73",
+ "type": "github"
+ },
+ "original": {
+ "owner": "hercules-ci",
+ "repo": "gitignore.nix",
+ "type": "github"
+ }
+ },
+ "gitignore_3": {
+ "inputs": {
+ "nixpkgs": [
+ "tahoe-great-black-swamp",
+ "hs-flake-utils",
+ "pre-commit-hooks",
+ "nixpkgs"
+ ]
+ },
+ "locked": {
+ "lastModified": 1660459072,
+ "narHash": "sha256-8DFJjXG8zqoONA1vXtgeKXy68KdJL5UaXR8NtVMUbx8=",
+ "owner": "hercules-ci",
+ "repo": "gitignore.nix",
+ "rev": "a20de23b925fd8264fd7fad6454652e142fd7f73",
+ "type": "github"
+ },
+ "original": {
+ "owner": "hercules-ci",
+ "repo": "gitignore.nix",
+ "type": "github"
+ }
+ },
"hs-flake-utils": {
"inputs": {
"flake-utils": "flake-utils_2",
"nixpkgs": "nixpkgs",
"pre-commit-hooks": "pre-commit-hooks"
},
+ "locked": {
+ "lastModified": 1681762240,
+ "narHash": "sha256-+PLx9xHBvV70dA7Gy/+YTH1w3PcSOrGV0z0rGxts8jU=",
+ "ref": "main",
+ "rev": "a51e591b7fdf8881ac0237452691df7b1aceecd3",
+ "revCount": 10,
+ "type": "git",
+ "url": "https://whetstone.private.storage/jcalderone/hs-flake-utils.git"
+ },
+ "original": {
+ "ref": "main",
+ "type": "git",
+ "url": "https://whetstone.private.storage/jcalderone/hs-flake-utils.git"
+ }
+ },
+ "hs-flake-utils_2": {
+ "inputs": {
+ "flake-utils": "flake-utils_4",
+ "nixpkgs": "nixpkgs_2",
+ "pre-commit-hooks": "pre-commit-hooks_2"
+ },
+ "locked": {
+ "lastModified": 1677773826,
+ "narHash": "sha256-xJmOtHugr4k2zNhP/AF6JdIUnIEyM+TEspLn2n5kloc=",
+ "ref": "main",
+ "rev": "d3a83fdd9563546ca41771186427638e685a2e2b",
+ "revCount": 9,
+ "type": "git",
+ "url": "https://whetstone.private.storage/jcalderone/hs-flake-utils.git"
+ },
+ "original": {
+ "ref": "main",
+ "type": "git",
+ "url": "https://whetstone.private.storage/jcalderone/hs-flake-utils.git"
+ }
+ },
+ "hs-flake-utils_3": {
+ "inputs": {
+ "flake-utils": "flake-utils_6",
+ "nixpkgs": "nixpkgs_3",
+ "pre-commit-hooks": "pre-commit-hooks_3"
+ },
"locked": {
"lastModified": 1677773826,
"narHash": "sha256-xJmOtHugr4k2zNhP/AF6JdIUnIEyM+TEspLn2n5kloc=",
@@ -121,6 +301,70 @@
"type": "github"
}
},
+ "nixpkgs-stable_2": {
+ "locked": {
+ "lastModified": 1673800717,
+ "narHash": "sha256-SFHraUqLSu5cC6IxTprex/nTsI81ZQAtDvlBvGDWfnA=",
+ "owner": "NixOS",
+ "repo": "nixpkgs",
+ "rev": "2f9fd351ec37f5d479556cd48be4ca340da59b8f",
+ "type": "github"
+ },
+ "original": {
+ "owner": "NixOS",
+ "ref": "nixos-22.11",
+ "repo": "nixpkgs",
+ "type": "github"
+ }
+ },
+ "nixpkgs-stable_3": {
+ "locked": {
+ "lastModified": 1673800717,
+ "narHash": "sha256-SFHraUqLSu5cC6IxTprex/nTsI81ZQAtDvlBvGDWfnA=",
+ "owner": "NixOS",
+ "repo": "nixpkgs",
+ "rev": "2f9fd351ec37f5d479556cd48be4ca340da59b8f",
+ "type": "github"
+ },
+ "original": {
+ "owner": "NixOS",
+ "ref": "nixos-22.11",
+ "repo": "nixpkgs",
+ "type": "github"
+ }
+ },
+ "nixpkgs_2": {
+ "locked": {
+ "lastModified": 1677624842,
+ "narHash": "sha256-4DF9DbDuK4/+KYx0L6XcPBeDHUFVCtzok2fWtwXtb5w=",
+ "owner": "nixos",
+ "repo": "nixpkgs",
+ "rev": "d70f5cd5c3bef45f7f52698f39e7cc7a89daa7f0",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nixos",
+ "ref": "nixos-22.11",
+ "repo": "nixpkgs",
+ "type": "github"
+ }
+ },
+ "nixpkgs_3": {
+ "locked": {
+ "lastModified": 1677624842,
+ "narHash": "sha256-4DF9DbDuK4/+KYx0L6XcPBeDHUFVCtzok2fWtwXtb5w=",
+ "owner": "nixos",
+ "repo": "nixpkgs",
+ "rev": "d70f5cd5c3bef45f7f52698f39e7cc7a89daa7f0",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nixos",
+ "ref": "nixos-22.11",
+ "repo": "nixpkgs",
+ "type": "github"
+ }
+ },
"pre-commit-hooks": {
"inputs": {
"flake-compat": "flake-compat",
@@ -149,14 +393,124 @@
"type": "github"
}
},
+ "pre-commit-hooks_2": {
+ "inputs": {
+ "flake-compat": "flake-compat_2",
+ "flake-utils": [
+ "tahoe-chk",
+ "hs-flake-utils",
+ "flake-utils"
+ ],
+ "gitignore": "gitignore_2",
+ "nixpkgs": [
+ "tahoe-chk",
+ "hs-flake-utils",
+ "nixpkgs"
+ ],
+ "nixpkgs-stable": "nixpkgs-stable_2"
+ },
+ "locked": {
+ "lastModified": 1677722096,
+ "narHash": "sha256-7mjVMvCs9InnrRybBfr5ohqcOz+pyEX8m22C1XsDilg=",
+ "owner": "cachix",
+ "repo": "pre-commit-hooks.nix",
+ "rev": "61a3511668891c68ebd19d40122150b98dc2fe3b",
+ "type": "github"
+ },
+ "original": {
+ "owner": "cachix",
+ "repo": "pre-commit-hooks.nix",
+ "type": "github"
+ }
+ },
+ "pre-commit-hooks_3": {
+ "inputs": {
+ "flake-compat": "flake-compat_3",
+ "flake-utils": [
+ "tahoe-great-black-swamp",
+ "hs-flake-utils",
+ "flake-utils"
+ ],
+ "gitignore": "gitignore_3",
+ "nixpkgs": [
+ "tahoe-great-black-swamp",
+ "hs-flake-utils",
+ "nixpkgs"
+ ],
+ "nixpkgs-stable": "nixpkgs-stable_3"
+ },
+ "locked": {
+ "lastModified": 1677722096,
+ "narHash": "sha256-7mjVMvCs9InnrRybBfr5ohqcOz+pyEX8m22C1XsDilg=",
+ "owner": "cachix",
+ "repo": "pre-commit-hooks.nix",
+ "rev": "61a3511668891c68ebd19d40122150b98dc2fe3b",
+ "type": "github"
+ },
+ "original": {
+ "owner": "cachix",
+ "repo": "pre-commit-hooks.nix",
+ "type": "github"
+ }
+ },
"root": {
"inputs": {
"flake-utils": "flake-utils",
"hs-flake-utils": "hs-flake-utils",
+ "nixpkgs": [
+ "hs-flake-utils",
+ "nixpkgs"
+ ],
+ "tahoe-chk": "tahoe-chk",
+ "tahoe-great-black-swamp": "tahoe-great-black-swamp"
+ }
+ },
+ "tahoe-chk": {
+ "inputs": {
+ "flake-utils": "flake-utils_3",
+ "hs-flake-utils": "hs-flake-utils_2",
+ "nixpkgs": [
+ "hs-flake-utils",
+ "nixpkgs"
+ ]
+ },
+ "locked": {
+ "lastModified": 1681998540,
+ "narHash": "sha256-gtlHidh8+qMUdnTzlxLIGlCMavq4/TFQDmope33Cd2w=",
+ "ref": "refs/tags/0.1.0.0",
+ "rev": "799bab0c2b8b5f9cbd98e7dd7d6a77285c87f16b",
+ "revCount": 340,
+ "type": "git",
+ "url": "https://whetstone.private.storage/PrivateStorage/tahoe-chk"
+ },
+ "original": {
+ "ref": "refs/tags/0.1.0.0",
+ "type": "git",
+ "url": "https://whetstone.private.storage/PrivateStorage/tahoe-chk"
+ }
+ },
+ "tahoe-great-black-swamp": {
+ "inputs": {
+ "flake-utils": "flake-utils_5",
+ "hs-flake-utils": "hs-flake-utils_3",
"nixpkgs": [
"hs-flake-utils",
"nixpkgs"
]
+ },
+ "locked": {
+ "lastModified": 1682446800,
+ "narHash": "sha256-Vxl4dLpoRp2svWTx0w74m7PeVPMlkSu/XOZAHccOUDs=",
+ "ref": "refs/tags/0.1.0.1",
+ "rev": "b81cc3fcdb0107d369a636fdc5a17cf174dff2ea",
+ "revCount": 143,
+ "type": "git",
+ "url": "https://whetstone.private.storage/PrivateStorage/tahoe-great-black-swamp"
+ },
+ "original": {
+ "ref": "refs/tags/0.1.0.1",
+ "type": "git",
+ "url": "https://whetstone.private.storage/PrivateStorage/tahoe-great-black-swamp"
}
}
},
diff --git a/flake.nix b/flake.nix
index 3b0f855eaf5d60d691d08acae679b279af7a7463..8c70ef15153e6a444c51dee6bd182192295cb18f 100644
--- a/flake.nix
+++ b/flake.nix
@@ -6,6 +6,16 @@
nixpkgs.follows = "hs-flake-utils/nixpkgs";
flake-utils.url = github:numtide/flake-utils;
hs-flake-utils.url = "git+https://whetstone.private.storage/jcalderone/hs-flake-utils.git?ref=main";
+
+ tahoe-chk = {
+ url = "git+https://whetstone.private.storage/PrivateStorage/tahoe-chk?ref=refs/tags/0.1.0.0";
+ inputs.nixpkgs.follows = "hs-flake-utils/nixpkgs";
+ };
+
+ tahoe-great-black-swamp = {
+ url = "git+https://whetstone.private.storage/PrivateStorage/tahoe-great-black-swamp?ref=refs/tags/0.1.0.1";
+ inputs.nixpkgs.follows = "hs-flake-utils/nixpkgs";
+ };
};
outputs = {
@@ -13,6 +23,8 @@
nixpkgs,
flake-utils,
hs-flake-utils,
+ tahoe-chk,
+ tahoe-great-black-swamp,
}: let
ulib = flake-utils.lib;
ghcVersion = "ghc8107";
@@ -27,10 +39,26 @@
src = ./.;
compilerVersion = ghcVersion;
packageName = "gbs-downloader";
+ hsPkgsOverrides = import ./nix/haskell-packages.nix {
+ tahoe-chk = tahoe-chk.outputs.packages.${system}.default;
+ tahoe-great-black-swamp = tahoe-great-black-swamp.outputs.packages.${system}.default;
+ haskellLib = pkgs.haskell.lib;
+ };
};
in {
checks = hslib.checks {};
- devShells = hslib.devShells {};
+ devShells = hslib.devShells {
+ extraBuildInputs = pkgs:
+ with pkgs; [
+ # We configure cabal to use zlib:pkg-config so we better supply
+ # pkg-config in the dev shell or `cabal ...` builds will surely
+ # fail.
+ pkg-config
+
+ # And also that pesky zlib dependency.
+ zlib
+ ];
+ };
packages = hslib.packages {};
apps.hlint = hslib.apps.hlint {};
@@ -41,12 +69,22 @@
program = "${
pkgs.writeShellApplication {
name = "cabal-build-and-test";
- runtimeInputs = with pkgs; [pkg-config haskell.compiler.${ghcVersion} cabal-install];
+ # Only put packages with things that need to be on PATH here
+ # because that's all that runtimeInputs buys us. Packages with
+ # different requirements need to be handled differently.
+ runtimeInputs = with pkgs; [
+ pkg-config
+ haskell.compiler.${ghcVersion}
+ cabal-install
+ ];
text = ''
+ # Here we make zlib discoverable by pkg-config so cabal can find
+ # headers and stuff.
+ export PKG_CONFIG_PATH=${pkgs.lib.makeSearchPath "lib/pkgconfig" [pkgs.zlib.dev]}
+
cabal update hackage.haskell.org
- cabal build --enable-tests
- eval "$(cabal list-bin gbs-downloader-tests)"
+ cabal run tests
'';
}
}/bin/cabal-build-and-test";
diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index 9f3f1429d93189a773a1b4213897c146133b7819..8d377001b6a0f7437ef008f13a615b2108909641 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -58,14 +58,24 @@ extra-doc-files: CHANGELOG.md
-- extra-source-files:
common warnings
- ghc-options: -Wall
+ ghc-options: -Wall -Werror
+
+common language
+ -- LANGUAGE extensions used by modules in all targets.
+ default-extensions:
+ NamedFieldPuns
+ OverloadedStrings
+ RecordWildCards
+ TupleSections
library
-- Import common warning flags.
- import: warnings
+ import:
+ warnings
+ , language
-- Modules exported by the library.
- exposed-modules: MyLib
+ exposed-modules: Tahoe.Download
-- Modules included in this library but not exported.
-- other-modules:
@@ -74,7 +84,14 @@ library
-- other-extensions:
-- Other library packages from which modules are imported.
- build-depends: base ^>=4.14.3.0
+ build-depends:
+ , base ^>=4.14.3.0
+ , binary
+ , bytestring
+ , containers
+ , tahoe-chk
+ , tahoe-great-black-swamp
+ , text
-- Directories containing source files.
hs-source-dirs: src
@@ -82,9 +99,11 @@ library
-- Base language which the package is written in.
default-language: Haskell2010
-executable gbs-downloader
+executable gbs-download
-- Import common warning flags.
- import: warnings
+ import:
+ warnings
+ , language
-- .hs or .lhs file containing the Main module.
main-is: Main.hs
@@ -108,16 +127,15 @@ executable gbs-downloader
test-suite gbs-downloader-test
-- Import common warning flags.
- import: warnings
+ import:
+ warnings
+ , language
-- Base language which the package is written in.
default-language: Haskell2010
-- Modules included in this executable, other than Main.
- -- other-modules:
-
- -- LANGUAGE extensions used by modules in this package.
- -- other-extensions:
+ other-modules: Generators
-- The interface type and version of the test suite.
type: exitcode-stdio-1.0
@@ -126,9 +144,20 @@ test-suite gbs-downloader-test
hs-source-dirs: test
-- The entrypoint to the test suite.
- main-is: Main.hs
+ main-is: Spec.hs
-- Test dependencies.
build-depends:
, base ^>=4.14.3.0
+ , base32
+ , binary
+ , bytestring
+ , containers
+ , crypto-api
, gbs-downloader
+ , hedgehog
+ , tahoe-chk
+ , tasty
+ , tasty-hedgehog
+ , tasty-hunit
+ , text
diff --git a/nix/haskell-packages.nix b/nix/haskell-packages.nix
new file mode 100644
index 0000000000000000000000000000000000000000..175fc2091a3906e508c6b4d7e1146a01122494c1
--- /dev/null
+++ b/nix/haskell-packages.nix
@@ -0,0 +1,12 @@
+{
+ haskellLib,
+ tahoe-chk,
+ tahoe-great-black-swamp,
+}: hfinal: hprev: {
+ inherit tahoe-chk;
+ inherit tahoe-great-black-swamp;
+
+ # A broken dependency of a tahoe-great-black-swamp executable that we don't
+ # use. Flip the broken bit so we can get a build.
+ language-ecmascript = haskellLib.unmarkBroken hprev.language-ecmascript;
+}
diff --git a/src/MyLib.hs b/src/MyLib.hs
deleted file mode 100644
index e657c4403f66f966da13d2027bf595d9673387f6..0000000000000000000000000000000000000000
--- a/src/MyLib.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module MyLib (someFunc) where
-
-someFunc :: IO ()
-someFunc = putStrLn "someFunc"
diff --git a/src/Tahoe/Download.hs b/src/Tahoe/Download.hs
new file mode 100644
index 0000000000000000000000000000000000000000..35d87188f5fb56222b3472f4d82df21e24d8d83f
--- /dev/null
+++ b/src/Tahoe/Download.hs
@@ -0,0 +1,154 @@
+{- | A high-level interface to downloading share data as bytes from storage
+ servers.
+-}
+module Tahoe.Download (LookupServer, DownloadError (..), discoverShares, download) where
+
+import Data.Binary (decodeOrFail)
+import qualified Data.ByteString.Lazy as LB
+import Data.Either (isRight, rights)
+import Data.List (foldl')
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import qualified Tahoe.CHK
+import Tahoe.CHK.Capability (Reader (..), Verifier (..))
+import qualified Tahoe.CHK.Encrypt
+import Tahoe.CHK.Server (StorageServer (..), StorageServerAnnouncement (..), StorageServerID, URL)
+import Tahoe.CHK.Types (ShareNum, StorageIndex)
+
+{- | An unrecoverable problem arose while attempting to download and/or read
+ some application data.
+-}
+data DownloadError
+ = -- | The configuration included no candidate servers from which to download.
+ NoConfiguredServers
+ | -- | Across all of the configured servers, none were actually connectable.
+ NoReachableServers
+ | -- | Across all of the configured servers, fewer than the required
+ -- number of shares were found. XXX Could split this into the different
+ -- cases - did not locate enough shares, did not download enough shares,
+ -- did not verify enough shares
+ NotEnoughShares
+ { notEnoughSharesNeeded :: Int
+ , notEnoughSharesFound :: Int
+ }
+ | -- | Across all of the shares that we could download, fewer than the
+ -- required number could actually be decoded.
+ NotEnoughDecodedShares
+ { notEnoughDecodedSharesNeeded :: Int
+ , notEnoughDecodedSharesFound :: Int
+ }
+ | -- | Enough syntactically valid shares were recovered but they could not
+ -- be interpreted.
+ ShareDecodingFailed
+ | -- | An attempt was made to download a share but no servers were given for
+ -- the download.
+ NoServers
+ deriving (Eq, Ord, Show)
+
+{- | An problem arose while attempting to discover the shares held on a
+ particular server.
+-}
+data DiscoverError
+ = -- | An announcement did not include a location for a connection attempt.
+ StorageServerLocationUnknown
+ | StorageServerUnreachable
+ deriving (Eq, Ord, Show)
+
+-- TODO The result might need to be in IO in case the URL indicates a
+-- Tor-based route to the server. In this case we might need to launch a Tor
+-- daemon or connect to a running Tor daemon or at least set up a new Tor
+-- circuit. All of which require I/O. But we can always refactor later!
+type LookupServer = URL -> Maybe StorageServer
+
+{- | Recover the application data associated with a given capability from the
+ given servers, if possible.
+-}
+download ::
+ -- | Information about the servers from which to consider downloading shares
+ -- representing the application data.
+ Map.Map StorageServerID StorageServerAnnouncement ->
+ -- | The read capability for the application data.
+ Reader ->
+ -- | Get functions for interacting with a server given its URL.
+ LookupServer ->
+ -- | Either a description of how the recovery failed or the recovered
+ -- application data.
+ IO (Either DownloadError LB.ByteString)
+download servers cap@Reader{readKey, verifier = Verifier{..}} lookupServer =
+ case Map.toList servers of
+ [] -> pure . Left $ NoConfiguredServers
+ serverList -> do
+ -- Ask each server for all shares it has.
+ discovered <- rights <$> mapM (discoverShares lookupServer storageIndex) serverList :: IO [(StorageServer, Set.Set ShareNum)]
+ if null discovered
+ then pure $ Left NoReachableServers
+ else
+ if (fromIntegral required >) . countDistinctShares $ discovered
+ then pure $ Left NotEnoughShares{notEnoughSharesNeeded = fromIntegral required, notEnoughSharesFound = countDistinctShares discovered}
+ else do
+ -- XXX up to here is probably "locateShares". now we move in to "fetchShares".
+ let sharemap = makeShareMap discovered
+ -- XXX note shares can contain failures
+ shares <- mapM (uncurry $ downloadShare storageIndex) (Map.toList sharemap)
+ -- XXX That was brief. Probably missing some complexity. now we move on to "decodeShares".
+ -- Filter down to shares we actually got.
+ let someShares = filter (isRight . snd) shares
+ fewerShares = filter (isRight . snd) $ (\(sharenum, Right bs) -> (sharenum, decodeOrFail bs)) <$> someShares
+ onlyDecoded = (\(sharenum, Right (_, _, share)) -> (fromIntegral sharenum, share)) <$> fewerShares
+ if length onlyDecoded < fromIntegral required
+ then pure $ Left NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = fromIntegral required, notEnoughDecodedSharesFound = length onlyDecoded}
+ else do
+ ciphertext <- Tahoe.CHK.decode cap onlyDecoded
+ case ciphertext of
+ Nothing -> pure $ Left ShareDecodingFailed
+ Just ct ->
+ pure . Right $ Tahoe.CHK.Encrypt.decrypt readKey ct
+
+{- | Figure the total number of distinct shares reported by all of the servers
+ we asked.
+-}
+countDistinctShares :: Ord b => [(a, Set.Set b)] -> Int
+countDistinctShares = Set.size . foldl' Set.union mempty . map snd
+
+{- | Ask one server which shares it has related to the storage index in
+ question.
+-}
+discoverShares :: LookupServer -> StorageIndex -> (StorageServerID, StorageServerAnnouncement) -> IO (Either DiscoverError (StorageServer, Set.Set ShareNum))
+discoverShares lookupServer storageIndex (_sid, sann) = do
+ case storageServerAnnouncementFURL sann of
+ Nothing -> pure $ Left StorageServerLocationUnknown
+ Just url -> do
+ let server = lookupServer url
+ case server of
+ Nothing -> pure $ Left StorageServerUnreachable
+ Just ss@StorageServer{storageServerGetBuckets} ->
+ Right . (ss,) <$> storageServerGetBuckets storageIndex
+
+{- | Invert the mapping implied by the list of two tuples so that the servers
+ that claim to have a certain share can easily be retrieved.
+-}
+makeShareMap :: Ord k => [(v, Set.Set k)] -> Map.Map k [v]
+makeShareMap locations =
+ foldl' (Map.unionWith (<>)) mempty ((\(k, v) -> Map.fromSet (const [k]) v) <$> locations)
+
+-- | Download the bytes of a share from one (or more!) of the given servers.
+downloadShare ::
+ -- | The storage index of the share to download.
+ StorageIndex ->
+ -- | The number of the share to download.
+ ShareNum ->
+ -- | The servers which we have a reasonable belief could hold a copy of the
+ -- share. It is common for there to be only one server holding each share
+ -- but nothing *prevents* multiple servers from having one. In this case we
+ -- could download the share from both of them, perhaps.
+ [StorageServer] ->
+ -- | The bytes of the share or some error that was encountered during
+ -- download.
+ IO (ShareNum, Either DownloadError LB.ByteString)
+downloadShare _ shareNum [] = pure (shareNum, Left NoServers)
+downloadShare storageIndex shareNum (s : _) = do
+ -- TODO: There might be more servers. We could try them if this fails.
+ -- On the other hand, we might get bytes but we don't verify them here so
+ -- we might also need retry logic up a level or two from here.
+ shareBytes <- storageServerRead s storageIndex shareNum
+ pure (shareNum, Right $ LB.fromStrict shareBytes)
diff --git a/test/Generators.hs b/test/Generators.hs
new file mode 100644
index 0000000000000000000000000000000000000000..08ba46e3fcbefd45e977c8d35e240821439aab1b
--- /dev/null
+++ b/test/Generators.hs
@@ -0,0 +1,22 @@
+module Generators where
+
+import Data.Int (Int64)
+import Hedgehog (MonadGen)
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import Tahoe.CHK.Types (Parameters (..))
+
+-- | The maximum value an Int64 can represent.
+maxInt64 :: Integer
+maxInt64 = fromIntegral (maxBound :: Int64)
+
+-- | Generate Parameters values for which all field invariants hold.
+genParameters :: MonadGen m => m Parameters
+genParameters = do
+ paramSegmentSize <- Gen.integral (Range.exponential 1 maxInt64)
+ paramTotalShares <- Gen.integral (Range.linear 2 256)
+ paramRequiredShares <- Gen.integral (Range.linear 1 (paramTotalShares - 1))
+ -- XXX We're going to get rid of "Happy" from this type. For now it's
+ -- easier not to let this value vary and it doesn't hurt anything.
+ let paramHappyShares = 1
+ pure $ Parameters{paramSegmentSize, paramTotalShares, paramHappyShares, paramRequiredShares}
diff --git a/test/Main.hs b/test/Main.hs
deleted file mode 100644
index 3e2059e31f5127521b263b051fc7247772685e1a..0000000000000000000000000000000000000000
--- a/test/Main.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module Main (main) where
-
-main :: IO ()
-main = putStrLn "Test suite not yet implemented."
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f2547908dc60bdaab1ccc29623c844c2f6a05fe1
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,271 @@
+module Main where
+
+import Control.Exception (Exception, throwIO)
+import Control.Monad (replicateM, zipWithM_)
+import Control.Monad.IO.Class (liftIO)
+import Crypto.Classes (buildKey)
+import qualified Data.Binary as Binary
+import qualified Data.ByteString as B
+import Data.ByteString.Base32 (encodeBase32Unpadded)
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Data.Word (Word16)
+import Generators (genParameters)
+import Hedgehog (MonadGen, diff, forAll, property)
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import System.IO (hSetEncoding, stderr, stdout, utf8)
+import qualified Tahoe.CHK
+import Tahoe.CHK.Capability (Reader (..), Verifier (..))
+import qualified Tahoe.CHK.Encrypt
+import Tahoe.CHK.Server (StorageServer (..), StorageServerAnnouncement (..), StorageServerID)
+import Tahoe.CHK.Types (Parameters (..))
+import Tahoe.CHK.Upload (getConvergentKey)
+import Tahoe.Download (DownloadError (..), LookupServer, download)
+import Tahoe.Server (memoryStorageServer)
+import Test.Tasty (TestTree, defaultMain, testGroup)
+import Test.Tasty.HUnit (assertEqual, testCase)
+import Test.Tasty.Hedgehog (testProperty)
+
+data PlacementError = RanOutOfPlacementInfo | RanOutOfServers deriving (Eq, Show)
+instance Exception PlacementError
+
+tests :: TestTree
+tests =
+ testGroup
+ "All tests"
+ [ testCase "no configured servers" $ do
+ -- If there are no servers then we can't possibly get enough
+ -- shares to recover the application data.
+ result <- liftIO $ download mempty (trivialCap 1 1) noServers
+ assertEqual
+ "download should fail with no servers"
+ (Left NoConfiguredServers)
+ result
+ , testCase "no reachable servers" $ do
+ -- If we can't contact any configured server then we can't
+ -- possibly get enough shares to recover the application data.
+ let anns =
+ Map.fromList
+ [
+ ( "v0-abc123"
+ , StorageServerAnnouncement
+ { storageServerAnnouncementFURL = Nothing
+ , storageServerAnnouncementNick = Just "unreachable"
+ , storageServerAnnouncementPermutationSeed = Nothing
+ }
+ )
+ ]
+
+ result <- liftIO $ download anns (trivialCap 1 1) noServers
+ assertEqual
+ "download should fail with no reachable servers"
+ (Left NoReachableServers)
+ result
+ , testCase "not enough shares" $ do
+ -- If we can't recover enough shares from the configured servers
+ -- then we can't possibly get enough shares to recover the
+ -- application data.
+ let anns =
+ Map.fromList
+ [
+ ( "v0-abc123"
+ , StorageServerAnnouncement
+ { storageServerAnnouncementFURL = Just "somewhere"
+ , storageServerAnnouncementNick = Just "abc123"
+ , storageServerAnnouncementPermutationSeed = Nothing
+ }
+ )
+ ]
+ cap = trivialCap 3 3
+
+ -- Two shares exist.
+ server <- memoryStorageServer
+ storageServerWrite server (storageIndex . verifier $ cap) 0 0 "Hello world"
+ storageServerWrite server (storageIndex . verifier $ cap) 1 0 "Hello world"
+
+ -- Make the server reachable.
+ let openServer furl =
+ if furl == "somewhere"
+ then pure server
+ else Nothing
+
+ -- Try to download the cap which requires three shares to reconstruct.
+ result <- liftIO $ download anns cap openServer
+ assertEqual
+ "download should fail with not enough shares"
+ (Left NotEnoughShares{notEnoughSharesNeeded = 3, notEnoughSharesFound = 2})
+ result
+ , testCase "not enough distinct shares" $ do
+ -- If we can't recover enough *distinct* shares from the
+ -- configured servers then we can't possibly get enough shares to
+ -- recover the application data. Duplicate shares do us no good.
+ let anns =
+ Map.fromList
+ [
+ ( "v0-abc123"
+ , StorageServerAnnouncement
+ { storageServerAnnouncementFURL = Just "somewhere"
+ , storageServerAnnouncementNick = Just "abc123"
+ , storageServerAnnouncementPermutationSeed = Nothing
+ }
+ )
+ ,
+ ( "v0-abc456"
+ , StorageServerAnnouncement
+ { storageServerAnnouncementFURL = Just "elsewhere"
+ , storageServerAnnouncementNick = Just "abc123"
+ , storageServerAnnouncementPermutationSeed = Nothing
+ }
+ )
+ ]
+ cap = trivialCap 3 3
+
+ -- Three shares exist
+ somewhere <- memoryStorageServer
+ let idx = storageIndex . verifier $ cap
+ offset = 0
+ storageServerWrite somewhere idx 0 offset "Hello world"
+ storageServerWrite somewhere idx 1 offset "Hello world"
+ -- But this one is just a duplicate of share 0 on the other
+ -- server.
+ elsewhere <- memoryStorageServer
+ storageServerWrite elsewhere idx 0 offset "Hello world"
+
+ -- Make the server reachable.
+ let openServer furl =
+ case furl of
+ "somewhere" -> pure somewhere
+ "elsewhere" -> pure elsewhere
+ _ -> Nothing
+
+ -- Try to download the cap which requires three shares to reconstruct.
+ result <- liftIO $ download anns cap openServer
+ assertEqual
+ "download should fail with not enough shares"
+ (Left NotEnoughShares{notEnoughSharesNeeded = 3, notEnoughSharesFound = 2})
+ result
+ , testProperty "success" $
+ property $ do
+ -- If we can recover enough distinct, decodeable shares from the
+ -- configured servers then we can recover the application data.
+
+ -- Generates configurations where it should be possible to recover
+ -- the data (have all the shares, have enough of the shares,
+ -- spread them across many servers, concentrate them on one or a
+ -- few, etc)
+
+ secret <- forAll $ Gen.bytes (Range.singleton 32)
+ plaintext <- forAll $ BL.fromStrict <$> Gen.bytes (Range.exponential 56 1024)
+ params@Parameters{paramTotalShares} <- forAll genParameters
+
+ -- Since multiple shares can be placed on a single server, as long
+ -- as we have one server we have a valid case. Since some shares
+ -- might be placed non-optimally it is also nice to allow for some
+ -- empty servers so allow for that as well.
+ let numServers = Range.linear 1 (fromIntegral paramTotalShares + 1)
+ serverIDs = Gen.text (Range.singleton 2) Gen.ascii
+ serverIDs' <- forAll $ Gen.set numServers serverIDs
+ -- Constructor <$> arbitrary <*> arbitrary
+
+ -- Choose a share distribution. Each element of the resulting
+ -- list tells us how many shares to place on the next server, for
+ -- some arbitrary (stable) server ordering.
+ perServerShareCount <-
+ forAll $
+ genListWithSum (length serverIDs') (fromIntegral paramTotalShares)
+
+ -- Make the servers.
+ servers <- liftIO $ replicateM (length serverIDs') memoryStorageServer
+
+ -- Encrypt and encode the data into shares.
+ let key = getConvergentKey secret params plaintext
+ ciphertext = Tahoe.CHK.Encrypt.encrypt key plaintext
+ (shares, cap) <- liftIO $ Tahoe.CHK.encode key params ciphertext
+
+ -- Distribute the shares.
+ liftIO $ placeShares cap (Binary.encode <$> shares) perServerShareCount servers 0
+
+ let serverMap = Map.fromList $ zip (Set.toList serverIDs') servers
+ lookupServer = someServers serverMap
+ serverAnnouncements = Map.fromSet makeAnn serverIDs'
+
+ -- Recover the plaintext from the servers.
+ result <- liftIO $ download serverAnnouncements cap lookupServer
+ diff (Right plaintext) (==) result
+ ]
+ where
+ -- A server lookup function that always fails.
+ noServers _ = Nothing
+
+ -- A server lookup function that finds servers already present in a Map.
+ someServers :: Map.Map StorageServerID StorageServer -> LookupServer
+ someServers servers = flip Map.lookup servers . parseURL
+ where
+ -- Exactly match the nonsense makeAnn spits out
+ parseURL = T.take 2 . T.drop 5
+
+ --- PHILOSOFY
+ -- We wish that share numbers were an opaque type instead of a
+ -- numeric/integral type. This is not the place to argue the point
+ -- though.
+ placeShares :: Reader -> [BL.ByteString] -> [Int] -> [StorageServer] -> Int -> IO ()
+ -- Out of shares, done.
+ placeShares _ [] _ _ _ = pure ()
+ -- Out of placement info but not out of shares is a programming error.
+ placeShares _ _ [] _ _ = throwIO RanOutOfPlacementInfo
+ -- Out of servers but not out of shares is a programming error.
+ placeShares _ _ _ [] _ = throwIO RanOutOfServers
+ -- Having some of all three means we can make progress.
+ placeShares cap shares (n : ns) (s : ss) sharesSoFar = do
+ -- write the right number of shares to this server
+ zipWithM_
+ (\shnum share -> storageServerWrite s (storageIndex . verifier $ cap) shnum 0 share)
+ [fromIntegral sharesSoFar ..]
+ (BL.toStrict <$> take n shares)
+ -- recurse to write the rest
+ placeShares cap (drop n shares) ns ss (sharesSoFar + n)
+
+ -- Make up a distinct (but nonsense) announcement for a given storage
+ -- server identifier.
+ makeAnn :: StorageServerID -> StorageServerAnnouncement
+ makeAnn sid =
+ StorageServerAnnouncement
+ { storageServerAnnouncementFURL = Just $ "pb://" <> sid <> "/" <> sid
+ , storageServerAnnouncementNick = Just . encodeBase32Unpadded . encodeUtf8 $ sid
+ , storageServerAnnouncementPermutationSeed = Nothing
+ }
+
+ -- Generate lists of ints that sum to a given total.
+ genListWithSum :: MonadGen m => Int -> Int -> m [Int]
+ -- We hit the target.
+ genListWithSum _ 0 = pure []
+ -- We only have room for one more element.
+ genListWithSum 1 t = pure [t]
+ -- Use up some of what's left on one element and recurse.
+ genListWithSum maxLength t = do
+ v <- Gen.int (Range.linear 0 t)
+ (v :) <$> genListWithSum (maxLength - 1) (t - v)
+
+trivialCap :: Word16 -> Word16 -> Reader
+trivialCap required total = Reader{..}
+ where
+ Just readKey = buildKey $ B.replicate 32 0x00
+ storageIndex = B.replicate 32 0x00
+ fingerprint = B.replicate 32 0x00
+ size = 1234
+ verifier = Verifier{..}
+
+main :: IO ()
+main = do
+ -- Hedgehog writes some non-ASCII and the whole test process will die if
+ -- it can't be encoded. Increase the chances that all of the output can
+ -- be encoded by forcing the use of UTF-8 (overriding the LANG-based
+ -- choice normally made).
+ hSetEncoding stdout utf8
+ hSetEncoding stderr utf8
+
+ defaultMain tests