diff --git a/Bundled/Posix.hsc b/Bundled/Posix.hsc new file mode 100644 --- /dev/null +++ b/Bundled/Posix.hsc @@ -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 + +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 #-} diff --git a/Bundled/SHA256.hs b/Bundled/SHA256.hs new file mode 100644 --- /dev/null +++ b/Bundled/SHA256.hs @@ -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 , Matthew Sackman +-- , 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 () + diff --git a/Bundled/sha2.c b/Bundled/sha2.c new file mode 100644 --- /dev/null +++ b/Bundled/sha2.c @@ -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 + * 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 + +#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 +#include + +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 */ + diff --git a/Bundled/sha2.h b/Bundled/sha2.h new file mode 100644 --- /dev/null +++ b/Bundled/sha2.h @@ -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 + * 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 */ + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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" diff --git a/Storage/Hashed.hs b/Storage/Hashed.hs new file mode 100644 --- /dev/null +++ b/Storage/Hashed.hs @@ -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) + diff --git a/Storage/Hashed/AnchoredPath.hs b/Storage/Hashed/AnchoredPath.hs new file mode 100644 --- /dev/null +++ b/Storage/Hashed/AnchoredPath.hs @@ -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 ] diff --git a/Storage/Hashed/Diff.hs b/Storage/Hashed/Diff.hs new file mode 100644 --- /dev/null +++ b/Storage/Hashed/Diff.hs @@ -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 ] diff --git a/Storage/Hashed/Index.hs b/Storage/Hashed/Index.hs new file mode 100644 --- /dev/null +++ b/Storage/Hashed/Index.hs @@ -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 diff --git a/Storage/Hashed/Monad.hs b/Storage/Hashed/Monad.hs new file mode 100644 --- /dev/null +++ b/Storage/Hashed/Monad.hs @@ -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 diff --git a/Storage/Hashed/Test.hs b/Storage/Hashed/Test.hs new file mode 100644 --- /dev/null +++ b/Storage/Hashed/Test.hs @@ -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") diff --git a/Storage/Hashed/Tree.hs b/Storage/Hashed/Tree.hs new file mode 100644 --- /dev/null +++ b/Storage/Hashed/Tree.hs @@ -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." diff --git a/Storage/Hashed/Utils.hs b/Storage/Hashed/Utils.hs new file mode 100644 --- /dev/null +++ b/Storage/Hashed/Utils.hs @@ -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) + diff --git a/hashed-storage.cabal b/hashed-storage.cabal new file mode 100644 --- /dev/null +++ b/hashed-storage.cabal @@ -0,0 +1,55 @@ +Name: hashed-storage +Version: 0.3 +License: BSD3 +Copyright: 2009 Petr Rockai +Author: Petr Rockai +Maintainer: Petr Rockai +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 diff --git a/test.hs b/test.hs new file mode 100644 --- /dev/null +++ b/test.hs @@ -0,0 +1,6 @@ +import Storage.Hashed.Test +import Test.HUnit + +main = do runTestTT tests_darcs_basic + runTestTT tests_tree_index + runTestTT tests_generic