{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

module Tahoe.CHK.Capability (
    CHK (..),
    Reader,
    readKey,
    verifier,
    Verifier,
    storageIndex,
    fingerprint,
    required,
    total,
    size,
    makeReader,
    pCapability,
    pVerifier,
    pReader,
    dangerRealShow,
) where

import Control.Lens (view)
import Control.Lens.TH (makeLenses)
import Crypto.Cipher.AES (AES128)
import Crypto.Cipher.Types (Cipher (cipherInit))
import Crypto.Error (maybeCryptoError)
import Data.ByteArray (convert)
import qualified Data.ByteString as B
import qualified Data.ByteString.Base32 as B
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.TreeDiff.Class (ToExpr (..))
import Data.Void (Void)
import Data.Word (Word16, Word64)
import GHC.Generics (Generic)
import Tahoe.CHK.Cipher (Key (..))
import Tahoe.CHK.Crypto (storageIndexHash)
import qualified Tahoe.CHK.Parsing
import Text.Megaparsec (ErrorFancy (ErrorFail), Parsec, count, fancyFailure, oneOf, try, (<|>))
import Text.Megaparsec.Char (char, string)
import Text.Megaparsec.Char.Lexer (decimal)

{- | Define a type in which we will perform parsing.  There is no custom error
 data (Void) and we are parsing T.Text.
-}
type Parser = Parsec Void T.Text

{- | The maximum number of shares it is possible for CHK-encoded data to be
 divided in to.
-}
maxShares :: Word16
maxShares :: Word16
maxShares = Word16
256

-- | The maximum size of the application data represented by a set of shares.
maxDataSize :: Integer
maxDataSize :: Integer
maxDataSize = Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
maxBound :: Word64)

{- | Represent a CHK "verify" capability.  This capability type can be used to
 verify the existence and validity (bit-level) of shares for the associated
 piece of plaintext.

 It can also be used to repair unhealthy data (I think?)
-}
data Verifier = Verifier
    { -- | The storage index of a verify capability is used as the key into the
      -- content-addressable storage system that is a storage server.  It can be
      -- used to ask storage servers for "shares" (ciphertext plus some
      -- metadata) to download.
      Verifier -> ByteString
_storageIndex :: B.ByteString
    , -- | The fingerprint (aka "UEB hash" aka "URI extension block hash") is a
      -- cryptographic hash that covers the URI extension block at the end of a
      -- CHK share.  The URI extension block itself contains various other
      -- cryptographic hashes.  Altogether this allows for integrity checking so
      -- shares downloaded from storage servers can be checked for validity (ie,
      -- that they are the same as what was uploaded) before they are processed.
      Verifier -> ByteString
_fingerprint :: B.ByteString
    , -- | The number of shares required to ZFEC decode the contents of the
      -- shares.  ZFEC calls this *K*.  It must be that 1 <= required <= 256 and
      -- required <= total.  ZFEC is not defined outside of these bounds.
      Verifier -> Word16
_required :: Word16
    , -- | The total number of shares produced by ZFEC encoding.  ZFEC calls
      -- this *n*.  It must be that 1 <= total <= 256 and required <= total.
      Verifier -> Word16
_total :: Word16
    , -- | The size (in bytes) of the plaintext encoded in the shares.  It must
      -- be that size >= 0 and in practice it is usually true that size >= 56.
      Verifier -> Integer
_size :: Integer
    }
    deriving (Eq Verifier
Eq Verifier
-> (Verifier -> Verifier -> Ordering)
-> (Verifier -> Verifier -> Bool)
-> (Verifier -> Verifier -> Bool)
-> (Verifier -> Verifier -> Bool)
-> (Verifier -> Verifier -> Bool)
-> (Verifier -> Verifier -> Verifier)
-> (Verifier -> Verifier -> Verifier)
-> Ord Verifier
Verifier -> Verifier -> Bool
Verifier -> Verifier -> Ordering
Verifier -> Verifier -> Verifier
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Verifier -> Verifier -> Verifier
$cmin :: Verifier -> Verifier -> Verifier
max :: Verifier -> Verifier -> Verifier
$cmax :: Verifier -> Verifier -> Verifier
>= :: Verifier -> Verifier -> Bool
$c>= :: Verifier -> Verifier -> Bool
> :: Verifier -> Verifier -> Bool
$c> :: Verifier -> Verifier -> Bool
<= :: Verifier -> Verifier -> Bool
$c<= :: Verifier -> Verifier -> Bool
< :: Verifier -> Verifier -> Bool
$c< :: Verifier -> Verifier -> Bool
compare :: Verifier -> Verifier -> Ordering
$ccompare :: Verifier -> Verifier -> Ordering
$cp1Ord :: Eq Verifier
Ord, Verifier -> Verifier -> Bool
(Verifier -> Verifier -> Bool)
-> (Verifier -> Verifier -> Bool) -> Eq Verifier
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verifier -> Verifier -> Bool
$c/= :: Verifier -> Verifier -> Bool
== :: Verifier -> Verifier -> Bool
$c== :: Verifier -> Verifier -> Bool
Eq, (forall x. Verifier -> Rep Verifier x)
-> (forall x. Rep Verifier x -> Verifier) -> Generic Verifier
forall x. Rep Verifier x -> Verifier
forall x. Verifier -> Rep Verifier x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Verifier x -> Verifier
$cfrom :: forall x. Verifier -> Rep Verifier x
Generic, [Verifier] -> Expr
Verifier -> Expr
(Verifier -> Expr) -> ([Verifier] -> Expr) -> ToExpr Verifier
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
listToExpr :: [Verifier] -> Expr
$clistToExpr :: [Verifier] -> Expr
toExpr :: Verifier -> Expr
$ctoExpr :: Verifier -> Expr
ToExpr)

