diff --git a/haskell/Codec/FEC.hs b/haskell/Codec/FEC.hs index df92ac4..9cbbf21 100644 --- a/haskell/Codec/FEC.hs +++ b/haskell/Codec/FEC.hs @@ -31,22 +31,25 @@ module Codec.FEC ( import Data.Bits (xor) import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as BI import qualified Data.ByteString.Unsafe as BU import Data.List (nub, partition, sortBy, (\\)) import Data.Word (Word8) -import Foreign.C.Types -import Foreign.ForeignPtr -import Foreign.Marshal.Alloc +import Foreign.C.Types (CSize (..), CUInt (..)) +import Foreign.ForeignPtr ( + ForeignPtr, + newForeignPtr, + withForeignPtr, + ) +import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Marshal.Array (advancePtr, withArray) -import Foreign.Ptr +import Foreign.Ptr (FunPtr, Ptr, castPtr) import Foreign.Storable (poke, sizeOf) import System.IO (IOMode (..), withFile) import System.IO.Unsafe (unsafePerformIO) data CFEC data FECParams = FECParams - { cfec :: (ForeignPtr CFEC) + { _cfec :: ForeignPtr CFEC , paramK :: Int , paramN :: Int } @@ -111,17 +114,17 @@ fec k n = else unsafePerformIO ( do - cfec <- _new (fromIntegral k) (fromIntegral n) - params <- newForeignPtr _free cfec + cfec' <- _new (fromIntegral k) (fromIntegral n) + params <- newForeignPtr _free cfec' return $ FECParams params k n ) -- | Create a C array of unsigned from an input array -uintCArray :: [Int] -> ((Ptr CUInt) -> IO a) -> IO a -uintCArray xs f = withArray (map fromIntegral xs) f +uintCArray :: [Int] -> (Ptr CUInt -> IO a) -> IO a +uintCArray = withArray . map fromIntegral -- | Convert a list of ByteStrings to an array of pointers to their data -byteStringsToArray :: [B.ByteString] -> ((Ptr (Ptr Word8)) -> IO a) -> IO a +byteStringsToArray :: [B.ByteString] -> (Ptr (Ptr Word8) -> IO a) -> IO a byteStringsToArray inputs f = do let l = length inputs allocaBytes @@ -141,7 +144,7 @@ byteStringsToArray inputs f = do -- | Return True iff all the given ByteStrings are the same length allByteStringsSameLength :: [B.ByteString] -> Bool allByteStringsSameLength [] = True -allByteStringsSameLength (bs : bss) = all ((==) (B.length bs)) $ map B.length bss +allByteStringsSameLength (bs : bss) = all ((==) (B.length bs) . B.length) bss {- | Run the given function with a pointer to an array of @n@ pointers to buffers of size @size@. Return these buffers as a list of ByteStrings @@ -151,7 +154,7 @@ createByteStringArray :: Int -> -- | the size of each buffer Int -> - ((Ptr (Ptr Word8)) -> IO ()) -> + (Ptr (Ptr Word8) -> IO ()) -> IO [B.ByteString] createByteStringArray n size f = do allocaBytes @@ -185,7 +188,7 @@ encode (FECParams params k n) inblocks let sz = B.length $ head inblocks withForeignPtr params - ( \cfec -> do + ( \cfec' -> do byteStringsToArray inblocks ( \src -> do @@ -196,7 +199,7 @@ encode (FECParams params k n) inblocks uintCArray [k .. (n - 1)] ( \block_nums -> do - _encode cfec src fecs block_nums (fromIntegral (n - k)) $ fromIntegral sz + _encode cfec' src fecs block_nums (fromIntegral (n - k)) $ fromIntegral sz ) ) ) @@ -214,12 +217,12 @@ reorderPrimaryBlocks :: Int -> [(Int, a)] -> [(Int, a)] reorderPrimaryBlocks n blocks = inner (sortTagged pBlocks) sBlocks [] where (pBlocks, sBlocks) = partition (\(tag, _) -> tag < n) blocks - inner [] sBlocks acc = acc ++ sBlocks - inner pBlocks [] acc = acc ++ pBlocks - inner pBlocks@((tag, a) : ps) sBlocks@(s : ss) acc = + inner [] sBlocks' acc = acc ++ sBlocks' + inner pBlocks' [] acc = acc ++ pBlocks' + inner pBlocks'@((tag, a) : ps) sBlocks'@(s : ss) acc = if length acc == tag - then inner ps sBlocks (acc ++ [(tag, a)]) - else inner pBlocks ss (acc ++ [s]) + then inner ps sBlocks' (acc ++ [(tag, a)]) + else inner pBlocks' ss (acc ++ [s]) {- | Recover the primary blocks from a list of @k@ blocks. Each block must be tagged with its number (see the module comments about block numbering) @@ -231,8 +234,8 @@ decode :: -- | a list the @k@ primary blocks [B.ByteString] decode (FECParams params k n) inblocks - | length (nub $ map fst inblocks) /= length (inblocks) = error "Duplicate input blocks in FEC decode" - | any (\f -> f < 0 || f >= n) $ map fst inblocks = error "Invalid block numbers in FEC decode" + | length (nub $ map fst inblocks) /= length inblocks = error "Duplicate input blocks in FEC decode" + | any ((\f -> f < 0 || f >= n) . fst) inblocks = error "Invalid block numbers in FEC decode" | length inblocks /= k = error "Wrong number of blocks to FEC decode" | not (allByteStringsSameLength $ map snd inblocks) = error "Not all inputs to FEC decode are same length" | otherwise = @@ -243,7 +246,7 @@ decode (FECParams params k n) inblocks presentBlocks = map fst inblocks' withForeignPtr params - ( \cfec -> do + ( \cfec' -> do byteStringsToArray (map snd inblocks') ( \src -> do @@ -255,7 +258,7 @@ decode (FECParams params k n) inblocks uintCArray presentBlocks ( \block_nums -> do - _decode cfec src out block_nums $ fromIntegral sz + _decode cfec' src out block_nums $ fromIntegral sz ) ) let blocks = [0 .. (n - 1)] \\ presentBlocks @@ -291,10 +294,10 @@ secureDivide n input ReadMode ( \handle -> do let inner 1 bs = return [bs] - inner n bs = do + inner n' bs = do mask <- B.hGet handle (B.length bs) let masked = B.pack $ B.zipWith xor bs mask - rest <- inner (n - 1) masked + rest <- inner (n' - 1) masked return (mask : rest) inner n input ) @@ -323,14 +326,14 @@ enFEC :: [B.ByteString] enFEC k n input = taggedPrimaryBlocks ++ taggedSecondaryBlocks where - taggedPrimaryBlocks = map (uncurry B.cons) $ zip [0 ..] primaryBlocks - taggedSecondaryBlocks = map (uncurry B.cons) $ zip [(fromIntegral k) ..] secondaryBlocks + taggedPrimaryBlocks = zipWith B.cons [0 ..] primaryBlocks + taggedSecondaryBlocks = zipWith B.cons [(fromIntegral k) ..] secondaryBlocks remainder = B.length input `mod` k - paddingLength = if remainder >= 1 then (k - remainder) else k - paddingBytes = (B.replicate (paddingLength - 1) 0) `B.append` (B.singleton $ fromIntegral paddingLength) + paddingLength = if remainder >= 1 then k - remainder else k + paddingBytes = B.replicate (paddingLength - 1) 0 `B.append` B.singleton (fromIntegral paddingLength) divide a bs | B.null bs = [] - | otherwise = (B.take a bs) : (divide a $ B.drop a bs) + | otherwise = B.take a bs : divide a (B.drop a bs) input' = input `B.append` paddingBytes blockSize = B.length input' `div` k primaryBlocks = divide blockSize input' diff --git a/haskell/test/FECTest.hs b/haskell/test/FECTest.hs index 0e22606..042f377 100644 --- a/haskell/test/FECTest.hs +++ b/haskell/test/FECTest.hs @@ -2,20 +2,26 @@ module Main where -import Test.Hspec +import Test.Hspec (describe, hspec, it, parallel) import qualified Codec.FEC as FEC import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.Int +import Data.Int () import Data.List (sortOn) -import Data.Serializer -import Data.Word - -import System.IO (IOMode (..), withFile) -import System.Random -import Test.QuickCheck -import Test.QuickCheck.Monadic +import Data.Serializer () +import Data.Word (Word16, Word8) + +import System.Random (Random (randoms), mkStdGen) +import Test.QuickCheck ( + Arbitrary (arbitrary), + Property, + Testable (property), + choose, + once, + withMaxSuccess, + (===), + ) +import Test.QuickCheck.Monadic (assert, monadicIO, run) -- Imported for the orphan Arbitrary ByteString instance. import Test.QuickCheck.Instances.ByteString () @@ -29,15 +35,9 @@ data Params = Params -- | A somewhat efficient generator for valid ZFEC parameters. instance Arbitrary Params where - arbitrary = do - required <- choose (1, 255) - total <- choose (required, 255) - return $ Params required total - -instance Arbitrary FEC.FECParams where - arbitrary = do - (Params required total) <- arbitrary :: Gen Params - return $ FEC.fec required total + arbitrary = + choose (1, 255) + >>= \req -> Params req <$> choose (req, 255) randomTake :: Int -> Int -> [a] -> [a] randomTake seed n values = map snd $ take n sortedValues @@ -89,30 +89,34 @@ prop_divide size byte divisor = monadicIO $ do assert (FEC.secureCombine parts == input) -- | @FEC.encode@ is the inverse of @FEC.decode@. -prop_decode :: FEC.FECParams -> Word16 -> Int -> Property -prop_decode fec len seed = property $ testFEC fec len seed +prop_decode :: Params -> Word16 -> Int -> Property +prop_decode (Params req tot) len seed = property $ do + testFEC fec len seed === True + where + fec = FEC.fec req tot -- | @FEC.enFEC@ is the inverse of @FEC.deFEC@. prop_deFEC :: Params -> B.ByteString -> Property -prop_deFEC (Params required total) testdata = - FEC.deFEC required total minimalShares === testdata +prop_deFEC (Params req tot) testdata = + FEC.deFEC req tot minimalShares === testdata where - allShares = FEC.enFEC required total testdata - minimalShares = take required allShares + allShares = FEC.enFEC req tot testdata + minimalShares = take req allShares main :: IO () -main = hspec $ do - describe "secureCombine" $ do - -- secureDivide is insanely slow and memory hungry for large inputs, - -- like QuickCheck will find with it as currently defined. Just pass - -- some small inputs. It's not clear it's worth fixing (or even - -- keeping) thesefunctions. They don't seem to be used by anything. - -- Why are they here? - it "is the inverse of secureDivide n" $ once $ prop_divide 1024 65 3 - - describe "deFEC" $ do - it "is the inverse of enFEC" $ (withMaxSuccess 2000 prop_deFEC) - - describe "decode" $ do - it "is (nearly) the inverse of encode" $ (withMaxSuccess 2000 prop_decode) - it "works with required=255" $ property $ prop_decode (FEC.fec 255 255) +main = hspec $ + parallel $ do + describe "secureCombine" $ do + -- secureDivide is insanely slow and memory hungry for large inputs, + -- like QuickCheck will find with it as currently defined. Just pass + -- some small inputs. It's not clear it's worth fixing (or even + -- keeping) thesefunctions. They don't seem to be used by anything. + -- Why are they here? + it "is the inverse of secureDivide n" $ once $ prop_divide 1024 65 3 + + describe "deFEC" $ do + it "is the inverse of enFEC" (withMaxSuccess 2000 prop_deFEC) + + describe "decode" $ do + it "is (nearly) the inverse of encode" (withMaxSuccess 2000 prop_decode) + it "works with required=255" $ property $ prop_decode (Params 255 255)