hashed-storage (empty) → 0.3
raw patch · 15 files changed
+2659/−0 lines, 15 filesdep +HUnitdep +basedep +binarybuild-type:Customsetup-changed
Dependencies added: HUnit, base, binary, bytestring, bytestring-mmap, containers, directory, extensible-exceptions, filepath, lcs, mmap, mtl, process, zlib
Files
- Bundled/Posix.hsc +84/−0
- Bundled/SHA256.hs +48/−0
- Bundled/sha2.c +950/−0
- Bundled/sha2.h +108/−0
- Setup.hs +12/−0
- Storage/Hashed.hs +167/−0
- Storage/Hashed/AnchoredPath.hs +62/−0
- Storage/Hashed/Diff.hs +136/−0
- Storage/Hashed/Index.hs +239/−0
- Storage/Hashed/Monad.hs +209/−0
- Storage/Hashed/Test.hs +104/−0
- Storage/Hashed/Tree.hs +367/−0
- Storage/Hashed/Utils.hs +112/−0
- hashed-storage.cabal +55/−0
- test.hs +6/−0
+ Bundled/Posix.hsc view
@@ -0,0 +1,84 @@+{-# OPTIONS_GHC -cpp #-}+module Bundled.Posix( getFdStatus, getSymbolicLinkStatus, getFileStatus+ , getFileStatusBS+ , fileExists+ , modificationTime, fileSize, FileStatus+ , EpochTime, isDirectory ) where++import qualified Data.ByteString.Char8 as BS+import Data.ByteString.Unsafe( unsafeUseAsCString )+import Foreign.Marshal.Alloc ( allocaBytes )+import Foreign.C.Error ( throwErrno, getErrno, eNOENT )+import Foreign.C.String ( withCString )+import Foreign.C.Types ( CTime, CInt )+import Foreign.Ptr ( Ptr )++import System.Posix.Internals+ ( CStat, c_fstat, lstat, c_stat, sizeof_stat+ , st_mode, st_size, st_mtime, s_isdir )++import System.Posix.Types ( Fd(..), CMode, EpochTime )++#if mingw32_HOST_OS+import Data.Int ( Int64 )+#else+import System.Posix.Types ( FileOffset )+#endif++##if mingw32_HOST_OS+type FileOffset = Int64+##endif++data FileStatus = FileStatus {+ fst_exists :: Bool,+ fst_mode :: CMode,+ fst_mtime :: CTime,+ fst_size :: FileOffset+ }++getFdStatus :: Fd -> IO FileStatus+getFdStatus (Fd fd) = do+ do_stat (c_fstat fd)++do_stat :: (Ptr CStat -> IO CInt) -> IO FileStatus+do_stat stat_func = do+ allocaBytes sizeof_stat $ \p -> do+ ret <- stat_func p+ err <- getErrno+ case (ret == -1 && err == eNOENT, ret == 0) of+ (True, _) -> return (FileStatus False 0 0 0)+ (False, True) -> do mode <- st_mode p+ mtime <- st_mtime p+ size <- st_size p+ return (FileStatus True mode mtime+ (fromIntegral size))+ _ -> throwErrno "do_stat"+{-# INLINE do_stat #-}++isDirectory :: FileStatus -> Bool+isDirectory = s_isdir . fst_mode++modificationTime :: FileStatus -> EpochTime+modificationTime = fst_mtime++fileSize :: FileStatus -> FileOffset+fileSize = fst_size++fileExists :: FileStatus -> Bool+fileExists = fst_exists++#include <sys/stat.h>++getSymbolicLinkStatus :: FilePath -> IO FileStatus+getSymbolicLinkStatus fp = + do_stat (\p -> (fp `withCString` (`lstat` p)))++getFileStatus :: FilePath -> IO FileStatus+getFileStatus fp =+ do_stat (\p -> (fp `withCString` (`c_stat` p)))++-- | Requires NULL-terminated bytestring -> unsafe! Use with care.+getFileStatusBS :: BS.ByteString -> IO FileStatus+getFileStatusBS fp =+ do_stat (\p -> (fp `unsafeUseAsCString` (`lstat` p)))+{-# INLINE getFileStatusBS #-}
+ Bundled/SHA256.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++-- |+-- Module: Data.Digest.SHA256+-- Copyright: Zooko O'Whielacronx+-- License: GPL+--+-- Stability: experimental++-- ByteString-based, zero-copying binding to Crypto++'s sha interface++-- thanks to Don Stewart <dons@galois.com>, Matthew Sackman+-- <matthew@wellquite.org>, Brian O'Sullivan, lispy, Adam Langley++module Bundled.SHA256 ( sha256 ) where++import Foreign+import Foreign.C.Types+import Numeric (showHex)+import Foreign.C.String ( withCString )+#if __GLASGOW_HASKELL__ > 606+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+#else+import Data.ByteString.Base (unsafeUseAsCStringLen)+#endif+import qualified Data.ByteString as B++sha256 :: B.ByteString -> String+sha256 p = unsafePerformIO $+ withCString (take 64 $ repeat 'x') $ \digestCString ->+ unsafeUseAsCStringLen p $ \(ptr,n) ->+ do let digest = castPtr digestCString :: Ptr Word8+ c_sha256 ptr (fromIntegral n) digest+ go digest 0 []+ where -- print it in 0-padded hex format+ go :: Ptr Word8 -> Int -> [String] -> IO String+ go q n acc | seq q n >= 32 = return $ concat (reverse acc)+ | otherwise = do w <- peekElemOff q n+ go q (n+1) (draw w : acc)+ draw w = case showHex w [] of+ [x] -> ['0', x]+ x -> x++-- void sha256sum(const unsigned char *d, size_t n, unsigned char *md);+--+foreign import ccall unsafe "sha2.h sha256" c_sha256+ :: Ptr CChar -> CSize -> Ptr Word8 -> IO ()+
+ Bundled/sha2.c view
@@ -0,0 +1,950 @@+/*+ * FIPS 180-2 SHA-224/256/384/512 implementation+ * Last update: 02/02/2007+ * Issue date: 04/30/2005+ *+ * Copyright (C) 2005, 2007 Olivier Gay <olivier.gay@a3.epfl.ch>+ * All rights reserved.+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions+ * are met:+ * 1. Redistributions of source code must retain the above copyright+ * notice, this list of conditions and the following disclaimer.+ * 2. Redistributions in binary form must reproduce the above copyright+ * notice, this list of conditions and the following disclaimer in the+ * documentation and/or other materials provided with the distribution.+ * 3. Neither the name of the project nor the names of its contributors+ * may be used to endorse or promote products derived from this software+ * without specific prior written permission.+ *+ * THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``AS IS'' AND+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ * ARE DISCLAIMED. IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE LIABLE+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+ * SUCH DAMAGE.+ */++#if 0+#define UNROLL_LOOPS /* Enable loops unrolling */+#endif++#include <string.h>++#include "sha2.h"++#define SHFR(x, n) (x >> n)+#define ROTR(x, n) ((x >> n) | (x << ((sizeof(x) << 3) - n)))+#define ROTL(x, n) ((x << n) | (x >> ((sizeof(x) << 3) - n)))+#define CH(x, y, z) ((x & y) ^ (~x & z))+#define MAJ(x, y, z) ((x & y) ^ (x & z) ^ (y & z))++#define SHA256_F1(x) (ROTR(x, 2) ^ ROTR(x, 13) ^ ROTR(x, 22))+#define SHA256_F2(x) (ROTR(x, 6) ^ ROTR(x, 11) ^ ROTR(x, 25))+#define SHA256_F3(x) (ROTR(x, 7) ^ ROTR(x, 18) ^ SHFR(x, 3))+#define SHA256_F4(x) (ROTR(x, 17) ^ ROTR(x, 19) ^ SHFR(x, 10))++#define SHA512_F1(x) (ROTR(x, 28) ^ ROTR(x, 34) ^ ROTR(x, 39))+#define SHA512_F2(x) (ROTR(x, 14) ^ ROTR(x, 18) ^ ROTR(x, 41))+#define SHA512_F3(x) (ROTR(x, 1) ^ ROTR(x, 8) ^ SHFR(x, 7))+#define SHA512_F4(x) (ROTR(x, 19) ^ ROTR(x, 61) ^ SHFR(x, 6))++#define UNPACK32(x, str) \+{ \+ *((str) + 3) = (uint8) ((x) ); \+ *((str) + 2) = (uint8) ((x) >> 8); \+ *((str) + 1) = (uint8) ((x) >> 16); \+ *((str) + 0) = (uint8) ((x) >> 24); \+}++#define PACK32(str, x) \+{ \+ *(x) = ((uint32) *((str) + 3) ) \+ | ((uint32) *((str) + 2) << 8) \+ | ((uint32) *((str) + 1) << 16) \+ | ((uint32) *((str) + 0) << 24); \+}++#define UNPACK64(x, str) \+{ \+ *((str) + 7) = (uint8) ((x) ); \+ *((str) + 6) = (uint8) ((x) >> 8); \+ *((str) + 5) = (uint8) ((x) >> 16); \+ *((str) + 4) = (uint8) ((x) >> 24); \+ *((str) + 3) = (uint8) ((x) >> 32); \+ *((str) + 2) = (uint8) ((x) >> 40); \+ *((str) + 1) = (uint8) ((x) >> 48); \+ *((str) + 0) = (uint8) ((x) >> 56); \+}++#define PACK64(str, x) \+{ \+ *(x) = ((uint64) *((str) + 7) ) \+ | ((uint64) *((str) + 6) << 8) \+ | ((uint64) *((str) + 5) << 16) \+ | ((uint64) *((str) + 4) << 24) \+ | ((uint64) *((str) + 3) << 32) \+ | ((uint64) *((str) + 2) << 40) \+ | ((uint64) *((str) + 1) << 48) \+ | ((uint64) *((str) + 0) << 56); \+}++/* Macros used for loops unrolling */++#define SHA256_SCR(i) \+{ \+ w[i] = SHA256_F4(w[i - 2]) + w[i - 7] \+ + SHA256_F3(w[i - 15]) + w[i - 16]; \+}++#define SHA512_SCR(i) \+{ \+ w[i] = SHA512_F4(w[i - 2]) + w[i - 7] \+ + SHA512_F3(w[i - 15]) + w[i - 16]; \+}++#define SHA256_EXP(a, b, c, d, e, f, g, h, j) \+{ \+ t1 = wv[h] + SHA256_F2(wv[e]) + CH(wv[e], wv[f], wv[g]) \+ + sha256_k[j] + w[j]; \+ t2 = SHA256_F1(wv[a]) + MAJ(wv[a], wv[b], wv[c]); \+ wv[d] += t1; \+ wv[h] = t1 + t2; \+}++#define SHA512_EXP(a, b, c, d, e, f, g ,h, j) \+{ \+ t1 = wv[h] + SHA512_F2(wv[e]) + CH(wv[e], wv[f], wv[g]) \+ + sha512_k[j] + w[j]; \+ t2 = SHA512_F1(wv[a]) + MAJ(wv[a], wv[b], wv[c]); \+ wv[d] += t1; \+ wv[h] = t1 + t2; \+}++uint32 sha224_h0[8] =+ {0xc1059ed8, 0x367cd507, 0x3070dd17, 0xf70e5939,+ 0xffc00b31, 0x68581511, 0x64f98fa7, 0xbefa4fa4};++uint32 sha256_h0[8] =+ {0x6a09e667, 0xbb67ae85, 0x3c6ef372, 0xa54ff53a,+ 0x510e527f, 0x9b05688c, 0x1f83d9ab, 0x5be0cd19};++uint64 sha384_h0[8] =+ {0xcbbb9d5dc1059ed8ULL, 0x629a292a367cd507ULL,+ 0x9159015a3070dd17ULL, 0x152fecd8f70e5939ULL,+ 0x67332667ffc00b31ULL, 0x8eb44a8768581511ULL,+ 0xdb0c2e0d64f98fa7ULL, 0x47b5481dbefa4fa4ULL};++uint64 sha512_h0[8] =+ {0x6a09e667f3bcc908ULL, 0xbb67ae8584caa73bULL,+ 0x3c6ef372fe94f82bULL, 0xa54ff53a5f1d36f1ULL,+ 0x510e527fade682d1ULL, 0x9b05688c2b3e6c1fULL,+ 0x1f83d9abfb41bd6bULL, 0x5be0cd19137e2179ULL};++uint32 sha256_k[64] =+ {0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5,+ 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5,+ 0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3,+ 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174,+ 0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc,+ 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da,+ 0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7,+ 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967,+ 0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13,+ 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85,+ 0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3,+ 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070,+ 0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5,+ 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3,+ 0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208,+ 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2};++uint64 sha512_k[80] =+ {0x428a2f98d728ae22ULL, 0x7137449123ef65cdULL,+ 0xb5c0fbcfec4d3b2fULL, 0xe9b5dba58189dbbcULL,+ 0x3956c25bf348b538ULL, 0x59f111f1b605d019ULL,+ 0x923f82a4af194f9bULL, 0xab1c5ed5da6d8118ULL,+ 0xd807aa98a3030242ULL, 0x12835b0145706fbeULL,+ 0x243185be4ee4b28cULL, 0x550c7dc3d5ffb4e2ULL,+ 0x72be5d74f27b896fULL, 0x80deb1fe3b1696b1ULL,+ 0x9bdc06a725c71235ULL, 0xc19bf174cf692694ULL,+ 0xe49b69c19ef14ad2ULL, 0xefbe4786384f25e3ULL,+ 0x0fc19dc68b8cd5b5ULL, 0x240ca1cc77ac9c65ULL,+ 0x2de92c6f592b0275ULL, 0x4a7484aa6ea6e483ULL,+ 0x5cb0a9dcbd41fbd4ULL, 0x76f988da831153b5ULL,+ 0x983e5152ee66dfabULL, 0xa831c66d2db43210ULL,+ 0xb00327c898fb213fULL, 0xbf597fc7beef0ee4ULL,+ 0xc6e00bf33da88fc2ULL, 0xd5a79147930aa725ULL,+ 0x06ca6351e003826fULL, 0x142929670a0e6e70ULL,+ 0x27b70a8546d22ffcULL, 0x2e1b21385c26c926ULL,+ 0x4d2c6dfc5ac42aedULL, 0x53380d139d95b3dfULL,+ 0x650a73548baf63deULL, 0x766a0abb3c77b2a8ULL,+ 0x81c2c92e47edaee6ULL, 0x92722c851482353bULL,+ 0xa2bfe8a14cf10364ULL, 0xa81a664bbc423001ULL,+ 0xc24b8b70d0f89791ULL, 0xc76c51a30654be30ULL,+ 0xd192e819d6ef5218ULL, 0xd69906245565a910ULL,+ 0xf40e35855771202aULL, 0x106aa07032bbd1b8ULL,+ 0x19a4c116b8d2d0c8ULL, 0x1e376c085141ab53ULL,+ 0x2748774cdf8eeb99ULL, 0x34b0bcb5e19b48a8ULL,+ 0x391c0cb3c5c95a63ULL, 0x4ed8aa4ae3418acbULL,+ 0x5b9cca4f7763e373ULL, 0x682e6ff3d6b2b8a3ULL,+ 0x748f82ee5defb2fcULL, 0x78a5636f43172f60ULL,+ 0x84c87814a1f0ab72ULL, 0x8cc702081a6439ecULL,+ 0x90befffa23631e28ULL, 0xa4506cebde82bde9ULL,+ 0xbef9a3f7b2c67915ULL, 0xc67178f2e372532bULL,+ 0xca273eceea26619cULL, 0xd186b8c721c0c207ULL,+ 0xeada7dd6cde0eb1eULL, 0xf57d4f7fee6ed178ULL,+ 0x06f067aa72176fbaULL, 0x0a637dc5a2c898a6ULL,+ 0x113f9804bef90daeULL, 0x1b710b35131c471bULL,+ 0x28db77f523047d84ULL, 0x32caab7b40c72493ULL,+ 0x3c9ebe0a15c9bebcULL, 0x431d67c49c100d4cULL,+ 0x4cc5d4becb3e42b6ULL, 0x597f299cfc657e2aULL,+ 0x5fcb6fab3ad6faecULL, 0x6c44198c4a475817ULL};++/* SHA-256 functions */++void sha256_transf(sha256_ctx *ctx, const unsigned char *message,+ unsigned int block_nb)+{+ uint32 w[64];+ uint32 wv[8];+ uint32 t1, t2;+ const unsigned char *sub_block;+ int i;++#ifndef UNROLL_LOOPS+ int j;+#endif++ for (i = 0; i < (int) block_nb; i++) {+ sub_block = message + (i << 6);++#ifndef UNROLL_LOOPS+ for (j = 0; j < 16; j++) {+ PACK32(&sub_block[j << 2], &w[j]);+ }++ for (j = 16; j < 64; j++) {+ SHA256_SCR(j);+ }++ for (j = 0; j < 8; j++) {+ wv[j] = ctx->h[j];+ }++ for (j = 0; j < 64; j++) {+ t1 = wv[7] + SHA256_F2(wv[4]) + CH(wv[4], wv[5], wv[6])+ + sha256_k[j] + w[j];+ t2 = SHA256_F1(wv[0]) + MAJ(wv[0], wv[1], wv[2]);+ wv[7] = wv[6];+ wv[6] = wv[5];+ wv[5] = wv[4];+ wv[4] = wv[3] + t1;+ wv[3] = wv[2];+ wv[2] = wv[1];+ wv[1] = wv[0];+ wv[0] = t1 + t2;+ }++ for (j = 0; j < 8; j++) {+ ctx->h[j] += wv[j];+ }+#else+ PACK32(&sub_block[ 0], &w[ 0]); PACK32(&sub_block[ 4], &w[ 1]);+ PACK32(&sub_block[ 8], &w[ 2]); PACK32(&sub_block[12], &w[ 3]);+ PACK32(&sub_block[16], &w[ 4]); PACK32(&sub_block[20], &w[ 5]);+ PACK32(&sub_block[24], &w[ 6]); PACK32(&sub_block[28], &w[ 7]);+ PACK32(&sub_block[32], &w[ 8]); PACK32(&sub_block[36], &w[ 9]);+ PACK32(&sub_block[40], &w[10]); PACK32(&sub_block[44], &w[11]);+ PACK32(&sub_block[48], &w[12]); PACK32(&sub_block[52], &w[13]);+ PACK32(&sub_block[56], &w[14]); PACK32(&sub_block[60], &w[15]);++ SHA256_SCR(16); SHA256_SCR(17); SHA256_SCR(18); SHA256_SCR(19);+ SHA256_SCR(20); SHA256_SCR(21); SHA256_SCR(22); SHA256_SCR(23);+ SHA256_SCR(24); SHA256_SCR(25); SHA256_SCR(26); SHA256_SCR(27);+ SHA256_SCR(28); SHA256_SCR(29); SHA256_SCR(30); SHA256_SCR(31);+ SHA256_SCR(32); SHA256_SCR(33); SHA256_SCR(34); SHA256_SCR(35);+ SHA256_SCR(36); SHA256_SCR(37); SHA256_SCR(38); SHA256_SCR(39);+ SHA256_SCR(40); SHA256_SCR(41); SHA256_SCR(42); SHA256_SCR(43);+ SHA256_SCR(44); SHA256_SCR(45); SHA256_SCR(46); SHA256_SCR(47);+ SHA256_SCR(48); SHA256_SCR(49); SHA256_SCR(50); SHA256_SCR(51);+ SHA256_SCR(52); SHA256_SCR(53); SHA256_SCR(54); SHA256_SCR(55);+ SHA256_SCR(56); SHA256_SCR(57); SHA256_SCR(58); SHA256_SCR(59);+ SHA256_SCR(60); SHA256_SCR(61); SHA256_SCR(62); SHA256_SCR(63);++ wv[0] = ctx->h[0]; wv[1] = ctx->h[1];+ wv[2] = ctx->h[2]; wv[3] = ctx->h[3];+ wv[4] = ctx->h[4]; wv[5] = ctx->h[5];+ wv[6] = ctx->h[6]; wv[7] = ctx->h[7];++ SHA256_EXP(0,1,2,3,4,5,6,7, 0); SHA256_EXP(7,0,1,2,3,4,5,6, 1);+ SHA256_EXP(6,7,0,1,2,3,4,5, 2); SHA256_EXP(5,6,7,0,1,2,3,4, 3);+ SHA256_EXP(4,5,6,7,0,1,2,3, 4); SHA256_EXP(3,4,5,6,7,0,1,2, 5);+ SHA256_EXP(2,3,4,5,6,7,0,1, 6); SHA256_EXP(1,2,3,4,5,6,7,0, 7);+ SHA256_EXP(0,1,2,3,4,5,6,7, 8); SHA256_EXP(7,0,1,2,3,4,5,6, 9);+ SHA256_EXP(6,7,0,1,2,3,4,5,10); SHA256_EXP(5,6,7,0,1,2,3,4,11);+ SHA256_EXP(4,5,6,7,0,1,2,3,12); SHA256_EXP(3,4,5,6,7,0,1,2,13);+ SHA256_EXP(2,3,4,5,6,7,0,1,14); SHA256_EXP(1,2,3,4,5,6,7,0,15);+ SHA256_EXP(0,1,2,3,4,5,6,7,16); SHA256_EXP(7,0,1,2,3,4,5,6,17);+ SHA256_EXP(6,7,0,1,2,3,4,5,18); SHA256_EXP(5,6,7,0,1,2,3,4,19);+ SHA256_EXP(4,5,6,7,0,1,2,3,20); SHA256_EXP(3,4,5,6,7,0,1,2,21);+ SHA256_EXP(2,3,4,5,6,7,0,1,22); SHA256_EXP(1,2,3,4,5,6,7,0,23);+ SHA256_EXP(0,1,2,3,4,5,6,7,24); SHA256_EXP(7,0,1,2,3,4,5,6,25);+ SHA256_EXP(6,7,0,1,2,3,4,5,26); SHA256_EXP(5,6,7,0,1,2,3,4,27);+ SHA256_EXP(4,5,6,7,0,1,2,3,28); SHA256_EXP(3,4,5,6,7,0,1,2,29);+ SHA256_EXP(2,3,4,5,6,7,0,1,30); SHA256_EXP(1,2,3,4,5,6,7,0,31);+ SHA256_EXP(0,1,2,3,4,5,6,7,32); SHA256_EXP(7,0,1,2,3,4,5,6,33);+ SHA256_EXP(6,7,0,1,2,3,4,5,34); SHA256_EXP(5,6,7,0,1,2,3,4,35);+ SHA256_EXP(4,5,6,7,0,1,2,3,36); SHA256_EXP(3,4,5,6,7,0,1,2,37);+ SHA256_EXP(2,3,4,5,6,7,0,1,38); SHA256_EXP(1,2,3,4,5,6,7,0,39);+ SHA256_EXP(0,1,2,3,4,5,6,7,40); SHA256_EXP(7,0,1,2,3,4,5,6,41);+ SHA256_EXP(6,7,0,1,2,3,4,5,42); SHA256_EXP(5,6,7,0,1,2,3,4,43);+ SHA256_EXP(4,5,6,7,0,1,2,3,44); SHA256_EXP(3,4,5,6,7,0,1,2,45);+ SHA256_EXP(2,3,4,5,6,7,0,1,46); SHA256_EXP(1,2,3,4,5,6,7,0,47);+ SHA256_EXP(0,1,2,3,4,5,6,7,48); SHA256_EXP(7,0,1,2,3,4,5,6,49);+ SHA256_EXP(6,7,0,1,2,3,4,5,50); SHA256_EXP(5,6,7,0,1,2,3,4,51);+ SHA256_EXP(4,5,6,7,0,1,2,3,52); SHA256_EXP(3,4,5,6,7,0,1,2,53);+ SHA256_EXP(2,3,4,5,6,7,0,1,54); SHA256_EXP(1,2,3,4,5,6,7,0,55);+ SHA256_EXP(0,1,2,3,4,5,6,7,56); SHA256_EXP(7,0,1,2,3,4,5,6,57);+ SHA256_EXP(6,7,0,1,2,3,4,5,58); SHA256_EXP(5,6,7,0,1,2,3,4,59);+ SHA256_EXP(4,5,6,7,0,1,2,3,60); SHA256_EXP(3,4,5,6,7,0,1,2,61);+ SHA256_EXP(2,3,4,5,6,7,0,1,62); SHA256_EXP(1,2,3,4,5,6,7,0,63);++ ctx->h[0] += wv[0]; ctx->h[1] += wv[1];+ ctx->h[2] += wv[2]; ctx->h[3] += wv[3];+ ctx->h[4] += wv[4]; ctx->h[5] += wv[5];+ ctx->h[6] += wv[6]; ctx->h[7] += wv[7];+#endif /* !UNROLL_LOOPS */+ }+}++void sha256(const unsigned char *message, unsigned int len, unsigned char *digest)+{+ sha256_ctx ctx;++ sha256_init(&ctx);+ sha256_update(&ctx, message, len);+ sha256_final(&ctx, digest);+}++void sha256_init(sha256_ctx *ctx)+{+#ifndef UNROLL_LOOPS+ int i;+ for (i = 0; i < 8; i++) {+ ctx->h[i] = sha256_h0[i];+ }+#else+ ctx->h[0] = sha256_h0[0]; ctx->h[1] = sha256_h0[1];+ ctx->h[2] = sha256_h0[2]; ctx->h[3] = sha256_h0[3];+ ctx->h[4] = sha256_h0[4]; ctx->h[5] = sha256_h0[5];+ ctx->h[6] = sha256_h0[6]; ctx->h[7] = sha256_h0[7];+#endif /* !UNROLL_LOOPS */++ ctx->len = 0;+ ctx->tot_len = 0;+}++void sha256_update(sha256_ctx *ctx, const unsigned char *message,+ unsigned int len)+{+ unsigned int block_nb;+ unsigned int new_len, rem_len, tmp_len;+ const unsigned char *shifted_message;++ tmp_len = SHA256_BLOCK_SIZE - ctx->len;+ rem_len = len < tmp_len ? len : tmp_len;++ memcpy(&ctx->block[ctx->len], message, rem_len);++ if (ctx->len + len < SHA256_BLOCK_SIZE) {+ ctx->len += len;+ return;+ }++ new_len = len - rem_len;+ block_nb = new_len / SHA256_BLOCK_SIZE;++ shifted_message = message + rem_len;++ sha256_transf(ctx, ctx->block, 1);+ sha256_transf(ctx, shifted_message, block_nb);++ rem_len = new_len % SHA256_BLOCK_SIZE;++ memcpy(ctx->block, &shifted_message[block_nb << 6],+ rem_len);++ ctx->len = rem_len;+ ctx->tot_len += (block_nb + 1) << 6;+}++void sha256_final(sha256_ctx *ctx, unsigned char *digest)+{+ unsigned int block_nb;+ unsigned int pm_len;+ unsigned int len_b;++#ifndef UNROLL_LOOPS+ int i;+#endif++ block_nb = (1 + ((SHA256_BLOCK_SIZE - 9)+ < (ctx->len % SHA256_BLOCK_SIZE)));++ len_b = (ctx->tot_len + ctx->len) << 3;+ pm_len = block_nb << 6;++ memset(ctx->block + ctx->len, 0, pm_len - ctx->len);+ ctx->block[ctx->len] = 0x80;+ UNPACK32(len_b, ctx->block + pm_len - 4);++ sha256_transf(ctx, ctx->block, block_nb);++#ifndef UNROLL_LOOPS+ for (i = 0 ; i < 8; i++) {+ UNPACK32(ctx->h[i], &digest[i << 2]);+ }+#else+ UNPACK32(ctx->h[0], &digest[ 0]);+ UNPACK32(ctx->h[1], &digest[ 4]);+ UNPACK32(ctx->h[2], &digest[ 8]);+ UNPACK32(ctx->h[3], &digest[12]);+ UNPACK32(ctx->h[4], &digest[16]);+ UNPACK32(ctx->h[5], &digest[20]);+ UNPACK32(ctx->h[6], &digest[24]);+ UNPACK32(ctx->h[7], &digest[28]);+#endif /* !UNROLL_LOOPS */+}++/* SHA-512 functions */++void sha512_transf(sha512_ctx *ctx, const unsigned char *message,+ unsigned int block_nb)+{+ uint64 w[80];+ uint64 wv[8];+ uint64 t1, t2;+ const unsigned char *sub_block;+ int i, j;++ for (i = 0; i < (int) block_nb; i++) {+ sub_block = message + (i << 7);++#ifndef UNROLL_LOOPS+ for (j = 0; j < 16; j++) {+ PACK64(&sub_block[j << 3], &w[j]);+ }++ for (j = 16; j < 80; j++) {+ SHA512_SCR(j);+ }++ for (j = 0; j < 8; j++) {+ wv[j] = ctx->h[j];+ }++ for (j = 0; j < 80; j++) {+ t1 = wv[7] + SHA512_F2(wv[4]) + CH(wv[4], wv[5], wv[6])+ + sha512_k[j] + w[j];+ t2 = SHA512_F1(wv[0]) + MAJ(wv[0], wv[1], wv[2]);+ wv[7] = wv[6];+ wv[6] = wv[5];+ wv[5] = wv[4];+ wv[4] = wv[3] + t1;+ wv[3] = wv[2];+ wv[2] = wv[1];+ wv[1] = wv[0];+ wv[0] = t1 + t2;+ }++ for (j = 0; j < 8; j++) {+ ctx->h[j] += wv[j];+ }+#else+ PACK64(&sub_block[ 0], &w[ 0]); PACK64(&sub_block[ 8], &w[ 1]);+ PACK64(&sub_block[ 16], &w[ 2]); PACK64(&sub_block[ 24], &w[ 3]);+ PACK64(&sub_block[ 32], &w[ 4]); PACK64(&sub_block[ 40], &w[ 5]);+ PACK64(&sub_block[ 48], &w[ 6]); PACK64(&sub_block[ 56], &w[ 7]);+ PACK64(&sub_block[ 64], &w[ 8]); PACK64(&sub_block[ 72], &w[ 9]);+ PACK64(&sub_block[ 80], &w[10]); PACK64(&sub_block[ 88], &w[11]);+ PACK64(&sub_block[ 96], &w[12]); PACK64(&sub_block[104], &w[13]);+ PACK64(&sub_block[112], &w[14]); PACK64(&sub_block[120], &w[15]);++ SHA512_SCR(16); SHA512_SCR(17); SHA512_SCR(18); SHA512_SCR(19);+ SHA512_SCR(20); SHA512_SCR(21); SHA512_SCR(22); SHA512_SCR(23);+ SHA512_SCR(24); SHA512_SCR(25); SHA512_SCR(26); SHA512_SCR(27);+ SHA512_SCR(28); SHA512_SCR(29); SHA512_SCR(30); SHA512_SCR(31);+ SHA512_SCR(32); SHA512_SCR(33); SHA512_SCR(34); SHA512_SCR(35);+ SHA512_SCR(36); SHA512_SCR(37); SHA512_SCR(38); SHA512_SCR(39);+ SHA512_SCR(40); SHA512_SCR(41); SHA512_SCR(42); SHA512_SCR(43);+ SHA512_SCR(44); SHA512_SCR(45); SHA512_SCR(46); SHA512_SCR(47);+ SHA512_SCR(48); SHA512_SCR(49); SHA512_SCR(50); SHA512_SCR(51);+ SHA512_SCR(52); SHA512_SCR(53); SHA512_SCR(54); SHA512_SCR(55);+ SHA512_SCR(56); SHA512_SCR(57); SHA512_SCR(58); SHA512_SCR(59);+ SHA512_SCR(60); SHA512_SCR(61); SHA512_SCR(62); SHA512_SCR(63);+ SHA512_SCR(64); SHA512_SCR(65); SHA512_SCR(66); SHA512_SCR(67);+ SHA512_SCR(68); SHA512_SCR(69); SHA512_SCR(70); SHA512_SCR(71);+ SHA512_SCR(72); SHA512_SCR(73); SHA512_SCR(74); SHA512_SCR(75);+ SHA512_SCR(76); SHA512_SCR(77); SHA512_SCR(78); SHA512_SCR(79);++ wv[0] = ctx->h[0]; wv[1] = ctx->h[1];+ wv[2] = ctx->h[2]; wv[3] = ctx->h[3];+ wv[4] = ctx->h[4]; wv[5] = ctx->h[5];+ wv[6] = ctx->h[6]; wv[7] = ctx->h[7];++ j = 0;++ do {+ SHA512_EXP(0,1,2,3,4,5,6,7,j); j++;+ SHA512_EXP(7,0,1,2,3,4,5,6,j); j++;+ SHA512_EXP(6,7,0,1,2,3,4,5,j); j++;+ SHA512_EXP(5,6,7,0,1,2,3,4,j); j++;+ SHA512_EXP(4,5,6,7,0,1,2,3,j); j++;+ SHA512_EXP(3,4,5,6,7,0,1,2,j); j++;+ SHA512_EXP(2,3,4,5,6,7,0,1,j); j++;+ SHA512_EXP(1,2,3,4,5,6,7,0,j); j++;+ } while (j < 80);++ ctx->h[0] += wv[0]; ctx->h[1] += wv[1];+ ctx->h[2] += wv[2]; ctx->h[3] += wv[3];+ ctx->h[4] += wv[4]; ctx->h[5] += wv[5];+ ctx->h[6] += wv[6]; ctx->h[7] += wv[7];+#endif /* !UNROLL_LOOPS */+ }+}++void sha512(const unsigned char *message, unsigned int len,+ unsigned char *digest)+{+ sha512_ctx ctx;++ sha512_init(&ctx);+ sha512_update(&ctx, message, len);+ sha512_final(&ctx, digest);+}++void sha512_init(sha512_ctx *ctx)+{+#ifndef UNROLL_LOOPS+ int i;+ for (i = 0; i < 8; i++) {+ ctx->h[i] = sha512_h0[i];+ }+#else+ ctx->h[0] = sha512_h0[0]; ctx->h[1] = sha512_h0[1];+ ctx->h[2] = sha512_h0[2]; ctx->h[3] = sha512_h0[3];+ ctx->h[4] = sha512_h0[4]; ctx->h[5] = sha512_h0[5];+ ctx->h[6] = sha512_h0[6]; ctx->h[7] = sha512_h0[7];+#endif /* !UNROLL_LOOPS */++ ctx->len = 0;+ ctx->tot_len = 0;+}++void sha512_update(sha512_ctx *ctx, const unsigned char *message,+ unsigned int len)+{+ unsigned int block_nb;+ unsigned int new_len, rem_len, tmp_len;+ const unsigned char *shifted_message;++ tmp_len = SHA512_BLOCK_SIZE - ctx->len;+ rem_len = len < tmp_len ? len : tmp_len;++ memcpy(&ctx->block[ctx->len], message, rem_len);++ if (ctx->len + len < SHA512_BLOCK_SIZE) {+ ctx->len += len;+ return;+ }++ new_len = len - rem_len;+ block_nb = new_len / SHA512_BLOCK_SIZE;++ shifted_message = message + rem_len;++ sha512_transf(ctx, ctx->block, 1);+ sha512_transf(ctx, shifted_message, block_nb);++ rem_len = new_len % SHA512_BLOCK_SIZE;++ memcpy(ctx->block, &shifted_message[block_nb << 7],+ rem_len);++ ctx->len = rem_len;+ ctx->tot_len += (block_nb + 1) << 7;+}++void sha512_final(sha512_ctx *ctx, unsigned char *digest)+{+ unsigned int block_nb;+ unsigned int pm_len;+ unsigned int len_b;++#ifndef UNROLL_LOOPS+ int i;+#endif++ block_nb = 1 + ((SHA512_BLOCK_SIZE - 17)+ < (ctx->len % SHA512_BLOCK_SIZE));++ len_b = (ctx->tot_len + ctx->len) << 3;+ pm_len = block_nb << 7;++ memset(ctx->block + ctx->len, 0, pm_len - ctx->len);+ ctx->block[ctx->len] = 0x80;+ UNPACK32(len_b, ctx->block + pm_len - 4);++ sha512_transf(ctx, ctx->block, block_nb);++#ifndef UNROLL_LOOPS+ for (i = 0 ; i < 8; i++) {+ UNPACK64(ctx->h[i], &digest[i << 3]);+ }+#else+ UNPACK64(ctx->h[0], &digest[ 0]);+ UNPACK64(ctx->h[1], &digest[ 8]);+ UNPACK64(ctx->h[2], &digest[16]);+ UNPACK64(ctx->h[3], &digest[24]);+ UNPACK64(ctx->h[4], &digest[32]);+ UNPACK64(ctx->h[5], &digest[40]);+ UNPACK64(ctx->h[6], &digest[48]);+ UNPACK64(ctx->h[7], &digest[56]);+#endif /* !UNROLL_LOOPS */+}++/* SHA-384 functions */++void sha384(const unsigned char *message, unsigned int len,+ unsigned char *digest)+{+ sha384_ctx ctx;++ sha384_init(&ctx);+ sha384_update(&ctx, message, len);+ sha384_final(&ctx, digest);+}++void sha384_init(sha384_ctx *ctx)+{+#ifndef UNROLL_LOOPS+ int i;+ for (i = 0; i < 8; i++) {+ ctx->h[i] = sha384_h0[i];+ }+#else+ ctx->h[0] = sha384_h0[0]; ctx->h[1] = sha384_h0[1];+ ctx->h[2] = sha384_h0[2]; ctx->h[3] = sha384_h0[3];+ ctx->h[4] = sha384_h0[4]; ctx->h[5] = sha384_h0[5];+ ctx->h[6] = sha384_h0[6]; ctx->h[7] = sha384_h0[7];+#endif /* !UNROLL_LOOPS */++ ctx->len = 0;+ ctx->tot_len = 0;+}++void sha384_update(sha384_ctx *ctx, const unsigned char *message,+ unsigned int len)+{+ unsigned int block_nb;+ unsigned int new_len, rem_len, tmp_len;+ const unsigned char *shifted_message;++ tmp_len = SHA384_BLOCK_SIZE - ctx->len;+ rem_len = len < tmp_len ? len : tmp_len;++ memcpy(&ctx->block[ctx->len], message, rem_len);++ if (ctx->len + len < SHA384_BLOCK_SIZE) {+ ctx->len += len;+ return;+ }++ new_len = len - rem_len;+ block_nb = new_len / SHA384_BLOCK_SIZE;++ shifted_message = message + rem_len;++ sha512_transf(ctx, ctx->block, 1);+ sha512_transf(ctx, shifted_message, block_nb);++ rem_len = new_len % SHA384_BLOCK_SIZE;++ memcpy(ctx->block, &shifted_message[block_nb << 7],+ rem_len);++ ctx->len = rem_len;+ ctx->tot_len += (block_nb + 1) << 7;+}++void sha384_final(sha384_ctx *ctx, unsigned char *digest)+{+ unsigned int block_nb;+ unsigned int pm_len;+ unsigned int len_b;++#ifndef UNROLL_LOOPS+ int i;+#endif++ block_nb = (1 + ((SHA384_BLOCK_SIZE - 17)+ < (ctx->len % SHA384_BLOCK_SIZE)));++ len_b = (ctx->tot_len + ctx->len) << 3;+ pm_len = block_nb << 7;++ memset(ctx->block + ctx->len, 0, pm_len - ctx->len);+ ctx->block[ctx->len] = 0x80;+ UNPACK32(len_b, ctx->block + pm_len - 4);++ sha512_transf(ctx, ctx->block, block_nb);++#ifndef UNROLL_LOOPS+ for (i = 0 ; i < 6; i++) {+ UNPACK64(ctx->h[i], &digest[i << 3]);+ }+#else+ UNPACK64(ctx->h[0], &digest[ 0]);+ UNPACK64(ctx->h[1], &digest[ 8]);+ UNPACK64(ctx->h[2], &digest[16]);+ UNPACK64(ctx->h[3], &digest[24]);+ UNPACK64(ctx->h[4], &digest[32]);+ UNPACK64(ctx->h[5], &digest[40]);+#endif /* !UNROLL_LOOPS */+}++/* SHA-224 functions */++void sha224(const unsigned char *message, unsigned int len,+ unsigned char *digest)+{+ sha224_ctx ctx;++ sha224_init(&ctx);+ sha224_update(&ctx, message, len);+ sha224_final(&ctx, digest);+}++void sha224_init(sha224_ctx *ctx)+{+#ifndef UNROLL_LOOPS+ int i;+ for (i = 0; i < 8; i++) {+ ctx->h[i] = sha224_h0[i];+ }+#else+ ctx->h[0] = sha224_h0[0]; ctx->h[1] = sha224_h0[1];+ ctx->h[2] = sha224_h0[2]; ctx->h[3] = sha224_h0[3];+ ctx->h[4] = sha224_h0[4]; ctx->h[5] = sha224_h0[5];+ ctx->h[6] = sha224_h0[6]; ctx->h[7] = sha224_h0[7];+#endif /* !UNROLL_LOOPS */++ ctx->len = 0;+ ctx->tot_len = 0;+}++void sha224_update(sha224_ctx *ctx, const unsigned char *message,+ unsigned int len)+{+ unsigned int block_nb;+ unsigned int new_len, rem_len, tmp_len;+ const unsigned char *shifted_message;++ tmp_len = SHA224_BLOCK_SIZE - ctx->len;+ rem_len = len < tmp_len ? len : tmp_len;++ memcpy(&ctx->block[ctx->len], message, rem_len);++ if (ctx->len + len < SHA224_BLOCK_SIZE) {+ ctx->len += len;+ return;+ }++ new_len = len - rem_len;+ block_nb = new_len / SHA224_BLOCK_SIZE;++ shifted_message = message + rem_len;++ sha256_transf(ctx, ctx->block, 1);+ sha256_transf(ctx, shifted_message, block_nb);++ rem_len = new_len % SHA224_BLOCK_SIZE;++ memcpy(ctx->block, &shifted_message[block_nb << 6],+ rem_len);++ ctx->len = rem_len;+ ctx->tot_len += (block_nb + 1) << 6;+}++void sha224_final(sha224_ctx *ctx, unsigned char *digest)+{+ unsigned int block_nb;+ unsigned int pm_len;+ unsigned int len_b;++#ifndef UNROLL_LOOPS+ int i;+#endif++ block_nb = (1 + ((SHA224_BLOCK_SIZE - 9)+ < (ctx->len % SHA224_BLOCK_SIZE)));++ len_b = (ctx->tot_len + ctx->len) << 3;+ pm_len = block_nb << 6;++ memset(ctx->block + ctx->len, 0, pm_len - ctx->len);+ ctx->block[ctx->len] = 0x80;+ UNPACK32(len_b, ctx->block + pm_len - 4);++ sha256_transf(ctx, ctx->block, block_nb);++#ifndef UNROLL_LOOPS+ for (i = 0 ; i < 7; i++) {+ UNPACK32(ctx->h[i], &digest[i << 2]);+ }+#else+ UNPACK32(ctx->h[0], &digest[ 0]);+ UNPACK32(ctx->h[1], &digest[ 4]);+ UNPACK32(ctx->h[2], &digest[ 8]);+ UNPACK32(ctx->h[3], &digest[12]);+ UNPACK32(ctx->h[4], &digest[16]);+ UNPACK32(ctx->h[5], &digest[20]);+ UNPACK32(ctx->h[6], &digest[24]);+#endif /* !UNROLL_LOOPS */+}++#ifdef TEST_VECTORS++/* FIPS 180-2 Validation tests */++#include <stdio.h>+#include <stdlib.h>++void test(const unsigned char *vector, unsigned char *digest,+ unsigned int digest_size)+{+ unsigned char output[2 * SHA512_DIGEST_SIZE + 1];+ int i;++ output[2 * digest_size] = '\0';++ for (i = 0; i < (int) digest_size ; i++) {+ sprintf((char *) output + 2 * i, "%02x", digest[i]);+ }++ printf("H: %s\n", output);+ if (strcmp((char *) vector, (char *) output)) {+ fprintf(stderr, "Test failed.\n");+ exit(EXIT_FAILURE);+ }+}++int main()+{+ static const unsigned char *vectors[4][3] =+ { /* SHA-224 */+ {+ "23097d223405d8228642a477bda255b32aadbce4bda0b3f7e36c9da7",+ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525",+ "20794655980c91d8bbb4c1ea97618a4bf03f42581948b2ee4ee7ad67",+ },+ /* SHA-256 */+ {+ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad",+ "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1",+ "cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0",+ },+ /* SHA-384 */+ {+ "cb00753f45a35e8bb5a03d699ac65007272c32ab0eded1631a8b605a43ff5bed"+ "8086072ba1e7cc2358baeca134c825a7",+ "09330c33f71147e83d192fc782cd1b4753111b173b3b05d22fa08086e3b0f712"+ "fcc7c71a557e2db966c3e9fa91746039",+ "9d0e1809716474cb086e834e310a4a1ced149e9c00f248527972cec5704c2a5b"+ "07b8b3dc38ecc4ebae97ddd87f3d8985",+ },+ /* SHA-512 */+ {+ "ddaf35a193617abacc417349ae20413112e6fa4e89a97ea20a9eeee64b55d39a"+ "2192992a274fc1a836ba3c23a3feebbd454d4423643ce80e2a9ac94fa54ca49f",+ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018"+ "501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909",+ "e718483d0ce769644e2e42c7bc15b4638e1f98b13b2044285632a803afa973eb"+ "de0ff244877ea60a4cb0432ce577c31beb009c5c2c49aa2e4eadb217ad8cc09b"+ }+ };++ static const unsigned char message1[] = "abc";+ static const unsigned char message2a[] = "abcdbcdecdefdefgefghfghighijhi"+ "jkijkljklmklmnlmnomnopnopq";+ static const unsigned char message2b[] =+ "abcdefghbcdefghicdefghijdefghijkefghij"+ "klfghijklmghijklmnhijklmnoijklmnopjklm"+ "nopqklmnopqrlmnopqrsmnopqrstnopqrstu";+ unsigned char *message3;+ unsigned int message3_len = 1000000;+ unsigned char digest[SHA512_DIGEST_SIZE];++ message3 = malloc(message3_len);+ if (message3 == NULL) {+ fprintf(stderr, "Can't allocate memory\n");+ return -1;+ }+ memset(message3, 'a', message3_len);++ printf("SHA-2 FIPS 180-2 Validation tests\n\n");+ printf("SHA-224 Test vectors\n");++ sha224(message1, strlen((char *) message1), digest);+ test(vectors[0][0], digest, SHA224_DIGEST_SIZE);+ sha224(message2a, strlen((char *) message2a), digest);+ test(vectors[0][1], digest, SHA224_DIGEST_SIZE);+ sha224(message3, message3_len, digest);+ test(vectors[0][2], digest, SHA224_DIGEST_SIZE);+ printf("\n");++ printf("SHA-256 Test vectors\n");++ sha256(message1, strlen((char *) message1), digest);+ test(vectors[1][0], digest, SHA256_DIGEST_SIZE);+ sha256(message2a, strlen((char *) message2a), digest);+ test(vectors[1][1], digest, SHA256_DIGEST_SIZE);+ sha256(message3, message3_len, digest);+ test(vectors[1][2], digest, SHA256_DIGEST_SIZE);+ printf("\n");++ printf("SHA-384 Test vectors\n");++ sha384(message1, strlen((char *) message1), digest);+ test(vectors[2][0], digest, SHA384_DIGEST_SIZE);+ sha384(message2b, strlen((char *) message2b), digest);+ test(vectors[2][1], digest, SHA384_DIGEST_SIZE);+ sha384(message3, message3_len, digest);+ test(vectors[2][2], digest, SHA384_DIGEST_SIZE);+ printf("\n");++ printf("SHA-512 Test vectors\n");++ sha512(message1, strlen((char *) message1), digest);+ test(vectors[3][0], digest, SHA512_DIGEST_SIZE);+ sha512(message2b, strlen((char *) message2b), digest);+ test(vectors[3][1], digest, SHA512_DIGEST_SIZE);+ sha512(message3, message3_len, digest);+ test(vectors[3][2], digest, SHA512_DIGEST_SIZE);+ printf("\n");++ printf("All tests passed.\n");++ return 0;+}++#endif /* TEST_VECTORS */+
+ Bundled/sha2.h view
@@ -0,0 +1,108 @@+/*+ * FIPS 180-2 SHA-224/256/384/512 implementation+ * Last update: 02/02/2007+ * Issue date: 04/30/2005+ *+ * Copyright (C) 2005, 2007 Olivier Gay <olivier.gay@a3.epfl.ch>+ * All rights reserved.+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions+ * are met:+ * 1. Redistributions of source code must retain the above copyright+ * notice, this list of conditions and the following disclaimer.+ * 2. Redistributions in binary form must reproduce the above copyright+ * notice, this list of conditions and the following disclaimer in the+ * documentation and/or other materials provided with the distribution.+ * 3. Neither the name of the project nor the names of its contributors+ * may be used to endorse or promote products derived from this software+ * without specific prior written permission.+ *+ * THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``AS IS'' AND+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ * ARE DISCLAIMED. IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE LIABLE+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+ * SUCH DAMAGE.+ */++#ifndef SHA2_H+#define SHA2_H++#define SHA224_DIGEST_SIZE ( 224 / 8)+#define SHA256_DIGEST_SIZE ( 256 / 8)+#define SHA384_DIGEST_SIZE ( 384 / 8)+#define SHA512_DIGEST_SIZE ( 512 / 8)++#define SHA256_BLOCK_SIZE ( 512 / 8)+#define SHA512_BLOCK_SIZE (1024 / 8)+#define SHA384_BLOCK_SIZE SHA512_BLOCK_SIZE+#define SHA224_BLOCK_SIZE SHA256_BLOCK_SIZE++#ifndef SHA2_TYPES+#define SHA2_TYPES+typedef unsigned char uint8;+typedef unsigned int uint32;+typedef unsigned long long uint64;+#endif++#ifdef __cplusplus+extern "C" {+#endif++typedef struct {+ unsigned int tot_len;+ unsigned int len;+ unsigned char block[2 * SHA256_BLOCK_SIZE];+ uint32 h[8];+} sha256_ctx;++typedef struct {+ unsigned int tot_len;+ unsigned int len;+ unsigned char block[2 * SHA512_BLOCK_SIZE];+ uint64 h[8];+} sha512_ctx;++typedef sha512_ctx sha384_ctx;+typedef sha256_ctx sha224_ctx;++void sha224_init(sha224_ctx *ctx);+void sha224_update(sha224_ctx *ctx, const unsigned char *message,+ unsigned int len);+void sha224_final(sha224_ctx *ctx, unsigned char *digest);+void sha224(const unsigned char *message, unsigned int len,+ unsigned char *digest);++void sha256_init(sha256_ctx * ctx);+void sha256_update(sha256_ctx *ctx, const unsigned char *message,+ unsigned int len);+void sha256_final(sha256_ctx *ctx, unsigned char *digest);+void sha256(const unsigned char *message, unsigned int len,+ unsigned char *digest);++void sha384_init(sha384_ctx *ctx);+void sha384_update(sha384_ctx *ctx, const unsigned char *message,+ unsigned int len);+void sha384_final(sha384_ctx *ctx, unsigned char *digest);+void sha384(const unsigned char *message, unsigned int len,+ unsigned char *digest);++void sha512_init(sha512_ctx *ctx);+void sha512_update(sha512_ctx *ctx, const unsigned char *message,+ unsigned int len);+void sha512_final(sha512_ctx *ctx, unsigned char *digest);+void sha512(const unsigned char *message, unsigned int len,+ unsigned char *digest);++#ifdef __cplusplus+}+#endif++#endif /* !SHA2_H */+
+ Setup.hs view
@@ -0,0 +1,12 @@+import Distribution.Simple+ ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.LocalBuildInfo( LocalBuildInfo(..) )+import System( system )+import System.FilePath( (</>) )++main = defaultMainWithHooks simpleUserHooks {+ runTests = \ _ _ pkg lbi -> do+ system $ buildDir lbi </> hst </> hst+ return ()+}+ where hst = "hashed-storage-test"
+ Storage/Hashed.hs view
@@ -0,0 +1,167 @@+module Storage.Hashed+ ( -- * Obtaining Trees.+ --+ -- | Please note that Trees obtained this way will contain Stub+ -- items. These need to be executed (they are IO actions) in order to be+ -- accessed. Use 'unfold' to do this. However, many operations are+ -- perfectly fine to be used on a stubbed Tree (and it is often more+ -- efficient to do everything that can be done before unfolding a Tree).+ readPlainTree, readDarcsHashed, readDarcsPristine++ -- * Blob access.+ , read, readSegment++ -- * Writing trees.+ , writePlainTree++ -- * Unsafe functions for the curious explorer.+ --+ -- | These are more useful for playing within ghci than for real, serious+ -- programs. They generally trade safety for conciseness. Please use+ -- responsibly. Don't kill innocent kittens.+ , floatPath, printPath ) where++import Prelude hiding ( catch, read, lines )+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as BL+import Storage.Hashed.AnchoredPath+import Storage.Hashed.Utils+import Storage.Hashed.Tree( Tree( listImmediate ), TreeItem(..), ItemType(..)+ , Blob(..), emptyTree, makeTree, makeTreeWithHash+ , list, read, find )+import System.FilePath( (</>), splitDirectories, normalise+ , dropTrailingPathSeparator )+import System.Directory( getDirectoryContents, doesFileExist+ , doesDirectoryExist, createDirectoryIfMissing )+import Codec.Compression.GZip( decompress )+import Control.Monad( forM_, unless )+import Bundled.Posix( getFileStatus, isDirectory, FileStatus )++------------------------+-- For explorers+--++-- | Take a relative FilePath and turn it into an AnchoredPath. The operation+-- is unsafe and if you break it, you keep both pieces. More useful for+-- exploratory purposes (ghci) than for serious programming.+floatPath :: FilePath -> AnchoredPath+floatPath = AnchoredPath . map (Name . BS.pack)+ . splitDirectories+ . normalise . dropTrailingPathSeparator++-- | Take a relative FilePath within a Tree and print the contents of the+-- object there. Useful for exploration, less so for serious programming.+printPath :: Tree -> FilePath -> IO ()+printPath t p = print' $ find t (floatPath p)+ where print' Nothing = putStrLn $ "ERROR: No object at " ++ p+ print' (Just (File b)) = do+ putStrLn $ "== Contents of file " ++ p ++ ":"+ BL.unpack `fmap` read b >>= putStr+ print' (Just (SubTree t')) = do+ putStrLn $ "== Listing Tree " ++ p ++ " (immediates only):"+ putStr $ unlines $ map BS.unpack $ listNames t'+ print' (Just (Stub _ _)) = do+ putStrLn $ "== (not listing stub at " ++ p ++ ")"+ listNames t' = [ n | (Name n, _) <- listImmediate t' ]++readPlainDir :: FilePath -> IO [(FilePath, FileStatus)]+readPlainDir dir =+ do withCurrentDirectory dir $ do+ items <- getDirectoryContents "."+ sequence [ do st <- getFileStatus s+ return (s, st)+ | s <- items, not $ s `elem` [ ".", ".." ] ]++-- | Read in a plain directory hierarchy from a filesystem. NB. The 'read'+-- function on Blobs with such a Tree is susceptible to file content+-- changes. Since we use mmap in 'read', this will break referential+-- transparency and produce unexpected results. Please always make sure that+-- all parallel access to the underlying filesystem tree never mutates+-- files. Unlink + recreate is fine though (in other words, the sync/write+-- operations below are safe).+readPlainTree :: FilePath -> IO Tree+readPlainTree dir = do+ items <- readPlainDir dir+ let subs = [+ let name = nameFromFilePath name'+ in if isDirectory status+ then (name,+ Stub (readPlainTree (dir </> name')) Nothing)+ else (name, File $+ Blob (readBlob name) Nothing)+ | (name', status) <- items ]+ return $ makeTree subs+ where readBlob (Name name) = readSegment (dir </> BS.unpack name, Nothing)++-- | Read and parse a darcs-style hashed directory listing from a given @dir@+-- and with a given @hash@.+readDarcsHashedDir :: FilePath -> Hash -> IO [(ItemType, Name, Hash)]+readDarcsHashedDir dir h = do+ compressed <- BL.readFile (dir </> BS.unpack (darcsFormatHash h))+ let content = decompress compressed+ lines = BL.split '\n' content+ return $ if BL.null compressed+ then []+ else parse lines+ where+ parse (t:n:h':r) = (parse' t,+ Name $ BS.pack $ darcsDecodeWhite (BL.unpack n),+ makeHash hash) : parse r+ where hash = BS.concat $ BL.toChunks $ h'+ parse _ = []+ parse' x+ | x == BL.pack "file:" = BlobType+ | x == BL.pack "directory:" = TreeType+ | otherwise = error $ "Error parsing darcs hashed dir: " ++ BL.unpack x++-- | Read in a darcs-style hashed tree. This is mainly useful for reading+-- \"pristine.hashed\". You need to provide the root hash you are interested in+-- (found in _darcs/hashed_inventory).+readDarcsHashed :: FilePath -> Hash -> IO Tree+readDarcsHashed dir root = do+ items <- readDarcsHashedDir dir root+ subs <- sequence [+ do case tp of+ BlobType -> return (d, File $+ Blob (readBlob h) (Just h))+ TreeType ->+ do let t = readDarcsHashed dir h+ return (d, Stub t (Just h))+ | (tp, d, h) <- items ]+ return $ makeTreeWithHash subs root+ where location h = (dir </> BS.unpack (darcsFormatHash h), Nothing)+ readBlob name = fmap decompress $ readSegment $ location name++-- | Read in a darcs pristine tree. Handles the plain and hashed pristine+-- cases. Does not (and will not) handle the no-pristine case, since that+-- requires replaying patches. Cf. 'readDarcsHashed' and 'readPlainTree' that+-- are used to do the actual 'Tree' construction.+readDarcsPristine :: FilePath -> IO Tree+readDarcsPristine dir = do+ let darcs = dir </> "_darcs"+ h_inventory = darcs </> "hashed_inventory"+ repo <- doesDirectoryExist darcs+ unless repo $ fail $ "Not a darcs repository: " ++ dir+ hashed <- doesFileExist h_inventory+ if hashed+ then do inv <- BS.readFile h_inventory+ let lines = BS.split '\n' inv+ case lines of+ [] -> return emptyTree+ (pris_line:_) ->+ let hash = makeHash $ BS.drop 9 pris_line+ in readDarcsHashed (darcs </> "pristine.hashed") hash+ else readPlainTree $ darcs </> "pristine"++-- | Write out *full* tree to a plain directory structure. If you instead want+-- to make incremental updates, refer to "Monad.plainTreeIO".+writePlainTree :: Tree -> FilePath -> IO ()+writePlainTree t dir = do+ createDirectoryIfMissing True dir+ forM_ (list t) write+ where write (p, File b) = write' p b+ write (p, SubTree _) =+ createDirectoryIfMissing True (anchorPath dir p)+ write _ = return ()+ write' p b = read b >>= BL.writeFile (anchorPath dir p)+
+ Storage/Hashed/AnchoredPath.hs view
@@ -0,0 +1,62 @@+module Storage.Hashed.AnchoredPath+ ( Name(..), AnchoredPath(..), appendPath, anchorPath+ , isPrefix, parent, parents, catPaths+ -- * Unsafe functions.+ , nameToFilePath, nameFromFilePath+ , floatBS, anchorBS ) where++import qualified Data.ByteString.Char8 as BS+import Data.List( isPrefixOf, inits )+import System.FilePath( (</>) )++-------------------------------+-- AnchoredPath utilities+--++newtype Name = Name BS.ByteString deriving (Eq, Show, Ord)+newtype AnchoredPath = AnchoredPath [Name] deriving (Eq, Show, Ord)++-- Both unsafe.++nameToFilePath :: Name -> FilePath+nameToFilePath (Name p) = BS.unpack p++nameFromFilePath :: FilePath -> Name+nameFromFilePath p = Name $ BS.pack p++isPrefix :: AnchoredPath -> AnchoredPath -> Bool+(AnchoredPath a) `isPrefix` (AnchoredPath b) = a `isPrefixOf` b++-- | Append an element to the end of a path.+appendPath :: AnchoredPath -> Name -> AnchoredPath+appendPath (AnchoredPath p) n =+ case n of+ (Name s) | s == BS.empty -> AnchoredPath p+ | otherwise -> AnchoredPath $ p ++ [n]++catPaths :: AnchoredPath -> AnchoredPath -> AnchoredPath+catPaths (AnchoredPath p) (AnchoredPath n) = AnchoredPath $ p ++ n++parent :: AnchoredPath -> AnchoredPath+parent (AnchoredPath x) = AnchoredPath (init x)++parents :: AnchoredPath -> [AnchoredPath]+parents (AnchoredPath x) =+ case x of+ [] -> []+ [_] -> [AnchoredPath []]+ _ -> map AnchoredPath $ tail $ inits (init x)++-- | Take a "root" directory and an anchored path and produce a full path.+anchorPath :: FilePath -> AnchoredPath -> FilePath+anchorPath dir (AnchoredPath p) = dir </> path+ where path = BS.unpack (flatten p)+ flatten = BS.intercalate (BS.singleton '/') . map (\(Name x) -> x)+{-# INLINE anchorPath #-}++floatBS :: BS.ByteString -> AnchoredPath+floatBS = AnchoredPath . map Name . takeWhile (not . BS.null) . BS.split '/'++anchorBS :: AnchoredPath -> BS.ByteString+anchorBS (AnchoredPath p) = BS.intercalate (BS.singleton '/')+ [ n | (Name n) <- p ]
+ Storage/Hashed/Diff.hs view
@@ -0,0 +1,136 @@+module Storage.Hashed.Diff where++import Prelude hiding ( read, lookup, filter )+import qualified Data.ByteString.Lazy.Char8 as BL+import Storage.Hashed.Tree+import Storage.Hashed.AnchoredPath+import Data.List.LCS+import Data.List ( groupBy )++unidiff :: Tree -> Tree -> IO BL.ByteString+unidiff l r =+ do (from, to) <- diffTrees l r+ diffs <- sequence $ zipCommonFiles diff from to+ return $ BL.concat diffs+ where diff p a b = do x <- read a+ y <- read b+ return $ diff' p x y+ diff' p x y =+ case unifiedDiff x y of+ x' | BL.null x' -> BL.empty+ | otherwise ->+ (BL.pack $ "--- " ++ anchorPath "old" p ++ "\n" +++ "+++ " ++ anchorPath "new" p ++ "\n")+ `BL.append` x'++type Line = BL.ByteString+data WeaveLine = Common Line+ | Remove Line+ | Add Line+ | Replace Line Line+ | Skip Int deriving Show++-- | A weave -- two files woven together, with common and differing regions+-- marked up. Cf. 'WeaveLine'.+type Weave = [WeaveLine]++-- | Sort of a sub-weave.+type Hunk = [WeaveLine]++-- | Produce unified diff (in a string form, ie. formatted) from a pair of+-- bytestrings.+unifiedDiff :: BL.ByteString -> BL.ByteString -> BL.ByteString+unifiedDiff a b = printUnified $ concat $ unifiedHunks+ where unifiedHunks = reduceContext 3 $ map unifyHunk $ hunks $ weave a b++-- | Weave two bytestrings. Intermediate data structure for the actual unidiff+-- implementation. No skips are produced.+weave :: BL.ByteString -> BL.ByteString -> Weave+weave a' b' = weave' left common right+ where left = init' (BL.split '\n' a') -- drop trailing newline+ right = init' (BL.split '\n' b') -- drop trailing newline+ init' [] = []+ init' x = init x+ common = lcs left right+ weave' [] [] [] = []+ weave' [] c [] = error $ "oops: Left & Right empty, Common: " ++ show c+ weave' [] [] (b:bs) = (Add b):weave' [] [] bs+ weave' (a:as) [] [] = (Remove a):weave' as [] []+ weave' (a:as) [] (b:bs) = (Replace a b):weave' as [] bs+ weave' (a:as) (c:cs) (b:bs)+ | a == c && b == c = (Common a):weave' as cs bs+ | a == c && b /= c = (Add b):weave' (a:as) (c:cs) bs+ | a /= c && b == c = (Remove a):weave' as (c:cs) (b:bs)+ | a /= c && b /= c = (Replace a b):weave' as (c:cs) bs+ | otherwise = error "oops!"+ weave' a c b = error $ "oops: \nLeft: " ++ show a ++ "\nCommon: " ++ show c ++ "\nRight: " ++ show b++-- | Break up a Weave into hunks.+hunks :: Weave -> [Hunk]+hunks = groupBy grp+ where grp (Common _) (Common _) = True+ grp (Common _) _ = False+ grp _ (Common _) = False+ grp _ _ = True++-- | Reformat a Hunk into a format suitable for unified diff. Replaces are+-- turned into add/remove pairs, all removals in a hunk go before all+-- adds. Hunks of Common lines are left intact. Produces input suitable for+-- reduceContext.+unifyHunk :: Hunk -> Hunk+unifyHunk h = case h of+ (Common _:_) -> h+ _ -> reorder $ concatMap breakup h+ where reorder h' = [ Remove a | Remove a <- h' ] ++ [ Add a | Add a <- h' ]+ breakup (Replace f t) = [Remove f, Add t]+ breakup x = [x]++-- | Break up a 'Weave' into unified hunks, leaving @n@ lines of context around+-- every hunk. Consecutive Common lines not used as context are replaced with+-- Skips.+reduceContext :: Int -> [Hunk] -> [Hunk]+reduceContext n hs =+ case hs of+ [] -> []+ [Common _:_] -> []+ [x] -> [x]+ [h,t] -> reduce 0 n h : reduce n 0 t : []+ (h:rest) -> reduce 0 n h :+ map (reduce n n) (init rest) +++ [reduce n 0 $ last rest]+ where+ reduce s e h@(Common _:_)+ | length h <= s + e = h+ | otherwise = take s h +++ [Skip $ length h - e - s ] +++ drop (length h - e) h+ reduce _ _ h = h++-- | Format a Weave for printing.+deweave :: Weave -> BL.ByteString+deweave = BL.unlines . map disp+ where disp (Common l) = BL.cons ' ' l+ disp (Remove l) = BL.cons '-' l+ disp (Add l) = BL.cons '+' l+ disp (Replace _ t) = BL.cons '!' t+ disp (Skip n) = BL.pack $ "-- skip " ++ show n ++ " lines --"++-- | Print a "hunked" weave in form of an unified diff. Hunk boundaries are+-- marked up as "Skip" lines. Cf. "reduceContext".+printUnified :: Weave -> BL.ByteString+printUnified hunked = printHunks 1 1 $ groupBy splits hunked+ where splits (Skip _) _ = False+ splits _ (Skip _) = False+ splits _ _ = True+ printHunks _ _ [] = BL.empty+ printHunks l r ([Skip n]:rest) =+ printHunks (n+l) (n+r) rest+ printHunks l r (h:rest) =+ (BL.pack $ "@@ -" ++ show l ++ "," +++ show (removals h) ++ " +" ++ show r +++ "," ++ show (adds h) ++ " @@\n")+ `BL.append` deweave h `BL.append`+ printHunks (l + removals h) (r + adds h) rest+ commons h = length [ () | (Common _) <- h ]+ adds h = commons h + length [ () | (Add _) <- h ]+ removals h = commons h + length [ () | (Remove _) <- h ]
+ Storage/Hashed/Index.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE PatternSignatures, ScopedTypeVariables #-}+module Storage.Hashed.Index where++import Prelude hiding ( lookup, readFile, writeFile, catch )+import Storage.Hashed.Utils+import Storage.Hashed.Tree+import Storage.Hashed.AnchoredPath+import Data.Int( Int64, Int32 )++import qualified Data.Set as S+import qualified Data.Map as M++import Bundled.Posix( getFileStatusBS, modificationTime,+ getFileStatus, fileSize, fileExists, EpochTime )+import System.IO.MMap( mmapFileForeignPtr, Mode(..) )+import System.Directory( removeFile, doesFileExist )+import Control.Monad( when )++import qualified Data.ByteString.Char8 as BS+import Data.ByteString.Internal( toForeignPtr, fromForeignPtr, memcpy+ , nullForeignPtr )++import Data.IORef( newIORef, readIORef, modifyIORef, IORef )+import Data.Maybe( fromJust, isJust )++import Foreign.Storable+import Foreign.ForeignPtr+import Foreign.Ptr++hashToString :: Hash -> String+hashToString (Hash (_,s)) = BS.unpack s++--------------------------+-- Indexed trees+--++-- |A recursive-ish index structure (as opposed to flat-ish structure, which is+-- used by git... It turns out that it's hard to efficiently read a flat index+-- with our internal data structures -- we need to turn the flat index into a+-- recursive Tree object, which is rather expensive...). As a bonus, we can+-- also efficiently implement subtree queries this way (cf. readIndex).+data Item = Item { iPath :: BS.ByteString+ , iName :: BS.ByteString+ , iHash :: BS.ByteString+ , iSize :: Ptr Int64+ , iAux :: Ptr Int64 -- end-offset for dirs, mtime for files+ } deriving Show++itemSize :: Item -> Int+itemSize i = 4 + (BS.length $ iPath i) + 1 + 64 + 16++itemSizeI :: (Num a) => Item -> a+itemSizeI = fromIntegral . itemSize++itemIsDir :: Item -> Bool+itemIsDir i = BS.last (iPath i) == '/'++createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item+createItem typ path fp off =+ do let name = BS.concat [ anchorBS path,+ (typ == TreeType) ? (BS.singleton '/', BS.empty),+ BS.singleton '\0' ]+ (namefp, nameoff, namel) = toForeignPtr name+ withForeignPtr fp $ \p ->+ withForeignPtr namefp $ \namep ->+ do pokeByteOff p off namel+ memcpy (plusPtr p $ off + 4)+ (plusPtr namep nameoff)+ (fromIntegral namel)+ peekItem fp off Nothing++peekItem :: ForeignPtr () -> Int -> Maybe Int -> IO Item+peekItem fp off dirlen =+ withForeignPtr fp $ \p -> do+ nl' :: Int32 <- peekByteOff p off+ let nl = fromIntegral nl'+ path = fromForeignPtr (castForeignPtr fp) (off + 4) (nl - 1)+ hash = fromForeignPtr (castForeignPtr fp) (off + 4 + nl) 64+ name' = snd $ BS.splitAt (fromJust dirlen) path+ name = (BS.last name' == '/') ? (BS.init name', name')+ return $! Item { iName = isJust dirlen ? (name, undefined)+ , iPath = path+ , iHash = hash+ , iSize = plusPtr p (off + 4 + nl + 64)+ , iAux = plusPtr p (off + 4 + nl + 64 + 8)+ }++-- | Update an existing item with new hash and optionally mtime (give Nothing+-- when updating directory entries).+update :: Item -> Maybe EpochTime -> Hash -> IO ()+update item mtime (Hash (Just size,hash)) =+ do poke (iSize item) size+ pokeBS (iHash item) hash+ when (isJust mtime) $ poke (iAux item)+ (fromIntegral $ fromEnum $ fromJust mtime)+update _ _ _ = fail "Index.update requires a hash with size included."++iHash' :: Item -> IO Hash+iHash' i = do size <- peek $ iSize i+ return $ hashSetSize (Hash (undefined, iHash i)) size++mmapIndex :: forall a. Int -> IO (ForeignPtr a, Int)+mmapIndex req_size = do+ exist <- doesFileExist "_darcs/index"+ act_size <- if exist then fileSize `fmap` getFileStatus "_darcs/index"+ else return 0+ let size = fromIntegral $+ if req_size > 0 then fromIntegral req_size else act_size+ case size of+ 0 -> return (castForeignPtr $ nullForeignPtr, size)+ _ -> do (x, _) <- mmapFileForeignPtr "_darcs/index"+ ReadWrite (Just (0, size))+ return (x, size)++-- |See "readIndex". This version also gives a map from paths to items, so the+-- extra per-item data can be used (hash and mtime) directly. The map is in a+-- form of IORef, since the data is not available until the tree is unfolded.+readIndex' :: IO (Tree, IORef (M.Map AnchoredPath Item))+readIndex' = do+ (mmap, mmap_size) <- mmapIndex 0+ dirs_changed <- newIORef S.empty+ item_map <- newIORef M.empty+ let readItem :: AnchoredPath -> Int -> Int -> IO (Item, Maybe TreeItem)+ readItem parent_path off dl =+ do item <- peekItem mmap off (Just dl)+ x <- if itemIsDir item then readDir parent_path item off dl+ else readFile parent_path item+ when (isJust x) $ modifyIORef item_map $ \m ->+ M.insert (parent_path `appendPath` (Name $ iName item)) item m+ return (item, x)+ readDir :: AnchoredPath -> Item -> Int -> Int -> IO (Maybe TreeItem)+ readDir parent_path item off dl =+ do dirend <- peek $ iAux item+ st <- getFileStatusBS (iPath item)+ let this_path = parent_path `appendPath` (Name $ iName item)+ nl = BS.length (iName item)+ dl' = dl + (nl == 0) ? (0, 1 + nl)+ subs coff | coff < dirend = do+ (idx_item, tree_item) <- readItem this_path+ (fromIntegral coff) dl'+ next <- if itemIsDir idx_item+ then peek $ iAux idx_item+ else return $ coff + itemSizeI idx_item+ rest <- subs next+ case tree_item of+ Nothing -> return $! rest+ Just ti -> return $! (Name $ iName idx_item, ti) : rest+ subs coff | coff == dirend = return []+ | otherwise = fail "Offset mismatch."+ updateHash path tree =+ do changed <- S.member path `fmap` readIORef dirs_changed+ let hash = darcsTreeHash tree+ tree' = tree { treeHash = Just hash }+ if changed+ then do update item Nothing hash+ return tree'+ else return tree+ treehash <- iHash' item+ let rt = Stub (do s <- subs $ fromIntegral (off + itemSize item)+ return $ (makeTree s)+ { finish = updateHash this_path+ , treeHash = Just treehash })+ (Just treehash)+ return $ if fileExists st then Just rt else Nothing+ readFile parent_path item =+ do st <- getFileStatusBS (iPath item)+ mtime <- fromIntegral `fmap` (peek $ iAux item)+ size <- peek $ iSize item+ let mtime' = modificationTime st+ size' = fileSize st+ readblob = readSegment (BS.unpack $ iPath item, Nothing)+ when ( mtime /= mtime' || size /= fromIntegral size' ) $+ do hash_' <- sha256 `fmap` readblob+ let hash' = hashSetSize hash_' (fromIntegral size')+ update item (Just mtime') hash'+ modifyIORef dirs_changed $ \s ->+ S.union (S.fromList $ parent_path : parents parent_path) s+ hash <- iHash' item+ if fileExists st+ then return $ Just $ File (Blob readblob $ Just hash)+ else return Nothing+ if (mmap_size > 0) then+ do (_, Just (Stub root h)) <- readItem (AnchoredPath []) 0 0+ tree <- root+ return (tree { treeHash = h }, item_map)+ else return (emptyTree, item_map)++-- |Read an index and build up a Tree object from it, referring to current+-- working directory. Any parts of the index that are out of date are updated+-- in-place. The result is always an up-to-date index. Also, the Tree is stubby+-- and only the pieces of the index that are unfolded will be actually updated!+-- To implement a subtree query, you can use 'Tree.filter' and then unfold the+-- result. Otherwise just unfold the whole tree to avoid unexpected problems.+readIndex :: IO Tree+readIndex = fst `fmap` readIndex'++-- |Will add and remove files in index to make it match the Tree object given+-- (it is an error for the Tree to contain a file or directory that does not+-- exist in a plain form under FilePath).+updateIndexFrom :: Tree -> IO Tree+updateIndexFrom ref =+ do (oldidx', item_map') <- readIndex'+ unfold oldidx'+ item_map <- readIORef item_map'+ reference <- unfold ref+ let typeLen TreeType = 1+ typeLen BlobType = 0+ paths = [ (p, itemType i) | (p, i) <- list reference ]+ len = 87 + sum [ typeLen typ + 84 + 1 + length (anchorPath "" p)+ | (p, typ) <- paths ]+ exist <- doesFileExist "_darcs/index"+ when exist $ removeFile "_darcs/index" -- to avoid clobbering oldidx+ (mmap, _) <- mmapIndex len+ let create (File _) path off =+ do i <- createItem BlobType path mmap off+ case M.lookup path item_map of+ Nothing -> return ()+ Just item -> do mtime <- peek $ iAux item+ hash <- iHash' item+ update i (Just $ fromIntegral mtime) hash+ return $ off + itemSize i+ create (SubTree s) path off =+ do i <- createItem TreeType path mmap off+ case M.lookup path item_map of+ Nothing -> return ()+ Just item -> do hash <- iHash' item+ update i Nothing hash+ let subs [] = return $ off + itemSize i+ subs ((name,x):xs) = do+ let path' = path `appendPath` name+ noff <- subs xs+ create x path' noff+ lastOff <- subs (listImmediate s)+ poke (iAux i) (fromIntegral lastOff)+ return lastOff+ create (Stub _ _) _ _ =+ fail "Cannot create index from stubbed Tree."+ create (SubTree reference) (AnchoredPath []) 0+ readIndex
+ Storage/Hashed/Monad.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE PatternSignatures, ScopedTypeVariables, BangPatterns #-}++-- | An experimental monadic interface to Tree mutation. The main idea is to+-- simulate IO-ish manipulation of real filesystem (that's the state part of+-- the monad), and to keep memory usage down by reasonably often dumping the+-- intermediate data to disk and forgetting it. XXX This currently does not+-- work as advertised and the monads leak memory. So far, I'm at a loss why+-- this happens.+module Storage.Hashed.Monad+ ( hashedTreeIO, plainTreeIO, virtualTreeIO+ , readFile, writeFile, createDirectory, rename, unlink+ , tree, cwd, TreeState+ ) where++import Prelude hiding ( read, catch, readFile, writeFile )++import Storage.Hashed.AnchoredPath+import Storage.Hashed.Tree+import Storage.Hashed.Utils++import System.Directory( createDirectoryIfMissing, doesFileExist )+import System.FilePath( (</>) )+import Data.List( inits )+import Data.Int( Int64 )+import Data.Maybe( isNothing )++import Codec.Compression.GZip( decompress, compress )++import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.ByteString.Char8 as BS+import Control.Monad.State.Strict+import qualified Data.Set as S++data TreeState = TreeState { cwd :: AnchoredPath+ , tree :: Tree+ , changed :: S.Set AnchoredPath+ , changesize :: Int64+ , sync :: TreeIO () }++-- | A TreeIO monad. A sort of like IO but it keeps a TreeState around as well,+-- which is a sort of virtual filesystem. Depending on how you obtained your+-- TreeIO, the actions in your virtual filesystem get somehow reflected in the+-- actual real filesystem. For "virtualTreeIO", nothing happens in real+-- filesystem, however with "plainTreeIO", the plain tree will be updated every+-- now and then, and with "hashedTreeIO" a darcs-style hashed tree will get+-- updated.+type TreeIO a = StateT TreeState IO a++initialState :: Tree -> TreeIO () -> TreeState+initialState t s = TreeState { cwd = AnchoredPath []+ , tree = t+ , changed = S.empty+ , changesize = 0+ , sync = s }++runTreeIO :: TreeIO a -> TreeState -> IO (a, Tree)+runTreeIO action initial = do+ (out, final) <- runStateT (do x <- action+ get >>= sync+ return x) initial+ return (out, tree final)++-- | Run a TreeIO action without dumping anything to disk. Useful for running+-- tree mutations just for the purpose of getting the resulting Tree and+-- throwing it away.+virtualTreeIO :: TreeIO a -> Tree -> IO (a, Tree)+virtualTreeIO action t = runTreeIO action $ initialState t (return ())++-- | Create a hashed file from a filepath and content. In case the file exists+-- it is kept untouched and is assumed to have the right content. XXX Corrupt+-- files should be probably renamed out of the way automatically or something+-- (probably when they are being read though).+fs_createHashedFile :: FilePath -> BL.ByteString -> TreeIO ()+fs_createHashedFile fn content =+ liftIO $ do+ exist <- doesFileExist fn+ unless exist $ BL.writeFile fn content++replaceItemAbs :: AnchoredPath -> Maybe TreeItem -> TreeIO ()+replaceItemAbs path item =+ modify $ \st -> st { tree = modifyTree (tree st) path item }++replaceItem :: AnchoredPath -> Maybe TreeItem -> TreeIO ()+replaceItem path item =+ modify $ \st -> st { tree = modifyTree (tree st)+ (cwd st `catPaths` path) item }++unfoldTo :: AnchoredPath -> TreeIO ()+unfoldTo p = do t <- gets tree+ t' <- liftIO $ unfoldPath t p+ modify $ \st -> st { tree = t' }++-- | Run a TreeIO @action@ in a hashed setting. The @initial@ tree is assumed+-- to be fully available from the @directory@, and any changes will be written+-- out to same. Please note that actual filesystem files are never removed.+--+-- XXX This somehow manages to leak memory, somewhere.+hashedTreeIO :: TreeIO a -- ^ action+ -> Tree -- ^ initial+ -> FilePath -- ^ directory+ -> IO (a, Tree)+hashedTreeIO action t dir =+ do runTreeIO action $ initialState t syncHashed+ where syncHashed = do+ ch <- gets changed+ modify $ \st -> st { changed = S.empty }+ forM_ (reverse $ S.toList ch) $ \c -> do+ let path = anchorPath "" c+ current <- gets tree+ case find current c of+ Just (File b) -> updateFile c b+ Just (SubTree s) -> updateSub c s+ _ -> fail $ "Bar at " ++ path+ updateFile path b@(Blob _ (Just !h)) = do+ let fn = dir </> BS.unpack (darcsFormatHash h)+ nblob = File $ Blob (decompress `fmap` BL.readFile fn) (Just h)+ newcontent <- liftIO $ compress `fmap` read b+ fs_createHashedFile fn newcontent+ replaceItemAbs path (Just nblob)+ updateFile path b@(Blob _ Nothing) = do+ content <- liftIO $ read b+ let h = hashSetSize (sha256 content) (BL.length content)+ fn = dir </> BS.unpack (darcsFormatHash h)+ nblob = File $ Blob (decompress `fmap` BL.readFile fn) (Just h)+ newcontent = compress content+ fs_createHashedFile fn newcontent+ replaceItemAbs path (Just nblob)+ updateSub path s = do+ let !hash = darcsTreeHash s+ dirdata = darcsFormatDir s+ fn = dir </> BS.unpack (darcsFormatHash $ hash)+ ns = SubTree (s { treeHash = Just hash })+ fs_createHashedFile fn (compress dirdata)+ replaceItemAbs path (Just ns)++-- | Run a TreeIO action in a plain tree setting. Writes out changes to the+-- plain tree every now and then (after the action is finished, the last tree+-- state is always flushed to disk). XXX Modify the tree with filesystem+-- reading and put it back into st (ie. replace the in-memory Blobs with normal+-- ones, so the memory can be GCd).+plainTreeIO :: TreeIO a -> Tree -> FilePath -> IO (a, Tree)+plainTreeIO action t dir = runTreeIO action $ initialState t syncPlain+ where syncPlain = do+ ch <- gets changed+ modify $ \st -> st { changed = S.empty }+ current <- gets tree+ forM_ (S.toList ch) $ \c -> do+ let path = anchorPath dir c+ case find current c of+ Just (File b) -> do+ liftIO $ read b >>= BL.writeFile path+ let nblob = File $ Blob (BL.readFile path) Nothing+ modify $ \st -> st { tree = modifyTree (tree st) c+ (Just nblob) }+ Just (SubTree _) ->+ liftIO $ createDirectoryIfMissing False path+ _ -> fail $ "Foo at " ++ path++-- | Grab content of a file in the current Tree at the given path.+readFile :: AnchoredPath -> TreeIO BL.ByteString+readFile p = do unfoldTo p+ t <- gets tree+ let f = findFile t p+ case f of+ Nothing -> fail $ "No such file " ++ show p+ Just x -> liftIO (read x)++-- | Internal. Mark a given path as changed, so the next sync will flush the+-- modified object to disk.+markChanged :: AnchoredPath -> TreeIO ()+markChanged p = do+ x <- get+ size <- liftIO $ case findFile (tree x) p of+ Just b -> BL.length `fmap` read b+ Nothing -> return 0+ put $ x { changed = S.union paths (changed x)+ , changesize = changesize x + size }+ where paths = let (AnchoredPath x) = p+ in S.fromList $ map AnchoredPath $ inits x++-- | Change content of a file at a given path. The change will be eventually+-- flushed to disk, but might be buffered for some time.+writeFile :: AnchoredPath -> BL.ByteString -> TreeIO ()+writeFile p con =+ do replaceItem p (Just blob)+ markChanged p+ maybeSync+ where blob = File $ Blob (return con) hash+ hash = Just $ hashSetSize (sha256 con) (BL.length con)++createDirectory :: AnchoredPath -> TreeIO ()+createDirectory p = replaceItem p $ Just $ SubTree emptyTree++unlink :: AnchoredPath -> TreeIO ()+unlink p = replaceItem p Nothing++rename :: AnchoredPath -> AnchoredPath -> TreeIO ()+rename from to = do unfoldTo from+ tr <- gets tree+ let item = find tr from+ when (isNothing item) $+ fail $ "Rename: " ++ show from ++ " does not exist"+ replaceItem to item+ replaceItem from Nothing++-- | If buffers are becoming large, sync, otherwise do nothing.+maybeSync :: TreeIO ()+maybeSync = do x <- gets changesize+ when (x > 16 * 1024 * 1024) $ get >>= sync
+ Storage/Hashed/Test.hs view
@@ -0,0 +1,104 @@+module Storage.Hashed.Test where++import Prelude hiding ( read )+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.ByteString.Char8 as BS+import Test.HUnit+import System.Process+import Control.Monad( forM_ )+import Data.Maybe+import Data.List( (\\), sort )+import System.Directory+import Storage.Hashed+import Storage.Hashed.AnchoredPath+import Storage.Hashed.Tree+import Storage.Hashed.Index+import Storage.Hashed.Utils++tests_darcs_basic =+ TestList [ TestLabel "have_files" have_files+ , TestLabel "have_pristine_files" have_pristine_files+ , TestLabel "darcs_manifest" darcs_manifest+ , TestLabel "darcs_contents" darcs_contents ]+ where+ files = [ floatPath "hashed-storage.cabal"+ , floatPath "Storage/Hashed.hs"+ , floatPath "Storage/Hashed/Index.hs" ]+ check_file t f = assertBool+ ("path " ++ show f ++ " is in tree")+ (isJust $ find t f)+ check_files t = forM_ files (check_file t)+ have_files = TestCase $ readPlainTree "." >>= unfold >>= check_files+ have_pristine_files = TestCase $+ readDarcsPristine "." >>= unfold >>= check_files++ -- NB. If darcs starts using hashed-storage internally, the following+ -- tests become useless, since they check our code against darcs.+ darcs_manifest = TestCase $ do+ f <- lines `fmap` readProcess "darcs" ["show", "files" ] ""+ t <- readDarcsPristine "." >>= unfold+ forM_ (f \\ ["."]) (\x -> check_file t (floatPath x))+ forM_ (list t)+ (\x -> assertBool (show (fst x) ++ " is in darcs show files") $+ anchorPath "." (fst x) `elem` f)+ darcs_contents = TestCase $ do+ t <- readDarcsPristine "." >>= unfold+ sequence_ [+ do our <- read b+ darcs <- readProcess "darcs" [ "show", "contents",+ anchorPath "." p ] ""+ assertEqual "contents match" (BL.unpack our) darcs+ | (p, File b) <- list t ]++tests_tree_index =+ TestList [ TestLabel "check_index" check_index+ , TestLabel "check_index_content" check_index_content ]+ where pristine = readDarcsPristine "." >>= unfold+ working = do+ x <- pristine+ plain <- readPlainTree "."+ unfold (restrict x plain)+ build_index =+ do x <- pristine >>= unfold+ idx <- updateIndexFrom x >>= unfold+ return (x, idx)+ check_index = TestCase $+ do (pris, idx) <- build_index+ (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris)+ check_blob_pair p x y =+ do a <- read x+ b <- read y+ assertEqual ("content match on " ++ show p) a b+ check_index_content = TestCase $+ do (_, idx) <- build_index+ plain <- readPlainTree "."+ x <- sequence $ zipCommonFiles check_blob_pair plain idx+ assertBool "files match" (length x > 0)++tests_generic = TestList [ TestLabel "check_modify" check_modify+ , TestLabel "check_modify_complex" check_modify_complex+ ]+ where blob x = File $ Blob (return (BL.pack x)) (Just $ sha256 $ BL.pack x)+ name = Name . BS.pack+ check_modify = TestCase $+ let t = makeTree [(name "foo", blob "bar")]+ mod = modifyTree t (floatPath "foo") (Just $ blob "bla")+ in do x <- read $ fromJust $ findFile t (floatPath "foo")+ y <- read $ fromJust $ findFile mod (floatPath "foo")+ assertEqual "old version" x (BL.pack "bar")+ assertEqual "new version" y (BL.pack "bla")+ check_modify_complex = TestCase $+ let t = makeTree [ (name "foo", blob "bar")+ , (name "bar", SubTree t1) ]+ t1 = makeTree [ (name "foo", blob "bar") ]+ mod = modifyTree t (floatPath "bar/foo") (Just $ blob "bla")+ in do foo <- read $ fromJust $ findFile t (floatPath "foo")+ foo' <- read $ fromJust $ findFile mod (floatPath "foo")+ bar_foo <- read $ fromJust $+ findFile t (floatPath "bar/foo")+ bar_foo' <- read $ fromJust $+ findFile mod (floatPath "bar/foo")+ assertEqual "old foo" foo (BL.pack "bar")+ assertEqual "old bar/foo" bar_foo (BL.pack "bar")+ assertEqual "new foo" foo' (BL.pack "bar")+ assertEqual "new bar/foo" bar_foo' (BL.pack "bla")
+ Storage/Hashed/Tree.hs view
@@ -0,0 +1,367 @@+-- | The abstract representation of a Tree and useful abstract utilities to+-- handle those.+module Storage.Hashed.Tree+ ( Tree, Blob(..), TreeItem(..), ItemType(..), Hash(..)+ , makeTree, makeTreeWithHash, darcsTreeHash, darcsFormatDir, emptyTree+ , emptyBlob++ -- * Unfolding stubbed (lazy) Trees.+ --+ -- | By default, Tree obtained by a read function is stubbed: it will+ -- contain Stub items that need to be executed in order to access the+ -- respective subtrees. 'unfold' will produce an unstubbed Tree.+ , unfold, unfoldPath++ -- * Tree access and lookup.+ , items, list, listImmediate, treeHash+ , lookup, find, findFile, findTree, itemHash, itemType+ , zipCommonFiles, zipFiles, zipTrees, diffTrees++ -- * Files (Blobs).+ , read++ -- * Manipulating trees.+ , finish, filter, restrict, modifyTree ) where++import Prelude hiding( lookup, filter, read, all )+import Storage.Hashed.AnchoredPath+import Storage.Hashed.Utils( Hash(..), sha256, hashSetSize, darcsFormatHash )++import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Map as M++import Data.Maybe( catMaybes )+import Data.List( sortBy, union, sort )++--------------------------------+-- Tree, Blob and friends+--++data Blob = Blob !(IO BL.ByteString) !(Maybe Hash)+data TreeItem = File !Blob+ | SubTree !Tree+ | Stub !(IO Tree) !(Maybe Hash)++data ItemType = BlobType | TreeType deriving (Show, Eq)++-- | Abstraction of a filesystem tree.+-- Please note that the Tree returned by the respective read operations will+-- have TreeStub items in it. To obtain a Tree without such stubs, call+-- unfold on it, eg.:+--+-- > tree <- readDarcsPristine "." >>= unfold+--+-- When a Tree is unfolded, it becomes "final". All stubs are forced and the+-- Tree can be traversed purely. Access to actual file contents stays in IO+-- though.+--+-- A Tree may have a Hash associated with it. A pair of Tree's is identical+-- whenever their hashes are (the reverse need not hold, since not all Trees+-- come equipped with a hash).+data Tree = Tree { items :: (M.Map Name TreeItem)+ , listImmediate :: [(Name, TreeItem)]+ -- | Get hash of a Tree. This is guaranteed to uniquely+ -- identify the Tree (including any blob content), as far as+ -- cryptographic hashes are concerned. Sha256 is recommended.+ , treeHash :: !(Maybe Hash)+ -- | When implementing a Tree that has complex unfolding+ -- semantics, the "finish" IO action lets you do arbitrary IO+ -- transform on the Tree after it is unfolded but before it is+ -- given to the user by unfold. (Used to implement Index+ -- updates, eg.)+ , finish :: Tree -> IO Tree }++-- | Get a hash of a TreeItem. May be Nothing.+itemHash :: TreeItem -> Maybe Hash+itemHash (File (Blob _ h)) = h+itemHash (SubTree t) = treeHash t+itemHash (Stub _ h) = h++itemType :: TreeItem -> ItemType+itemType (File _) = BlobType+itemType (SubTree _) = TreeType+itemType (Stub _ _) = TreeType++emptyTree :: Tree+emptyTree = Tree { items = M.empty+ , listImmediate = []+ , treeHash = Nothing+ , finish = return }++emptyBlob :: Blob+emptyBlob = Blob (return BL.empty) Nothing++makeTree :: [(Name,TreeItem)] -> Tree+makeTree l = Tree { items = M.fromList l+ , listImmediate = l+ , treeHash = Nothing+ , finish = return }++makeTreeWithHash :: [(Name,TreeItem)] -> Hash -> Tree+makeTreeWithHash l h = Tree { items = M.fromList l+ , listImmediate = l+ , treeHash = Just h+ , finish = return }++darcsFormatDir :: Tree -> BL.ByteString+darcsFormatDir t = BL.fromChunks $ concatMap string+ (sortBy cmp $ listImmediate t)+ where cmp (Name a, _) (Name b, _) = compare a b+ string (Name name, item) =+ [ case item of+ File _ -> BS.pack "file:\n"+ SubTree _ -> BS.pack "directory:\n"+ Stub _ _ ->+ error "Trees with stubs not supported in darcsFormatDir.",+ name, BS.singleton '\n',+ case itemHash item of+ Nothing -> error $ "darcsFormatDir: missing hash on "+ ++ show name+ Just h -> darcsFormatHash h,+ BS.singleton '\n' ]++-- | Compute a darcs-compatible hash value for a tree-like structure.+darcsTreeHash :: Tree -> Hash+darcsTreeHash d = hashSetSize (sha256 bl) $ BL.length bl+ where bl = darcsFormatDir d++-----------------------------------+-- Tree access and lookup+--++-- | Look up a 'Tree' item (an immediate subtree or blob).+lookup :: Tree -> Name -> Maybe TreeItem+lookup t n = M.lookup n (items t)++find' :: TreeItem -> AnchoredPath -> Maybe TreeItem+find' t (AnchoredPath []) = Just t+find' (SubTree t) (AnchoredPath (d : rest)) =+ case lookup t d of+ Just sub -> find' sub (AnchoredPath rest)+ Nothing -> Nothing+find' _ _ = Nothing++-- | Find a 'TreeItem' by its path. Gives 'Nothing' if the path is invalid.+find :: Tree -> AnchoredPath -> Maybe TreeItem+find t p = find' (SubTree t) p++-- | Find a 'Blob' by its path. Gives 'Nothing' if the path is invalid, or does+-- not point to a Blob.+findFile :: Tree -> AnchoredPath -> Maybe Blob+findFile t p = case find t p of+ Just (File x) -> Just x+ _ -> Nothing++-- | Find a 'Tree' by its path. Gives 'Nothing' if the path is invalid, or does+-- not point to a Tree.+findTree :: Tree -> AnchoredPath -> Maybe Tree+findTree t p = case find t p of+ Just (SubTree x) -> Just x+ _ -> Nothing++-- | List all contents of a 'Tree'.+list :: Tree -> [(AnchoredPath, TreeItem)]+list t_ = paths t_ (AnchoredPath [])+ where paths t p = [ (appendPath p n, i)+ | (n,i) <- listImmediate t ] +++ concat [ paths subt (appendPath p subn)+ | (subn, SubTree subt) <- listImmediate t ]++-- | Unfold a stubbed Tree into a one with no stubs in it. You might want to+-- filter the tree before unfolding to save IO.+unfold :: Tree -> IO Tree+unfold t_ = unfold' t_ (AnchoredPath [])+ where unfold' :: Tree -> AnchoredPath -> IO Tree+ unfold' t path = do+ unfolded <- sequence [+ item n t' path+ | (n, Stub t' _) <- listImmediate t ]+ let orig = M.filter (not . isStub) (items t)+ orig_l = [ i | i <- listImmediate t, not $ isStub $ snd i ]+ m_unfolded = M.fromList unfolded+ tree = t { items = M.union orig m_unfolded+ , listImmediate = orig_l ++ unfolded }+ finish tree tree+ subtree name stub path =+ do let npath = appendPath path name+ tree <- stub+ sub <- unfold' tree npath+ return (name, SubTree sub)+ item n stub p = subtree n stub p+ isStub (Stub _ _) = True+ isStub _ = False++-- | Unfold a path in a (stubbed) Tree, such that the leaf node of the path is+-- reachable without crossing any stubs.+unfoldPath :: Tree -> AnchoredPath -> IO Tree+unfoldPath t_ path_ = do unfold' t_ path_+ where unfold' t (AnchoredPath [_]) = return t+ unfold' t (AnchoredPath (n:rest)) = do+ case lookup t n of+ (Just (Stub stub _)) ->+ do unstubbed <- stub+ amend t n rest unstubbed+ (Just (SubTree t')) -> amend t n rest t'+ _ -> fail $ "Descent error in unfoldPath: " ++ show path_+ amend t name rest sub = do+ t' <- unfold' sub (AnchoredPath rest)+ let orig_l = [ i | i@(n',_) <- listImmediate t, name /= n' ]+ tree = t { items = M.insert name (SubTree sub) (items t)+ , listImmediate = (name, SubTree sub) : orig_l }+ return tree++-- | Given two Trees, a @guide@ and a @tree@, produces a new Tree that is a+-- identical to @tree@, but only has those items that are present in both+-- @tree@ and @guide@. The @guide@ Tree may not contain any stubs.+restrict :: Tree -> Tree -> Tree+restrict guide tree = filter accept tree+ where accept path item =+ case (find guide path, item) of+ (Just (SubTree _), SubTree _) -> True+ (Just (SubTree _), Stub _ _) -> True+ (Just (File _), File _) -> True+ (Just (Stub _ _), _) ->+ error "*sulk* Go away, you, you precondition violator!"+ (_, _) -> False++-- | Given a predicate of the form AnchoredPath -> TreeItem -> Bool, and a+-- Tree, produce a Tree that only has items for which the predicate returned+-- True. The tree might contain stubs. When unfolded, these will be subject to+-- filtering as well.+filter :: (AnchoredPath -> TreeItem -> Bool) -> Tree -> Tree+filter predicate t_ = filter' t_ (AnchoredPath [])+ where filter' t path =+ let subs = (catMaybes [ (,) name `fmap` wibble path name item+ | (name,item) <- listImmediate t ])+ in t { items = M.mapMaybeWithKey (wibble path) $ items t+ , listImmediate = subs+ , treeHash = Nothing }+ wibble path name item =+ let npath = path `appendPath` name in+ if predicate npath item+ then Just $ filterSub npath item+ else Nothing+ filterSub npath (SubTree t) = SubTree $ filter' t npath+ filterSub npath (Stub stub _) =+ Stub (do x <- stub+ return $ filter' x npath) Nothing+ filterSub _ x = x++-- | Read a Blob into a Lazy ByteString. Might be backed by an mmap, use with+-- care.+read :: Blob -> IO BL.ByteString+read (Blob r _) = r++-- | For every pair of corresponding blobs from the two supplied trees,+-- evaluate the supplied function and accumulate the results in a list. Hint:+-- to get IO actions through, just use sequence on the resulting list.+-- NB. This won't unfold any stubs.+zipCommonFiles :: (AnchoredPath -> Blob -> Blob -> a) -> Tree -> Tree -> [a]+zipCommonFiles f a b = catMaybes [ flip (f p) x `fmap` findFile a p+ | (p, File x) <- list b ]++-- | For each file in each of the two supplied trees, evaluate the supplied+-- function (supplying the corresponding file from the other tree, or Nothing)+-- and accumulate the results in a list. Hint: to get IO actions through, just+-- use sequence on the resulting list. NB. This won't unfold any stubs.+zipFiles :: (AnchoredPath -> Maybe Blob -> Maybe Blob -> a)+ -> Tree -> Tree -> [a]+zipFiles f a b = [ f p (findFile a p) (findFile b p)+ | p <- paths a `union` paths b ]+ where paths t = sort [ p | (p, File _) <- list t ]++zipTrees :: (AnchoredPath -> Maybe TreeItem -> Maybe TreeItem -> a)+ -> Tree -> Tree -> [a]+zipTrees f a b = [ f p (find a p) (find b p)+ | p <- reverse (paths a `union` paths b) ]+ where paths t = sort [ p | (p, _) <- list t ]++-- | Cautiously extracts differing subtrees from a pair of Trees. It will never+-- do any unneccessary unfolding. Tree hashes are used to cut the comparison as+-- high up the Tree branches as possible. The result is a pair of trees that do+-- not share any identical subtrees. They are derived from the first and second+-- parameters respectively and they are always fully unfolded. It might be+-- advantageous to feed the result into 'zipFiles'.+diffTrees :: Tree -> Tree -> IO (Tree, Tree)+diffTrees left right =+ if treeHash left `match` treeHash right+ then return (emptyTree, emptyTree)+ else diff left right+ where match (Just h) (Just j) | h == j = True+ match _ _ = False+ isFile (File _) = True+ isFile _ = False+ notFile = not . isFile+ subtree :: TreeItem -> IO Tree+ subtree (Stub x _) = x+ subtree (SubTree x) = return x+ subtree (File _) = error "diffTrees tried to descend a File as a subtree"+ maybeUnfold (Stub x _) = SubTree `fmap` (x >>= unfold)+ maybeUnfold (SubTree x) = SubTree `fmap` unfold x+ maybeUnfold i = return i+ immediateN t = [ n | (n, _) <- listImmediate t ]+ diff left' right' = do+ items <- sequence [+ case (lookup left' n, lookup right' n) of+ (Just l, Nothing) -> do+ l' <- maybeUnfold l+ return (n, Just l', Nothing)+ (Nothing, Just r) -> do+ r' <- maybeUnfold r+ return (n, Nothing, Just r')+ (Just l, Just r)+ | itemHash l `match` itemHash r ->+ return (n, Nothing, Nothing)+ | notFile l && notFile r ->+ do x <- subtree l+ y <- subtree r+ (x', y') <- diffTrees x y+ return $ (n,+ Just $ SubTree x',+ Just $ SubTree y')+ | isFile l && isFile r ->+ return (n, Just l, Just r)+ | otherwise -> do l' <- maybeUnfold l+ r' <- maybeUnfold r+ return $ (n, Just l', Just r')+ | n <- immediateN left' `union` immediateN right' ]+ let items_l = [ (n, l) | (n, Just l ,_) <- items ]+ items_r = [ (n, r) | (n, _, Just r) <- items ]+ return (makeTree items_l, makeTree items_r)++modifyTree :: Tree -> AnchoredPath -> Maybe TreeItem -> Tree++modifyTree _ (AnchoredPath []) (Just (SubTree sub)) = sub++modifyTree t (AnchoredPath [n]) (Just item) =+ t { items = M.insert n item (items t)+ , listImmediate = (n,item) : subs+ , treeHash = Nothing }+ where subs = [ x | x@(n', _) <- listImmediate t, n /= n' ]++modifyTree t (AnchoredPath [n]) Nothing =+ t { items = M.delete n (items t)+ , listImmediate = subs+ , treeHash = Nothing }+ where subs = [ x | x@(n', _) <- listImmediate t, n /= n' ]++modifyTree t path@(AnchoredPath (n:r)) item =+ t { items = M.insert n sub (items t)+ , listImmediate = (n,sub) : subs+ , treeHash = Nothing }+ where subs = [ x | x@(n', _) <- listImmediate t, n /= n' ]+ modSubtree s = modifyTree s (AnchoredPath r) item+ sub = case lookup t n of+ Just (SubTree s) -> SubTree $ modSubtree s+ Just (Stub s _) -> Stub (do x <- s+ return $ modSubtree x) Nothing+ Nothing -> SubTree $ modSubtree emptyTree+ _ -> error $ "Modify tree at " ++ show path++modifyTree _ (AnchoredPath []) (Just (Stub _ _)) =+ error "Bug in descent in modifyTree."+modifyTree _ (AnchoredPath []) (Just (File _)) =+ error "Bug in descent in modifyTree."+modifyTree _ (AnchoredPath []) Nothing =+ error "Bug in descent in modifyTree."
+ Storage/Hashed/Utils.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE PatternSignatures, ScopedTypeVariables #-}++-- | Mostly internal utilities for use by the rest of the library. Subject to+-- removal without further notice.+module Storage.Hashed.Utils where++import Prelude hiding ( lookup, catch )+import qualified Bundled.SHA256 as SHA+import System.Mem( performGC )+import System.IO.Posix.MMap( unsafeMMapFile )+import Bundled.Posix( getFileStatus, fileSize )+import System.Directory( getCurrentDirectory, setCurrentDirectory )+import System.FilePath( (</>), isAbsolute )+import Data.Int( Int64 )+import Data.Char( chr )+import Control.Exception.Extensible( catch, bracket, SomeException(..) )+import Control.Monad( when )++import Foreign.ForeignPtr( withForeignPtr )+import Foreign.Ptr( plusPtr )+import Data.ByteString.Internal( toForeignPtr, memcpy )++import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.ByteString.Char8 as BS++newtype Hash = Hash (Maybe Int64, BS.ByteString) deriving (Show, Eq, Read)++makeHash :: BS.ByteString -> Hash+makeHash str = case BS.split '-' str of+ [h] -> Hash (Nothing, h)+ [s, h] -> Hash (Just $ read $ BS.unpack s, h)+ _ -> error $ "Bad hash string " ++ show str++hashSetSize :: Hash -> Int64 -> Hash+hashSetSize (Hash (_,h)) s = Hash (Just s, h)++darcsFormatSize :: (Num a) => a -> BS.ByteString+darcsFormatSize s = BS.pack $ replicate (10 - length n) '0' ++ n+ where n = (show s)++darcsFormatHash :: Hash -> BS.ByteString+darcsFormatHash (Hash (Just s, h)) =+ BS.concat [ darcsFormatSize s+ , BS.singleton '-'+ , h ]+darcsFormatHash (Hash (Nothing, h)) = h+++darcsDecodeWhite :: String -> FilePath+darcsDecodeWhite ('\\':cs) =+ case break (=='\\') cs of+ (theord, '\\':rest) ->+ chr (read theord) : darcsDecodeWhite rest+ _ -> error "malformed filename"+darcsDecodeWhite (c:cs) = c: darcsDecodeWhite cs+darcsDecodeWhite "" = ""++-- | Pointer to a filesystem, possibly with start/end offsets. Supposed to be+-- fed to (uncurry mmapFileByteString) or similar.+type FileSegment = (FilePath, Maybe (Int64, Int64))++-- | Bad and ugly. Only works well with single-chunk BL's.+sha256 :: BL.ByteString -> Hash+sha256 = makeHash . BS.pack . SHA.sha256 . BS.concat . BL.toChunks++-- | Read in a FileSegment into a Lazy ByteString. Implemented using mmap.+readSegment :: FileSegment -> IO BL.ByteString+readSegment (f,_) = do+ x <- unsafeMMapFile f+ `catch` (\(_::SomeException) -> do+ size <- fileSize `fmap` getFileStatus f+ if size == 0+ then return BS.empty+ else performGC >> unsafeMMapFile f)+ return $ BL.fromChunks [x]+{-# INLINE readSegment #-}++-- | Run an IO action with @path@ as a working directory. Does neccessary+-- bracketing.+withCurrentDirectory :: FilePath -> IO a -> IO a+withCurrentDirectory name m =+ bracket+ (do cwd <- getCurrentDirectory+ when (name /= "") (setCurrentDirectory name)+ return cwd)+ (\oldwd -> setCurrentDirectory oldwd+ `catch` \(_::SomeException) -> return ())+ (const m)++-- Ternary kind of operator. Just a concise way to write if.+(?) :: Bool -> (a, a) -> a+w ? (a,b) = if w then a else b+{-# INLINE (?) #-}++makeAbsolute :: FilePath -> IO FilePath+makeAbsolute p = do+ cwd <- getCurrentDirectory+ return $! isAbsolute p ? (p, cwd </> p)++-- Wow, unsafe.+pokeBS :: BS.ByteString -> BS.ByteString -> IO ()+pokeBS to from =+ do let (fp_to, off_to, len_to) = toForeignPtr to+ (fp_from, off_from, len_from) = toForeignPtr from+ when (len_to /= len_from) $ fail $ "Length mismatch in pokeBS: from = "+ ++ (show len_from) ++ " /= to = " ++ (show len_to)+ withForeignPtr fp_from $ \p_from -> do+ withForeignPtr fp_to $ \p_to -> do+ memcpy (plusPtr p_to off_to)+ (plusPtr p_from off_from)+ (fromIntegral len_to)+
+ hashed-storage.cabal view
@@ -0,0 +1,55 @@+Name: hashed-storage+Version: 0.3+License: BSD3+Copyright: 2009 Petr Rockai <me@mornfall.net>+Author: Petr Rockai <me@mornfall.net>+Maintainer: Petr Rockai <me@mornfall.net>+Synopsis: Hashed file storage support code.+Description:+ Support code for reading and manipulating hashed file storage (where each+ file and directory is associated with a cryptographic hash, for+ corruption-resistant storage and fast comparisons).+ .+ The supported storage formats include darcs hashed pristine, a plain+ filesystem tree and an indexed plain tree (where the index maintains hashes+ of the plain files and directories).++Category: System+Build-Type: Custom+Cabal-Version: >=1.2++extra-source-files: Bundled/sha2.h++Library+ ghc-options: -Wall -O2+ ghc-prof-options: -prof -auto-all -O2++ Exposed-Modules:+ Storage.Hashed+ Storage.Hashed.AnchoredPath+ Storage.Hashed.Tree+ Storage.Hashed.Index+ Storage.Hashed.Diff+ Storage.Hashed.Monad++ Other-Modules:+ Storage.Hashed.Utils+ Storage.Hashed.Test++ Build-Depends: base, directory, filepath,+ bytestring, bytestring-mmap,+ zlib, lcs, binary, containers,+ mtl, extensible-exceptions,+ mmap++ other-modules: Bundled.SHA256+ Bundled.Posix+ c-sources: Bundled/sha2.c++Executable hashed-storage-test+ ghc-options: -O2+ ghc-prof-options: -prof -auto-all -O2+ other-modules: Bundled.Posix+ c-sources: Bundled/sha2.c+ Main-Is: test.hs+ Build-Depends: HUnit, process >= 1.0.1
+ test.hs view
@@ -0,0 +1,6 @@+import Storage.Hashed.Test+import Test.HUnit++main = do runTestTT tests_darcs_basic+ runTestTT tests_tree_index+ runTestTT tests_generic