$(makeLenses ''Verifier)

{- | Replace most of the tail of a string with a short placeholder.  If the
 string is not much longer than `n` then the result might not actually be
 shorter.
-}
shorten :: Int -> T.Text -> T.Text
shorten :: Int -> Text -> Text
shorten Int
n = (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"...") (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.take Int
n

-- | Show a value as Text.
showT :: Show s => s -> T.Text
showT :: s -> Text
showT = String -> Text
T.pack (String -> Text) -> (s -> String) -> s -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> String
forall a. Show a => a -> String
show

-- | Show a ByteString using a base32-encoded representation.
showBase32 :: B.ByteString -> T.Text
showBase32 :: ByteString -> Text
showBase32 = Text -> Text
T.toLower (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
B.encodeBase32Unpadded

-- | A version of bounded specialized to parsing text.
bounded :: (Ord n, Integral n) => n -> n -> Parser n
bounded :: n -> n -> Parser n
bounded = ParsecT Void Text Identity Integer -> n -> n -> Parser n
forall e s (m :: * -> *) n.
(MonadParsec e s m, Ord n, Integral n) =>
m Integer -> n -> n -> m n
Tahoe.CHK.Parsing.bounded ParsecT Void Text Identity Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal

instance Show Verifier where
    show :: Verifier -> String
show Verifier
v =
        Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
            Text -> [Text] -> Text
T.intercalate
                Text
":"
                [ Text
"URI"
                , Text
"CHK-Verifier"
                , Int -> Text -> Text
shorten Int
4 (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
showBase32 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Getting ByteString Verifier ByteString -> Verifier -> ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ByteString Verifier ByteString
Lens' Verifier ByteString
storageIndex Verifier
v
                , Int -> Text -> Text
shorten Int
4 (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
showBase32 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Getting ByteString Verifier ByteString -> Verifier -> ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ByteString Verifier ByteString
Lens' Verifier ByteString
fingerprint Verifier
v
                , Word16 -> Text
forall s. Show s => s -> Text
showT (Word16 -> Text) -> Word16 -> Text
forall a b. (a -> b) -> a -> b
$ Getting Word16 Verifier Word16 -> Verifier -> Word16
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Word16 Verifier Word16
Lens' Verifier Word16
required Verifier
v
                , Word16 -> Text
forall s. Show s => s -> Text
showT (Word16 -> Text) -> Word16 -> Text
forall a b. (a -> b) -> a -> b
$ Getting Word16 Verifier Word16 -> Verifier -> Word16
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Word16 Verifier Word16
Lens' Verifier Word16
total Verifier
v
                , Integer -> Text
forall s. Show s => s -> Text
showT (Integer -> Text) -> Integer -> Text
forall a b. (a -> b) -> a -> b
$ Getting Integer Verifier Integer -> Verifier -> Integer
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Integer Verifier Integer
Lens' Verifier Integer
size Verifier
v
                ]

{- | Represent a CHK "read" capability.  This capability type can be diminished
 to a verify capability so it confers all of the abilities of a verify
 capability.  It can also be used to decrypt shares to reconstruct the
 original plaintext.  See makeReader for a safe constructor that correctly
 derives the verify capability.
-}
data Reader = Reader
    { -- | The read key of a read capability is used as the symmetric encryption
      -- key to turn the original plaintext into ciphertext and back again.  The
      -- read key is also used to derive the verify key for the verify
      -- capability.  See ``storageIndexHash``.
      Reader -> Key AES128
_readKey :: Key AES128
    , -- | The verify capability for this read capability.
      Reader -> Verifier
_verifier :: Verifier
    }

$(makeLenses ''Reader)

-- AESKey128 has no Eq or Ord instances so derive these for Reader manually.
-- We do include the AESKey128 in our comparison by encoding it to bytes
-- first.
instance Eq Reader where
    Reader
left == :: Reader -> Reader -> Bool
== Reader
right = Reader -> (ByteString, Verifier)
readerKey Reader
left (ByteString, Verifier) -> (ByteString, Verifier) -> Bool
forall a. Eq a => a -> a -> Bool
== Reader -> (ByteString, Verifier)
readerKey Reader
right

instance Ord Reader where
    compare :: Reader -> Reader -> Ordering
compare Reader
left Reader
right = (ByteString, Verifier) -> (ByteString, Verifier) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Reader -> (ByteString, Verifier)
readerKey Reader
left) (Reader -> (ByteString, Verifier)
readerKey Reader
right)

instance ToExpr Reader where
    toExpr :: Reader -> Expr
toExpr = (ByteString, Verifier) -> Expr
forall a. ToExpr a => a -> Expr
toExpr ((ByteString, Verifier) -> Expr)
-> (Reader -> (ByteString, Verifier)) -> Reader -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reader -> (ByteString, Verifier)
readerKey

{- | Give it a Show instance that elides the sensitive material.  This makes
 it easier to compose with other types and we can still learn a lot of
 useful things about a capability without being able to see the literal
 secret key.
-}
instance Show Reader where
    show :: Reader -> String
show Reader
reader =
        Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
            Text -> [Text] -> Text
T.intercalate
                Text
":"
                [ Text
"URI"
                , Text
"CHK"
                , Int -> Text -> Text
shorten Int
4 (Text -> Text) -> (Key AES128 -> Text) -> Key AES128 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
showBase32 (ByteString -> Text)
-> (Key AES128 -> ByteString) -> Key AES128 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScrubbedBytes -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (ScrubbedBytes -> ByteString)
-> (Key AES128 -> ScrubbedBytes) -> Key AES128 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key AES128 -> ScrubbedBytes
forall cipher. Key cipher -> ScrubbedBytes
keyBytes (Key AES128 -> Text) -> Key AES128 -> Text
forall a b. (a -> b) -> a -> b
$ Getting (Key AES128) Reader (Key AES128) -> Reader -> Key AES128
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Key AES128) Reader (Key AES128)
Lens' Reader (Key AES128)
readKey Reader
reader
                , Int -> Text -> Text
shorten Int
4 (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
showBase32 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Getting ByteString Reader ByteString -> Reader -> ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Verifier -> Const ByteString Verifier)
-> Reader -> Const ByteString Reader
Lens' Reader Verifier
verifier ((Verifier -> Const ByteString Verifier)
 -> Reader -> Const ByteString Reader)
-> Getting ByteString Verifier ByteString
-> Getting ByteString Reader ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ByteString Verifier ByteString
Lens' Verifier ByteString
fingerprint) Reader
reader
                , Word16 -> Text
forall s. Show s => s -> Text
showT (Word16 -> Text) -> Word16 -> Text
forall a b. (a -> b) -> a -> b
$ Getting Word16 Reader Word16 -> Reader -> Word16
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Verifier -> Const Word16 Verifier)
-> Reader -> Const Word16 Reader
Lens' Reader Verifier
verifier ((Verifier -> Const Word16 Verifier)
 -> Reader -> Const Word16 Reader)
-> Getting Word16 Verifier Word16 -> Getting Word16 Reader Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Word16 Verifier Word16
Lens' Verifier Word16
required) Reader
reader
                , Word16 -> Text
