diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2017 Tweag I/O + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/cas-hashable.cabal b/cas-hashable.cabal new file mode 100644 --- /dev/null +++ b/cas-hashable.cabal @@ -0,0 +1,47 @@ +Name: cas-hashable +Version: 1.0.0 +Synopsis: A hashing class for content-addressed storage +Description: + A hashing class for content-addressed storage. Content can be hashed either by value or through an IO action. Part of the funflow ecosystem. +License: MIT +License-file: LICENSE +Author: Tom Nielsen, Nicholas Clarke, Andreas Herrmann +Maintainer: yves.pares@tweag.io +build-type: Simple +Cabal-Version: >= 1.10 +homepage: https://github.com/tweag/funflow +bug-reports: https://github.com/tweag/funflow +category: Control +Tested-With: GHC == 7.8.4, GHC == 7.10.2, GHC == 7.10.3, GHC == 8.0.1 + +extra-source-files: + changelog.md + +Library + ghc-options: -Wall -fno-warn-type-defaults + hs-source-dirs: src + default-language: Haskell2010 + + Exposed-modules: Data.CAS.ContentHashable + , Data.CAS.StoreOrphans + Build-depends: + base >= 4.6 && <5 + , aeson >= 1.2.3.0 + , bytestring + , clock + , containers + , cryptonite + , ghc-prim + , hashable + , integer-gmp + , memory + , path > 0.6.0 + , path-io + , safe-exceptions + , scientific + , store + , text + , time + , unix + , unordered-containers + , vector diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md diff --git a/src/Data/CAS/ContentHashable.hs b/src/Data/CAS/ContentHashable.hs new file mode 100644 --- /dev/null +++ b/src/Data/CAS/ContentHashable.hs @@ -0,0 +1,537 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UnboxedTuples #-} + +-- | 'ContentHashable' provides a hashing function suitable for use in the +-- Funflow content store. +-- +-- This behaves as does a normal hashing function on Haskell types. However, +-- on path types, this instead calculates a hash based on the contents of the +-- file or directory referenced. +-- +-- We also export the 'ExternallyAssuredFile' and 'ExternallyAssuredDirectory' +-- types. These instead use the path, file size and modification time to control +-- the hash. +module Data.CAS.ContentHashable + ( ContentHash + , toBytes + , fromBytes + , ContentHashable (..) + , contentHashUpdate_binaryFile + , contentHashUpdate_byteArray# + , contentHashUpdate_fingerprint + , contentHashUpdate_primitive + , contentHashUpdate_storable + + , FileContent (..) + , DirectoryContent (..) + + , ExternallyAssuredFile(..) + , ExternallyAssuredDirectory(..) + + , encodeHash + , decodeHash + , hashToPath + , pathToHash + + , SHA256 + , Context + , Digest + ) where + + +import Control.Exception.Safe (catchJust) +import Control.Monad (foldM, (>=>)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Crypto.Hash (Context, Digest, SHA256, + digestFromByteString, + hashFinalize, hashInit, + hashUpdate) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import Data.Bits (shiftL) +import Data.ByteArray (Bytes, MemView (MemView), + allocAndFreeze, convert) +import Data.ByteArray.Encoding (Base (Base16), + convertFromBase, + convertToBase) +import qualified Data.ByteString as BS +import Data.ByteString.Builder.Extra (defaultChunkSize) +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as BSL +import Data.CAS.StoreOrphans () +import Data.Foldable (foldlM) +import Data.Functor.Contravariant +import qualified Data.Hashable +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.HashSet as HashSet +import Data.Int +import Data.List (sort) +import Data.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Ratio +import Data.Scientific +import Data.Store (Store (..), peekException) +import qualified Data.Text as T +import qualified Data.Text.Array as TA +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Internal as T +import qualified Data.Text.Lazy as TL +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Typeable +import qualified Data.Vector as V +import Data.Word +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (castPtr) +import Foreign.Storable (Storable, sizeOf) +import GHC.Fingerprint +import GHC.Generics +import GHC.Integer.GMP.Internals (BigNat (..), Integer (..)) +import GHC.Natural (Natural (..)) +import GHC.Prim (ByteArray#, + copyByteArrayToAddr#, + sizeofByteArray#) +import GHC.Ptr (Ptr (Ptr)) +import GHC.Types (IO (IO), Int (I#), Word (W#)) +import qualified Path +import qualified Path.Internal +import qualified Path.IO +import System.IO (IOMode (ReadMode), + withBinaryFile) +import System.IO.Error (isPermissionError) +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Files (fileSize, getFileStatus) + + +newtype ContentHash = ContentHash { unContentHash :: Digest SHA256 } + deriving (Eq, Ord, Generic) + +instance Aeson.FromJSON ContentHash where + parseJSON (Aeson.String s) + | Just h <- decodeHash (TE.encodeUtf8 s) = pure h + | otherwise = fail "Invalid hash encoding" + parseJSON invalid + = Aeson.typeMismatch "ContentHash" invalid +instance Aeson.ToJSON ContentHash where + toJSON = Aeson.String . TE.decodeUtf8 . encodeHash + +instance Data.Hashable.Hashable ContentHash where + hashWithSalt s = Data.Hashable.hashWithSalt s . encodeHash + +instance Show ContentHash where + showsPrec d h = showParen (d > app_prec) + $ showString "ContentHash \"" + . (showString $ C8.unpack $ encodeHash h) + . showString "\"" + where app_prec = 10 + +instance Store ContentHash where + size = contramap toBytes size + peek = fromBytes <$> peek >>= \case + Nothing -> peekException "Store ContentHash: Illegal digest" + Just x -> return x + poke = poke . toBytes + +toBytes :: ContentHash -> BS.ByteString +toBytes = convert . unContentHash + +fromBytes :: BS.ByteString -> Maybe ContentHash +fromBytes bs = ContentHash <$> digestFromByteString bs + +hashEncoding :: Base +hashEncoding = Base16 + +-- | File path appropriate encoding of a hash +encodeHash :: ContentHash -> BS.ByteString +encodeHash = convertToBase hashEncoding . toBytes + +-- | Inverse of 'encodeHash' if given a valid input. +-- +-- prop> decodeHash (encodeHash x) = Just x +decodeHash :: BS.ByteString -> Maybe ContentHash +decodeHash bs = case convertFromBase hashEncoding bs of + Left _ -> Nothing + Right x -> fromBytes x + +-- | File path appropriate encoding of a hash +hashToPath :: ContentHash -> Path.Path Path.Rel Path.Dir +hashToPath h = + case Path.parseRelDir $ C8.unpack $ encodeHash h of + Nothing -> error + "[ContentHashable.hashToPath] \ + \Failed to convert hash to directory name" + Just dir -> dir + + +-- | Inverse of 'hashToPath' if given a valid input. +-- +-- prop> pathToHash (hashToPath x) = Just x +pathToHash :: FilePath -> Maybe ContentHash +pathToHash = decodeHash . C8.pack + + +class Monad m => ContentHashable m a where + + -- | Update a hash context based on the given value. + -- + -- See 'Crypto.Hash.hashUpdate'. + -- + -- XXX: Consider swapping the arguments. + contentHashUpdate :: Context SHA256 -> a -> m (Context SHA256) + + default contentHashUpdate :: (Generic a, GContentHashable m (Rep a)) + => Context SHA256 -> a -> m (Context SHA256) + contentHashUpdate ctx a = gContentHashUpdate ctx (from a) + + -- | Generate hash of the given value. + -- + -- See 'Crypto.Hash.hash'. + contentHash :: a -> m ContentHash + contentHash x = ContentHash . hashFinalize <$> contentHashUpdate hashInit x + + +-- | Update hash context based on binary in memory representation due to 'Foreign.Storable.Storable'. +-- +-- XXX: Do we need to worry about endianness? +contentHashUpdate_storable :: (Monad m, Storable a) => Context SHA256 -> a -> m (Context SHA256) +contentHashUpdate_storable ctx a = + return . unsafePerformIO $ with a (\p -> pure $! hashUpdate ctx (MemView (castPtr p) (sizeOf a))) + +-- | Update hash context based on a type's 'GHC.Fingerprint.Type.Fingerprint'. +-- +-- The fingerprint is constructed from the library-name, module-name, and name of the type itself. +contentHashUpdate_fingerprint :: (Monad m, Typeable a) => Context SHA256 -> a -> m (Context SHA256) +contentHashUpdate_fingerprint ctx = contentHashUpdate ctx . typeRepFingerprint . typeOf + +-- | Update hash context by combining 'contentHashUpdate_fingerprint' and 'contentHashUpdate_storable'. +-- Intended for primitive types like 'Int'. +contentHashUpdate_primitive :: (Monad m, Typeable a, Storable a) => Context SHA256 -> a -> m (Context SHA256) +contentHashUpdate_primitive ctx a = + flip contentHashUpdate_fingerprint a >=> flip contentHashUpdate_storable a $ ctx + +-- | Update hash context based on binary contents of the given file. +contentHashUpdate_binaryFile :: Context SHA256 -> FilePath -> IO (Context SHA256) +contentHashUpdate_binaryFile ctx0 fp = withBinaryFile fp ReadMode $ \h -> + let go ctx = do + chunk <- BS.hGetSome h defaultChunkSize + if BS.null chunk then + pure ctx + else + go $! hashUpdate ctx chunk + in go ctx0 + +-- | Update hash context based on 'GHC.Prim.ByteArray#' +-- by copying into a newly allocated 'Data.ByteArray.Bytes' +-- and updating the hash context from there. +-- +-- XXX: @'GHC.Prim.byteArrayContents#' :: 'GHC.Prim.ByteArray#' -> 'GHC.Prim.Addr#'@ +-- could be used together with 'Data.ByteArray.MemView' instead. +-- However, 'GHC.Prim.byteArrayContents#' explicitly says, that it is only safe to use +-- on a pinned 'GHC.Prim.ByteArray#'. +contentHashUpdate_byteArray# :: ByteArray# -> Int -> Int -> Context SHA256 -> Context SHA256 +contentHashUpdate_byteArray# ba (I# off) (I# len) ctx = hashUpdate ctx $ + allocAndFreeze @Bytes (I# len) $ \(Ptr addr) -> IO $ \s -> + (# copyByteArrayToAddr# ba off addr len s, () #) + +-- | Update hash context based on the contents of a strict 'Data.Text.Text'. +contentHashUpdate_text :: Context SHA256 -> T.Text -> Context SHA256 +contentHashUpdate_text ctx (T.Text arr off_ len_) = + contentHashUpdate_byteArray# (TA.aBA arr) off len ctx + where + off = off_ `shiftL` 1 -- convert from 'Word16' to 'Word8' + len = len_ `shiftL` 1 -- convert from 'Word16' to 'Word8' + +instance Monad m => ContentHashable m Fingerprint where + contentHashUpdate ctx (Fingerprint a b) = flip contentHashUpdate_storable a >=> flip contentHashUpdate_storable b $ ctx + +instance Monad m => ContentHashable m Bool where contentHashUpdate = contentHashUpdate_primitive + +instance Monad m => ContentHashable m Char where contentHashUpdate = contentHashUpdate_primitive + +instance Monad m => ContentHashable m Int where contentHashUpdate = contentHashUpdate_primitive +instance Monad m => ContentHashable m Int8 where contentHashUpdate = contentHashUpdate_primitive +instance Monad m => ContentHashable m Int16 where contentHashUpdate = contentHashUpdate_primitive +instance Monad m => ContentHashable m Int32 where contentHashUpdate = contentHashUpdate_primitive +instance Monad m => ContentHashable m Int64 where contentHashUpdate = contentHashUpdate_primitive + +instance Monad m => ContentHashable m Word where contentHashUpdate = contentHashUpdate_primitive +instance Monad m => ContentHashable m Word8 where contentHashUpdate = contentHashUpdate_primitive +instance Monad m => ContentHashable m Word16 where contentHashUpdate = contentHashUpdate_primitive +instance Monad m => ContentHashable m Word32 where contentHashUpdate = contentHashUpdate_primitive +instance Monad m => ContentHashable m Word64 where contentHashUpdate = contentHashUpdate_primitive + +instance Monad m => ContentHashable m Float where contentHashUpdate = contentHashUpdate_primitive +instance Monad m => ContentHashable m Double where contentHashUpdate = contentHashUpdate_primitive + +instance (ContentHashable m n, Typeable n) => ContentHashable m (Ratio n) where + contentHashUpdate ctx x = + flip contentHashUpdate_fingerprint x + >=> flip contentHashUpdate (numerator x) + >=> flip contentHashUpdate (denominator x) + $ ctx + +instance Monad m => ContentHashable m Scientific where + contentHashUpdate ctx x = + flip contentHashUpdate_fingerprint x + >=> flip contentHashUpdate (toRational x) + $ ctx + +instance Monad m => ContentHashable m Integer where + contentHashUpdate ctx n = ($ ctx) $ + flip contentHashUpdate_fingerprint n >=> case n of + S# i -> + pure . flip hashUpdate (C8.pack "S") -- tag constructur + >=> flip contentHashUpdate_storable (I# i) -- hash field + Jp# (BN# ba) -> + pure . flip hashUpdate (C8.pack "L") -- tag constructur + >=> pure . contentHashUpdate_byteArray# ba 0 (I# (sizeofByteArray# ba)) -- hash field + Jn# (BN# ba) -> + pure . flip hashUpdate (C8.pack "N") -- tag constructur + >=> pure . contentHashUpdate_byteArray# ba 0 (I# (sizeofByteArray# ba)) -- hash field + +instance Monad m => ContentHashable m Natural where + contentHashUpdate ctx n = ($ ctx) $ + flip contentHashUpdate_fingerprint n >=> case n of + NatS# w -> + pure . flip hashUpdate (C8.pack "S") -- tag constructur + >=> flip contentHashUpdate_storable (W# w) -- hash field + NatJ# (BN# ba) -> + pure . flip hashUpdate (C8.pack "L") -- tag constructur + >=> pure . contentHashUpdate_byteArray# ba 0 (I# (sizeofByteArray# ba)) -- hash field + +instance Monad m => ContentHashable m BS.ByteString where + contentHashUpdate ctx s = + flip contentHashUpdate_fingerprint s + >=> pure . flip hashUpdate s $ ctx + +instance Monad m => ContentHashable m BSL.ByteString where + contentHashUpdate ctx s = + flip contentHashUpdate_fingerprint s + >=> pure . flip (BSL.foldlChunks hashUpdate) s $ ctx + +instance Monad m => ContentHashable m T.Text where + contentHashUpdate ctx s = + flip contentHashUpdate_fingerprint s + >=> pure . flip contentHashUpdate_text s $ ctx + +instance Monad m => ContentHashable m TL.Text where + contentHashUpdate ctx s = + flip contentHashUpdate_fingerprint s + >=> pure . flip (TL.foldlChunks contentHashUpdate_text) s $ ctx + +instance (Typeable k, Typeable v, ContentHashable m k, ContentHashable m v) + => ContentHashable m (Map k v) where + contentHashUpdate ctx m = + flip contentHashUpdate_fingerprint m + >=> flip contentHashUpdate (Map.toList m) $ ctx + +instance (Typeable k, Typeable v, ContentHashable m k, ContentHashable m v) + => ContentHashable m (HashMap.HashMap k v) where + contentHashUpdate ctx m = + flip contentHashUpdate_fingerprint m + -- XXX: The order of the list is unspecified. + >=> flip contentHashUpdate (HashMap.toList m) $ ctx + +instance (Typeable v, ContentHashable m v) + => ContentHashable m (HashSet.HashSet v) where + contentHashUpdate ctx s = + flip contentHashUpdate_fingerprint s + -- XXX: The order of the list is unspecified. + >=> flip contentHashUpdate (HashSet.toList s) $ ctx + +instance (Typeable a, ContentHashable m a) + => ContentHashable m [a] where + contentHashUpdate ctx l = + flip contentHashUpdate_fingerprint l + >=> flip (foldM contentHashUpdate) l $ ctx + +instance (Typeable a, ContentHashable m a) + => ContentHashable m (NonEmpty a) where + contentHashUpdate ctx l = + flip contentHashUpdate_fingerprint l + >=> flip (foldlM contentHashUpdate) l $ ctx + +instance (Typeable a, ContentHashable m a) + => ContentHashable m (V.Vector a) where + contentHashUpdate ctx v = + flip contentHashUpdate_fingerprint v + >=> flip (V.foldM' contentHashUpdate) v $ ctx + +instance Monad m => ContentHashable m () +instance (ContentHashable m a, ContentHashable m b) => ContentHashable m (a, b) +instance (ContentHashable m a, ContentHashable m b, ContentHashable m c) => ContentHashable m (a, b, c) +instance (ContentHashable m a, ContentHashable m b, ContentHashable m c, ContentHashable m d) => ContentHashable m (a, b, c, d) +instance (ContentHashable m a, ContentHashable m b, ContentHashable m c, ContentHashable m d, ContentHashable m e) => ContentHashable m (a, b, c, d, e) +instance (Monad m, ContentHashable m a, ContentHashable m b, ContentHashable m c, ContentHashable m d, ContentHashable m e, ContentHashable m f) => ContentHashable m (a, b, c, d, e, f) +instance (Monad m, ContentHashable m a, ContentHashable m b, ContentHashable m c, ContentHashable m d, ContentHashable m e, ContentHashable m f, ContentHashable m g) => ContentHashable m (a, b, c, d, e, f, g) + +instance ContentHashable m a => ContentHashable m (Maybe a) + +instance (ContentHashable m a, ContentHashable m b) => ContentHashable m (Either a b) + +instance Monad m => ContentHashable m Aeson.Value + + +class Monad m => GContentHashable m f where + gContentHashUpdate :: Context SHA256 -> f a -> m (Context SHA256) + +instance Monad m => GContentHashable m V1 where + gContentHashUpdate ctx _ = pure ctx + +instance Monad m => GContentHashable m U1 where + gContentHashUpdate ctx U1 = pure ctx + +instance ContentHashable m c => GContentHashable m (K1 i c) where + gContentHashUpdate ctx x = contentHashUpdate ctx (unK1 x) + +instance (Constructor c, GContentHashable m f) => GContentHashable m (C1 c f) where + gContentHashUpdate ctx0 x = gContentHashUpdate nameCtx (unM1 x) + where nameCtx = hashUpdate ctx0 $ C8.pack (conName x) + +instance (Datatype d, GContentHashable m f) => GContentHashable m (D1 d f) where + gContentHashUpdate ctx0 x = gContentHashUpdate packageCtx (unM1 x) + where + datatypeCtx = hashUpdate ctx0 $ C8.pack (datatypeName x) + moduleCtx = hashUpdate datatypeCtx $ C8.pack (datatypeName x) + packageCtx = hashUpdate moduleCtx $ C8.pack (datatypeName x) + +instance GContentHashable m f => GContentHashable m (S1 s f) where + gContentHashUpdate ctx x = gContentHashUpdate ctx (unM1 x) + +instance (GContentHashable m a, GContentHashable m b) => GContentHashable m (a :*: b) where + gContentHashUpdate ctx (x :*: y) = gContentHashUpdate ctx x >>= flip gContentHashUpdate y + +instance (GContentHashable m a, GContentHashable m b) => GContentHashable m (a :+: b) where + gContentHashUpdate ctx (L1 x) = gContentHashUpdate ctx x + gContentHashUpdate ctx (R1 x) = gContentHashUpdate ctx x + +-- XXX: Do we need this? +-- instance GContentHashable (a :.: b) where +-- gContentHashUpdate ctx x = _ (unComp1 x) + + +instance (Monad m, Typeable b, Typeable t) => ContentHashable m (Path.Path b t) where + contentHashUpdate ctx p@(Path.Internal.Path fp) = + flip contentHashUpdate_fingerprint p + >=> flip contentHashUpdate fp + $ ctx + + +-- | Path to a regular file +-- +-- Only the file's content and its executable permission is taken into account +-- when generating the content hash. The path itself is ignored. +newtype FileContent = FileContent (Path.Path Path.Abs Path.File) + +instance ContentHashable IO FileContent where + + contentHashUpdate ctx (FileContent fp) = do + exec <- Path.IO.executable <$> Path.IO.getPermissions fp + ctx' <- if exec then contentHashUpdate ctx () else pure ctx + contentHashUpdate_binaryFile ctx' (Path.fromAbsFile fp) + +-- | Path to a directory +-- +-- Only the contents of the directory and their path relative to the directory +-- are taken into account when generating the content hash. +-- The path to the directory is ignored. +newtype DirectoryContent = DirectoryContent (Path.Path Path.Abs Path.Dir) + +instance MonadIO m => ContentHashable m DirectoryContent where + + contentHashUpdate ctx0 (DirectoryContent dir0) = liftIO $ do + (dirs, files) <- Path.IO.listDir dir0 + ctx' <- foldM hashFile ctx0 (sort files) + foldM hashDir ctx' (sort dirs) + where + hashFile ctx fp = + -- XXX: Do we need to treat symbolic links specially? + flip contentHashUpdate (Path.filename fp) + >=> flip contentHashUpdate (FileContent fp) + $ ctx + hashDir ctx dir = + flip contentHashUpdate (Path.dirname dir) + >=> flip contentHashUpdate (DirectoryContent dir) + $ ctx + +instance Monad m => ContentHashable m UTCTime where + contentHashUpdate ctx utcTime = let + secondsSinceEpoch = fromEnum . utcTimeToPOSIXSeconds $ utcTime + in flip contentHashUpdate_fingerprint utcTime + >=> flip contentHashUpdate secondsSinceEpoch + $ ctx + +-- | Path to a file to be treated as _externally assured_. +-- +-- An externally assured file is handled in a somewhat 'cheating' way by +-- funflow. The 'ContentHashable' instance for such assumes that some external +-- agent guarantees the integrity of the file being referenced. Thus, rather +-- than hashing the file contents, we only consider its (absolute) path, size and +-- modification time, which can be rapidly looked up from filesystem metadata. +-- +-- For a similar approach, see the instance for 'ObjectInBucket' in +-- Control.Funflow.AWS.S3, where we exploit the fact that S3 is already +-- content hashed to avoid performing any hashing. +newtype ExternallyAssuredFile = ExternallyAssuredFile (Path.Path Path.Abs Path.File) + deriving (Generic, Show) + +instance Aeson.FromJSON ExternallyAssuredFile +instance Aeson.ToJSON ExternallyAssuredFile +instance Store ExternallyAssuredFile + +instance ContentHashable IO ExternallyAssuredFile where + contentHashUpdate ctx (ExternallyAssuredFile fp) = do + modTime <- Path.IO.getModificationTime fp + fSize <- fileSize <$> getFileStatus (Path.toFilePath fp) + flip contentHashUpdate fp + >=> flip contentHashUpdate modTime + >=> flip contentHashUpdate_storable fSize + $ ctx + + +-- | Path to a directory to be treated as _externally assured_. +-- +-- For an externally assured directory, we _do_ traverse its contents and verify +-- those as we would externally assured files, rather than just relying on the +-- directory path. Doing this traversal is pretty cheap, and it's quite likely +-- for directory contents to be modified without modifying the contents. +-- +-- If an item in the directory cannot be read due to lacking permissions, +-- then it will be ignored and not included in the hash. If the flow does not +-- have permissions to access the contents of a subdirectory, then these +-- contents cannot influence the outcome of a task and it is okay to exclude +-- them from the hash. In that case we only hash the name, as that could +-- influence the outcome of a task. +newtype ExternallyAssuredDirectory = ExternallyAssuredDirectory (Path.Path Path.Abs Path.Dir) + deriving (Generic, Show) + +instance Aeson.FromJSON ExternallyAssuredDirectory +instance Aeson.ToJSON ExternallyAssuredDirectory +instance Store ExternallyAssuredDirectory + +instance ContentHashable IO ExternallyAssuredDirectory where + contentHashUpdate ctx0 (ExternallyAssuredDirectory dir0) = do + -- Note that we don't bother looking at the relative directory paths and + -- including these in the hash. This is because the absolute hash gets + -- included every time we hash a file. + (dirs, files) <- Path.IO.listDir dir0 + ctx' <- foldM hashFile ctx0 (sort files) + foldM hashDir ctx' (sort dirs) + where + hashFile ctx fp = contentHashUpdate ctx (ExternallyAssuredFile fp) + `catchPermissionError` \_ -> contentHashUpdate ctx fp + hashDir ctx dir = contentHashUpdate ctx (ExternallyAssuredDirectory dir) + `catchPermissionError` \_ -> contentHashUpdate ctx dir + catchPermissionError = catchJust $ \e -> + if isPermissionError e then Just e else Nothing diff --git a/src/Data/CAS/StoreOrphans.hs b/src/Data/CAS/StoreOrphans.hs new file mode 100644 --- /dev/null +++ b/src/Data/CAS/StoreOrphans.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Dedicated module for orphan instances. +module Data.CAS.StoreOrphans where + +import Data.Functor.Contravariant +import Data.Store (Store) +import qualified Data.Store as Store +import qualified Path as Path +import qualified Path.Internal + +instance Store (Path.Path Path.Abs Path.File) where + size = contramap (\(Path.Internal.Path fp) -> fp) Store.size + peek = Path.Internal.Path <$> Store.peek + poke = Store.poke . (\(Path.Internal.Path fp) -> fp) +instance Store (Path.Path Path.Abs Path.Dir) where + size = contramap (\(Path.Internal.Path fp) -> fp) Store.size + peek = Path.Internal.Path <$> Store.peek + poke = Store.poke . (\(Path.Internal.Path fp) -> fp) +instance Store (Path.Path Path.Rel Path.File) where + size = contramap (\(Path.Internal.Path fp) -> fp) Store.size + peek = Path.Internal.Path <$> Store.peek + poke = Store.poke . (\(Path.Internal.Path fp) -> fp) +instance Store (Path.Path Path.Rel Path.Dir) where + size = contramap (\(Path.Internal.Path fp) -> fp) Store.size + peek = Path.Internal.Path <$> Store.peek + poke = Store.poke . (\(Path.Internal.Path fp) -> fp)