forall s. Show s => s -> Text
showT (Word16 -> Text) -> Word16 -> Text
forall a b. (a -> b) -> a -> b
$ Getting Word16 Reader Word16 -> Reader -> Word16
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Verifier -> Const Word16 Verifier)
-> Reader -> Const Word16 Reader
Lens' Reader Verifier
verifier ((Verifier -> Const Word16 Verifier)
 -> Reader -> Const Word16 Reader)
-> Getting Word16 Verifier Word16 -> Getting Word16 Reader Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Word16 Verifier Word16
Lens' Verifier Word16
total) Reader
reader
                , Integer -> Text
forall s. Show s => s -> Text
showT (Integer -> Text) -> Integer -> Text
forall a b. (a -> b) -> a -> b
$ Getting Integer Reader Integer -> Reader -> Integer
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Verifier -> Const Integer Verifier)
-> Reader -> Const Integer Reader
Lens' Reader Verifier
verifier ((Verifier -> Const Integer Verifier)
 -> Reader -> Const Integer Reader)
-> Getting Integer Verifier Integer
-> Getting Integer Reader Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Integer Verifier Integer
Lens' Verifier Integer
size) Reader
reader
                ]

-- Construct a key with Eq and Ord instances for the Reader Eq and Ord
-- instances.
readerKey :: Reader -> (B.ByteString, Verifier)
readerKey :: Reader -> (ByteString, Verifier)
readerKey Reader
r = (Key AES128 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (Key AES128 -> ByteString) -> Key AES128 -> ByteString
forall a b. (a -> b) -> a -> b
$ Getting (Key AES128) Reader (Key AES128) -> Reader -> Key AES128
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Key AES128) Reader (Key AES128)
Lens' Reader (Key AES128)
readKey Reader
r, Getting Verifier Reader Verifier -> Reader -> Verifier
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Verifier Reader Verifier
Lens' Reader Verifier
verifier Reader
r)

{- | A "Content-Hash-Key" (CHK) capability is small value that can be used to
 perform some operation on a (usually) larger value that may be stored
 somewhere else.  There are two forms of CHK capabilities: verify and read.
 See *Verifier* and *Reader* for details.
-}
data CHK = CHKVerifier Verifier | CHKReader Reader deriving (Eq CHK
Eq CHK
-> (CHK -> CHK -> Ordering)
-> (CHK -> CHK -> Bool)
-> (CHK -> CHK -> Bool)
-> (CHK -> CHK -> Bool)
-> (CHK -> CHK -> Bool)
-> (CHK -> CHK -> CHK)
-> (CHK -> CHK -> CHK)
-> Ord CHK
CHK -> CHK -> Bool
CHK -> CHK -> Ordering
CHK -> CHK -> CHK
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CHK -> CHK -> CHK
$cmin :: CHK -> CHK -> CHK
max :: CHK -> CHK -> CHK
$cmax :: CHK -> CHK -> CHK
>= :: CHK -> CHK -> Bool
$c>= :: CHK -> CHK -> Bool
> :: CHK -> CHK -> Bool
$c> :: CHK -> CHK -> Bool
<= :: CHK -> CHK -> Bool
$c<= :: CHK -> CHK -> Bool
< :: CHK -> CHK -> Bool
$c< :: CHK -> CHK -> Bool
compare :: CHK -> CHK -> Ordering
$ccompare :: CHK -> CHK -> Ordering
$cp1Ord :: Eq CHK
Ord, CHK -> CHK -> Bool
(CHK -> CHK -> Bool) -> (CHK -> CHK -> Bool) -> Eq CHK
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CHK -> CHK -> Bool
$c/= :: CHK -> CHK -> Bool
== :: CHK -> CHK -> Bool
$c== :: CHK -> CHK -> Bool
Eq)

{- | Serialize a CHK capability to text.  This operation is "dangerous" in
 that it will serialize the encryption key of a read capability into the
 text.  Since the encryption key is necessary and (practically) sufficient
 to recover the original plaintext associated with the capability, it must
 be handled carefully to avoid unintentional disclosure.  Serializing the
 key to a string is a good way to accidentally disclose it!  Be warned.

 The text is in the canonical form, originally used by the Python
 implementation of Tahoe-LAFS.
-}
dangerRealShow :: CHK -> T.Text
dangerRealShow :: CHK -> Text
dangerRealShow (CHKVerifier Verifier
v) =
    Text -> [Text] -> Text
T.intercalate
        Text
":"
        [ Text
"URI"
        , Text
"CHK-Verifier"
        , ByteString -> Text
showBase32 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Getting ByteString Verifier ByteString -> Verifier -> ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ByteString Verifier ByteString
Lens' Verifier ByteString
storageIndex Verifier
v
        , ByteString -> Text
showBase32 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Getting ByteString Verifier ByteString -> Verifier -> ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ByteString Verifier ByteString
Lens' Verifier ByteString
fingerprint Verifier
v
        , Word16 -> Text
forall s. Show s => s -> Text
showT (Word16 -> Text) -> Word16 -> Text
forall a b. (a -> b) -> a -> b
$ Getting Word16 Verifier Word16 -> Verifier -> Word16
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Word16 Verifier Word16
Lens' Verifier Word16
required Verifier
v
        , Word16 -> Text
forall s. Show s => s -> Text
showT (Word16 -> Text) -> Word16 -> Text
forall a b. (a -> b) -> a -> b
$ Getting Word16 Verifier Word16 -> Verifier -> Word16
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Word16 Verifier Word16
Lens' Verifier Word16
total Verifier
v
        , Integer -> Text
forall s. Show s => s -> Text
showT (Integer -> Text) -> Integer -> Text
forall a b. (a -> b) -> a -> b
$ Getting Integer Verifier Integer -> Verifier -> Integer
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Integer Verifier Integer
Lens' Verifier Integer
size Verifier
v
        ]
dangerRealShow (CHKReader Reader
r) =
    Text -> [Text] -> Text
T.intercalate
        Text
":"
        [ Text
"URI"
        , Text
"CHK"
        , ByteString -> Text
showBase32 (ByteString -> Text)
-> (Key AES128 -> ByteString) -> Key AES128 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key AES128 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (Key AES128 -> Text) -> Key AES128 -> Text
forall a b. (a -> b) -> a -> b
$ Getting (Key AES128) Reader (Key AES128) -> Reader -> Key AES128
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Key AES128) Reader (Key AES128)
Lens' Reader (Key AES128)
readKey Reader
r
        , ByteString -> Text
showBase32 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Getting ByteString Reader ByteString -> Reader -> ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Verifier -> Const ByteString Verifier)
-> Reader -> Const ByteString Reader
Lens' Reader Verifier
verifier ((Verifier -> Const ByteString Verifier)
 -> Reader -> Const ByteString Reader)
-> Getting ByteString Verifier ByteString
-> Getting ByteString Reader ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ByteString Verifier ByteString
Lens' Verifier ByteString
fingerprint) Reader
r
        , Word16 -> Text
forall s. Show s => s -> Text
showT (Word16 -> Text) -> Word16 -> Text
forall a b. (a -> b) -> a -> b
$ Getting Word16 Reader Word16 -> Reader -> Word16
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Verifier -> Const Word16 Verifier)
-> Reader -> Const Word16 Reader
Lens' Reader Verifier
verifier ((Verifier -> Const Word16 Verifier)
 -> Reader -> Const Word16 Reader)
-> Getting Word16 Verifier Word16 -> Getting Word16 Reader Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Word16 Verifier Word16
Lens' Verifier Word16
required) Reader
r
        , Word16 -> Text
forall s. Show s => s -> Text
showT (Word16 -> Text) -> Word16 -> Text
forall a b. (a -> b) -> a -> b
$ Getting Word16 Reader Word16 -> Reader -> Word16
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Verifier -> Const Word16 Verifier)
-> Reader -> Const Word16 Reader
Lens' Reader Verifier
verifier ((Verifier -> Const Word16 Verifier)
 -> Reader -> Const Word16 Reader)
-> Getting Word16 Verifier Word16 -> Getting Word16 Reader Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Word16 Verifier Word16
Lens' Verifier Word16
total) Reader
r
        , Integer -> Text
forall s. Show s => s -> Text
showT (Integer -> Text) -> Integer -> Text
forall a b. (a -> b) -> a -> b
$ Getting Integer Reader Integer -> Reader -> Integer
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Verifier -> Const Integer Verifier)
-> Reader -> Const Integer Reader
Lens' Reader Verifier
verifier ((Verifier -> Const Integer Verifier)
 -> Reader -> Const Integer Reader)
-> Getting Integer Verifier Integer
-> Getting Integer Reader Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Integer Verifier Integer
Lens' Verifier Integer
size) Reader
r
        ]

{- | A parser combinator for parsing either a verify or read CHK capability
 from the canonical format.  This is the moral inverse of dangerRealShow.
-}
pCapability :: Parser CHK
pCapability :: Parser CHK
pCapability = Parser CHK -> Parser CHK
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Verifier -> CHK
CHKVerifier (Verifier -> CHK)
-> ParsecT Void Text Identity Verifier -> Parser CHK
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Verifier
pVerifier) Parser CHK -> Parser CHK -> Parser CHK
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Reader -> CHK
CHKReader (Reader -> CHK) -> ParsecT Void Text Identity Reader -> Parser CHK
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Reader
pReader)

-- | A parser combinator for parsing a CHK verify capability.
pVerifier :: Parser Verifier
pVerifier :: ParsecT Void Text Identity Verifier
pVerifier =
    ByteString -> ByteString -> Word16 -> Word16 -> Integer -> Verifier
Verifier
        (ByteString
 -> ByteString -> Word16 -> Word16 -> Integer -> Verifier)
-> ParsecT Void Text Identity ByteString
-> ParsecT
     Void
     Text
     Identity
     (ByteString -> Word16 -> Word16 -> Integer -> Verifier)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"URI:CHK-Verifier:" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity ByteString
-> ParsecT Void Text Identity ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> Word16 -> ParsecT Void Text Identity ByteString
pBase32 String
rfc3548Alphabet Word16
128)
        ParsecT
  Void
  Text
  Identity
  (ByteString -> Word16 -> Word16 -> Integer -> Verifier)
-> ParsecT Void Text Identity Char
-> ParsecT
     Void
     Text
     Identity
     (ByteString -> Word16 -> Word16 -> Integer -> Verifier)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':'
        ParsecT
  Void
  Text
  Identity
  (ByteString -> Word16 -> Word16 -> Integer -> Verifier)
-> ParsecT Void Text Identity ByteString
-> ParsecT
     Void Text Identity (Word16 -> Word16 -> Integer -> Verifier)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Word16 -> ParsecT Void Text Identity ByteString
pBase32 String
rfc3548Alphabet Word16
256
        ParsecT
  Void Text Identity (Word16 -> Word16 -> Integer -> Verifier)
-> ParsecT Void Text Identity Char
-> ParsecT
     Void Text Identity (Word16 -> Word16 -> Integer -> Verifier)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':'
        ParsecT
  Void Text Identity (Word16 -> Word16 -> Integer -> Verifier)
-> ParsecT Void Text Identity Word16
-> ParsecT Void Text Identity (Word16 -> Integer -> Verifier)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word16 -> Word16 -> ParsecT Void Text Identity Word16
forall n. (Ord n, Integral n) => n -> n -> Parser n
bounded Word16
1 Word16
maxShares
        ParsecT Void Text Identity (Word16 -> Integer -> Verifier)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Word16 -> Integer -> Verifier)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':'
        ParsecT Void Text Identity (Word16 -> Integer -> Verifier)
-> ParsecT Void Text Identity Word16
-> ParsecT Void Text Identity (Integer -> Verifier)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word16 -> Word16 -> ParsecT Void Text Identity Word16
forall n. (Ord n, Integral n) => n -> n -> Parser n
bounded Word16
1 Word16
maxShares
        ParsecT Void Text Identity (Integer -> Verifier)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Integer -> Verifier)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':'
        ParsecT Void Text Identity (Integer -> Verifier)
-> ParsecT Void Text Identity Integer
-> ParsecT Void Text Identity Verifier
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Integer -> Integer -> ParsecT Void Text Identity Integer
forall n. (Ord n, Integral n) => n -> n -> Parser n
bounded Integer
1 Integer
maxDataSize

-- | A parser combinator for parsing a CHK read capability.
pReader :: Parser Reader
pReader :: ParsecT Void Text Identity Reader
pReader =
    Key AES128 -> ByteString -> Word16 -> Word16 -> Integer -> Reader
makeReader
        (Key AES128 -> ByteString -> Word16 -> Word16 -> Integer -> Reader)
-> ParsecT Void Text Identity (Key AES128)
-> ParsecT
     Void
     Text
     Identity
     (ByteString -> Word16 -> Word16 -> Integer -> Reader)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"URI:CHK:"
                ParsecT Void Text Identity Text
-> ParsecT Void Text Identity ByteString
-> ParsecT Void Text Identity ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> Word16 -> ParsecT Void Text Identity ByteString
pBase32 String
rfc3548Alphabet Word16
128
                ParsecT Void Text Identity ByteString
-> (ByteString -> ParsecT Void Text Identity (Key AES128))
-> ParsecT Void Text Identity (Key AES128)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParsecT Void Text Identity (Key AES128)
-> (Key AES128 -> ParsecT Void Text Identity (Key AES128))
-> Maybe (Key AES128)
-> ParsecT Void Text Identity (Key AES128)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Set (ErrorFancy Void) -> ParsecT Void Text Identity (Key AES128)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
Set (ErrorFancy e) -> m a
fancyFailure (Set (ErrorFancy Void) -> ParsecT Void Text Identity (Key AES128))
-> (Text -> Set (ErrorFancy Void))
-> Text
-> ParsecT Void Text Identity (Key AES128)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorFancy Void -> Set (ErrorFancy Void)
forall a. a -> Set a
Set.singleton (ErrorFancy Void -> Set (ErrorFancy Void))
-> (Text -> ErrorFancy Void) -> Text -> Set (ErrorFancy Void)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorFancy Void
forall e. String -> ErrorFancy e
ErrorFail (String -> ErrorFancy Void)
-> (Text -> String) -> Text -> ErrorFancy Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> ParsecT Void Text Identity (Key AES128))
-> Text -> ParsecT Void Text Identity (Key AES128)
forall a b. (a -> b) -> a -> b
$ Text
"Failed to build AESKey128 from CHK read key bytes") Key AES128 -> ParsecT Void Text Identity (Key AES128)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Key AES128) -> ParsecT Void Text Identity (Key AES128))
-> (ByteString -> Maybe (Key AES128))
-> ByteString
-> ParsecT Void Text Identity (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
            )
        ParsecT
  Void
  Text
  Identity
  (ByteString -> Word16 -> Word16 -> Integer -> Reader)
-> ParsecT Void Text Identity Char
-> ParsecT
     Void
     Text
     Identity
     (ByteString -> Word16 -> Word16 -> Integer -> Reader)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':'
        ParsecT
  Void
  Text
  Identity
  (ByteString -> Word16 -> Word16 -> Integer -> Reader)
-> ParsecT Void Text Identity ByteString
-> ParsecT
     Void Text Identity (Word16 -> Word16 -> Integer -> Reader)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Word16 -> ParsecT Void Text Identity ByteString
pBase32 String
rfc3548Alphabet Word16
256
        ParsecT Void Text Identity (Word16 -> Word16 -> Integer -> Reader)
-> ParsecT Void Text Identity Char
-> ParsecT
     Void Text Identity (Word16 -> Word16 -> Integer -> Reader)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':'
        ParsecT Void Text Identity (Word16 -> Word16 -> Integer -> Reader)
-> ParsecT Void Text Identity Word16
-> ParsecT Void Text Identity (Word16 -> Integer -> Reader)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word16 -> Word16 -> ParsecT Void Text Identity Word16
forall n. (Ord n, Integral n) => n -> n -> Parser n
bounded Word16
1 Word16
256
        ParsecT Void Text Identity (Word16 -> Integer -> Reader)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Word16 -> Integer -> Reader)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':'
        ParsecT Void Text Identity (Word16 -> Integer -> Reader)
-> ParsecT Void Text Identity Word16
-> ParsecT Void Text Identity (Integer -> Reader)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word16 -> Word16 -> ParsecT Void Text Identity Word16
forall n. (Ord n, Integral n) => n -> n -> Parser n
bounded Word16
1 Word16
256
        ParsecT Void Text Identity (Integer -> Reader)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Integer -> Reader)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':'
        ParsecT Void Text Identity (Integer -> Reader)
-> ParsecT Void Text Identity Integer
-> ParsecT Void Text Identity Reader
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Integer -> Integer -> ParsecT Void Text Identity Integer
forall n. (Ord n, Integral n) => n -> n -> Parser n
bounded Integer
1 Integer
maxDataSize

{- | Construct a CHK read capability from its components.  This includes the
 correct derivation of the corresponding CHK verify capability.
-}
makeReader :: Key AES128 -> B.ByteString -> Word16 -> Word16 -> Integer -> Reader
makeReader :: Key AES128 -> ByteString -> Word16 -> Word16 -> Integer -> Reader
makeReader Key AES128
readKey' ByteString
fingerprint' Word16
required' Word16
total' Integer
size' =
    Key AES128 -> Verifier -> Reader
Reader Key AES128
readKey' (Key AES128 -> ByteString -> Word16 -> Word16 -> Integer -> Verifier
deriveVerifier Key AES128
readKey' ByteString
fingerprint' Word16
required' Word16
total' Integer
size')

{- | Given all of the fields of a CHK read capability, derive and return the
 corresponding CHK verify capability.
-}
deriveVerifier ::
    -- | The read key
    Key AES128 ->
    -- | The fingerprint
    B.ByteString ->
    -- | The required number of shares
    Word16 ->
    -- | The total number of shares
    Word16 ->
    -- | The plaintext size
    Integer ->
    Verifier
deriveVerifier :: Key AES128 -> ByteString -> Word16 -> Word16 -> Integer -> Verifier
deriveVerifier = ByteString -> ByteString -> Word16 -> Word16 -> Integer -> Verifier
Verifier (ByteString
 -> ByteString -> Word16 -> Word16 -> Integer -> Verifier)
-> (Key AES128 -> ByteString)
-> Key AES128
-> ByteString
-> Word16
-> Word16
-> Integer
-> Verifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key AES128 -> ByteString
storageIndexHash

{- | A parser combinator for an arbitrary byte string of a fixed length,
 encoded using base32.
-}
pBase32 ::
    -- | The alphabet to use.  For example, *rfc3548Alphabet*.
    [Char] ->
    -- | The number of bits in the encoded byte string.
    Word16 ->
    -- | A parser for the byte string.  Strings that are not valid base32 will
    -- be rejected.  Strings that are the wrong length are *not necessarily*
    -- currently rejected!  Please fix that, somebody.
    Parser B.ByteString
pBase32 :: String -> Word16 -> ParsecT Void Text Identity ByteString
pBase32 String
alpha Word16
bits = do
    Text
b32Text <- ParsecT Void Text Identity Text
pBase32Text
    (Text -> ParsecT Void Text Identity ByteString)
-> (ByteString -> ParsecT Void Text Identity ByteString)
-> Either Text ByteString
-> ParsecT Void Text Identity ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Set (ErrorFancy Void) -> ParsecT Void Text Identity ByteString
forall e s (m :: * -> *) a.
MonadParsec e s m =>
Set (ErrorFancy e) -> m a
fancyFailure (Set (ErrorFancy Void) -> ParsecT Void Text Identity ByteString)
-> (Text -> Set (ErrorFancy Void))
-> Text
-> ParsecT Void Text Identity ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorFancy Void -> Set (ErrorFancy Void)
forall a. a -> Set a
Set.singleton (ErrorFancy Void -> Set (ErrorFancy Void))
-> (Text -> ErrorFancy Void) -> Text -> Set (ErrorFancy Void)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorFancy Void
forall e. String -> ErrorFancy e
ErrorFail (String -> ErrorFancy Void)
-> (Text -> String) -> Text -> ErrorFancy Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) ByteString -> ParsecT Void Text Identity ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either Text ByteString
decodeBase32Text Text
b32Text)
  where
    decodeBase32Text :: Text -> Either Text ByteString
decodeBase32Text = ByteString -> Either Text ByteString
B.decodeBase32Unpadded (ByteString -> Either Text ByteString)
-> (Text -> ByteString) -> Text -> Either Text ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8
    pBase32Text :: ParsecT Void Text Identity Text
pBase32Text = Text -> Char -> Text
T.snoc (Text -> Char -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Char -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
stem ParsecT Void Text Identity (Char -> Text)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Char
trailer

    -- Determine how many full characters to expect along with how many bits
    -- are left to expect encoded in the final character.
    (Word16
full, Word16
extra) = Word16
bits Word16 -> Word16 -> (Word16, Word16)
forall a. Integral a => a -> a -> (a, a)
`divMod` Word16
5

    -- Match the base32 characters that represent the full 5 bits
    -- possible.  fromIntegral is okay here because `full` is only a
    -- Word16 and will definitely fit safely into the Int count wants.
    stem :: Parser T.Text
    stem :: ParsecT Void Text Identity Text
stem = String -> Text
T.pack (String -> Text)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
full) ([Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf String
[Token Text]
alpha)

    -- Match the final character that represents fewer than 5 bits.
    trailer :: Parser Char
    trailer :: ParsecT Void Text Identity Char
trailer = [Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf ([Token Text] -> ParsecT Void Text Identity (Token Text))
-> [Token Text] -> ParsecT Void Text Identity (Token Text)
forall a b. (a -> b) -> a -> b
$ String -> Word16 -> String
trailingChars String
alpha Word16
extra

    -- XXX The real trailing character set is smaller than this.  This
    -- parser will let through invalid characters that result in giving us
    -- possibly too many bits.
    trailingChars :: [Char] -> Word16 -> [Char]
    trailingChars :: String -> Word16 -> String
trailingChars String
alpha' Word16
_ = String
alpha'

{- | The RFC3548 standard alphabet used by Gnutella, Content-Addressable Web,
 THEX, Bitzi, Web-Calculus...
-}
rfc3548Alphabet :: [Char]
rfc3548Alphabet :: String
rfc3548Alphabet = String
"abcdefghijklmnopqrstuvwxyz234567"