From 6d35ffd86f37b0fa0b58fc8bd5f00a06db58227f Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 14 Jul 2025 16:00:07 +0200 Subject: [PATCH] add from hackage; update to support lts-23.24 --- Dockerfile | 17 +++ LICENSE | 30 +++++ Setup.hs | 2 + changes.md | 15 +++ filepath-crypto.cabal | 45 +++++++ packages.yaml | 13 ++ src/Data/Binary/SerializationLength.hs | 24 ++++ src/Data/Binary/SerializationLength/Class.hs | 13 ++ src/Data/Binary/SerializationLength/TH.hs | 23 ++++ src/System/FilePath/Cryptographic.hs | 121 ++++++++++++++++++ .../Cryptographic/ImplicitNamespace.hs | 20 +++ stack.yaml | 9 ++ 12 files changed, 332 insertions(+) create mode 100644 Dockerfile create mode 100644 LICENSE create mode 100644 Setup.hs create mode 100644 changes.md create mode 100644 filepath-crypto.cabal create mode 100644 packages.yaml create mode 100644 src/Data/Binary/SerializationLength.hs create mode 100644 src/Data/Binary/SerializationLength/Class.hs create mode 100644 src/Data/Binary/SerializationLength/TH.hs create mode 100644 src/System/FilePath/Cryptographic.hs create mode 100644 src/System/FilePath/Cryptographic/ImplicitNamespace.hs create mode 100644 stack.yaml diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 0000000..0fe3305 --- /dev/null +++ b/Dockerfile @@ -0,0 +1,17 @@ +FROM haskell:9.8.4 + +WORKDIR /opt/filepath-crypto + +# RUN stack install --resolver lts-24.0 --compiler ghc-9.10.1 hpack + +# Add just the .cabal file to capture dependencies +# COPY ./filepath-crypto.cabal /opt/filepath-crypto/filepath-crypto.cabal + +# Docker will cache this command as a layer, freeing us up to +# modify source code without re-installing dependencies +# (unless the .cabal file changes!) + +# Add and Install Application Code +COPY . /opt/filepath-crypto +# RUN stack build --resolver lts-24.0 --only-dependencies -j4 +RUN stack build --resolver lts-23.24 --compiler ghc-9.8.4 filepath-crypto \ No newline at end of file diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..4522849 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Gregor Kleen + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Gregor Kleen nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT +OWNER 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changes.md b/changes.md new file mode 100644 index 0000000..79755e0 --- /dev/null +++ b/changes.md @@ -0,0 +1,15 @@ +# 0.1.0.0 + - Add support for 'cryptoids-class' + +# 0.0.0.3 + - Got rid of `encoding` + +# 0.0.0.2 + - Improved documentation + +# 0.0.0.1 + - Improved documentation + +# 0.0.0.0 + +First published version diff --git a/filepath-crypto.cabal b/filepath-crypto.cabal new file mode 100644 index 0000000..1707052 --- /dev/null +++ b/filepath-crypto.cabal @@ -0,0 +1,45 @@ +name: filepath-crypto +version: 0.2.0.0 +cabal-version: >=1.10 +build-type: Simple +license: BSD3 +license-file: LICENSE +maintainer: Gregor Kleen +synopsis: Reversable and secure encoding of object ids as filepaths +category: cryptography +author: Gregor Kleen +extra-source-files: + changes.md + +source-repository head + type: git + location: https://git.rheperire.org/cryptoids/filepath-crypto + +library + exposed-modules: + System.FilePath.Cryptographic + System.FilePath.Cryptographic.ImplicitNamespace + Data.Binary.SerializationLength + Data.Binary.SerializationLength.TH + build-depends: + base >=4.10.1.0 && <5, + binary >=0.8.5.1 && <0.9, + bytestring >=0.10.8.2 && <0.13, + case-insensitive >=1.2.0.10 && <2, + cryptoids >=0.6.0.0 && <0.7, + exceptions >=0.8.3 && <0.11, + filepath >=1.4.1.2 && <2, + sandi >=0.4.1 && <0.6, + template-haskell >=2.12.0.0 && <3 + default-language: Haskell2010 + default-extensions: KindSignatures ViewPatterns FlexibleContexts + GeneralizedNewtypeDeriving PatternGuards RecordWildCards DataKinds + DeriveDataTypeable DeriveGeneric FlexibleInstances + MultiParamTypeClasses TypeFamilies ConstraintKinds + other-extensions: ScopedTypeVariables + hs-source-dirs: src + other-modules: + Data.Binary.SerializationLength.Class + Paths_filepath_crypto + ghc-options: -Wall -fno-warn-name-shadowing + diff --git a/packages.yaml b/packages.yaml new file mode 100644 index 0000000..e63cf47 --- /dev/null +++ b/packages.yaml @@ -0,0 +1,13 @@ +name: filepath-crypto +version: 0.2.0.0 + +dependencies: + - base >=4.10.1.0 && <5 + - binary >=0.8.5.1 && <0.9 + - bytestring >=0.10.8.2 && <0.13 + - case-insensitive >=1.2.0.10 && <2 + - cryptoids >=0.6.0.0 && <0.7 + - exceptions >=0.8.3 && <0.9 + - filepath >=1.4.1.2 && <2 + - sandi >=0.4.1 && <0.6 + - template-haskell >=2.12.0.0 && <3 \ No newline at end of file diff --git a/src/Data/Binary/SerializationLength.hs b/src/Data/Binary/SerializationLength.hs new file mode 100644 index 0000000..658f783 --- /dev/null +++ b/src/Data/Binary/SerializationLength.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Binary.SerializationLength + ( HasFixedSerializationLength(..) + ) where + +import Data.Binary.SerializationLength.Class +import Data.Binary.SerializationLength.TH + +import Data.Int +import Data.Word + +$(hasFixedSerializationLength ''Word8 1) +$(hasFixedSerializationLength ''Word16 2) +$(hasFixedSerializationLength ''Word32 4) +$(hasFixedSerializationLength ''Word64 8) + +$(hasFixedSerializationLength ''Int8 1) +$(hasFixedSerializationLength ''Int16 2) +$(hasFixedSerializationLength ''Int32 4) +$(hasFixedSerializationLength ''Int64 8) diff --git a/src/Data/Binary/SerializationLength/Class.hs b/src/Data/Binary/SerializationLength/Class.hs new file mode 100644 index 0000000..f9d9fea --- /dev/null +++ b/src/Data/Binary/SerializationLength/Class.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies #-} + +module Data.Binary.SerializationLength.Class + ( HasFixedSerializationLength(..) + ) where + +import GHC.TypeLits + +-- | The class of types for which the result of serialization with @Data.Binary@ +-- is known statically to be of a certain length +class KnownNat (SerializationLength a) => HasFixedSerializationLength a where + -- | The 'SerializationLength' is given in bytes at type level + type SerializationLength a :: Nat diff --git a/src/Data/Binary/SerializationLength/TH.hs b/src/Data/Binary/SerializationLength/TH.hs new file mode 100644 index 0000000..b151477 --- /dev/null +++ b/src/Data/Binary/SerializationLength/TH.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +module Data.Binary.SerializationLength.TH + ( hasFixedSerializationLength + ) where + +import Language.Haskell.TH + +import Data.Binary.SerializationLength.Class + + +hasFixedSerializationLength :: Name -> Integer -> DecsQ +-- | Shorthand for defining instances of 'HasFixedSerializationLength', morally: +-- +-- > hasFixedSerializationLength typeName byteN = [d| +-- > instance HasFixedSerializiationLength $(typeName) where +-- > type SerializationLength $(typeName) = $(byteN) +-- > |] +hasFixedSerializationLength (return . ConT -> t) (return . LitT . NumTyLit -> i) = + [d| + instance HasFixedSerializationLength $(t) where + type SerializationLength $(t) = $(i) + |] diff --git a/src/System/FilePath/Cryptographic.hs b/src/System/FilePath/Cryptographic.hs new file mode 100644 index 0000000..ce18b03 --- /dev/null +++ b/src/System/FilePath/Cryptographic.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| +Description: Reversably generate filepaths from arbitrary serializable types in a secure fashion +License: BSD3 + +Given a value of a serializable type (like 'Int') we perform serialization and +compute a cryptographic hash of the associated namespace (carried as a phantom +type of kind 'Symbol'). +The serialized payload is encrypted using a symmetric cipher in CBC mode using +the hashed namespace as an initialization vector (IV). + +The ciphertext is then +-encoded +and padding stripped. + +Rather than being indicated by the amount of padding, the length of the +serialized plaintext is instead carried at the type level within +'CryptoFileName' (analogously to the namespace). +Mismatches in serialized plaintext length are checked for but are /not/ +guaranteed to cause runtime errors in all cases. + +Since the serialized payload is padded to the length of the next cipher block we +can detect namespace mismatches by checking that all bytes expected to have been +inserted during padding are nil. +The probability of detecting a namespace mismatch is thus \(1 - 2^{b \left \lceil \frac{l}{b} \right \rceil - l}\) +where \(l\) is the length of the serialized payload and \(b\) the length of a +ciphertext block (both in bits). +-} +module System.FilePath.Cryptographic + ( CryptoFileName + , HasCryptoFileName + , module Data.Binary.SerializationLength + , encrypt + , decrypt + , module Data.CryptoID.Poly + ) where + +import Data.CryptoID.Poly hiding (encrypt, decrypt) +import Data.CryptoID.ByteString (cipherBlockSize) +import qualified Data.CryptoID.Poly as Poly (encrypt, decrypt) +import Data.CryptoID.Class (HasCryptoID) +import qualified Data.CryptoID.Class as Class (HasCryptoID(..)) + +import System.FilePath (FilePath) +import qualified Codec.Binary.Base32 as Base32 +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Binary +import Data.Binary.SerializationLength +import Data.Char (toUpper) + +import Data.Ratio ((%)) +import Data.List + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as ByteString.Char8 + +import Control.Monad +import Control.Monad.Catch + +import Data.Proxy +import GHC.TypeLits + + +type CryptoFileName (namespace :: Symbol) = CryptoID namespace (CI FilePath) +type HasCryptoFileName (namespace :: Symbol) = HasCryptoID namespace (CI FilePath) + + +paddedLength :: Integral a => a -> a +-- | Round up to nearest multiple of 'cipherBlockSize' +paddedLength l = bs * ceiling (l % bs) + where bs = fromIntegral cipherBlockSize + +-- | Encrypt an arbitrary serializable value +-- +-- We only expect to fail if the given value is not serialized in such a fashion +-- that it meets the expected length given at type level. +encrypt :: forall a m namespace. + ( KnownSymbol namespace + , Binary a + , MonadThrow m + , HasFixedSerializationLength a + ) => CryptoIDKey -> a -> m (CryptoFileName namespace) +encrypt = Poly.encrypt determineLength $ return . encode + where + determineLength str = do + let l = ByteString.length str + unless (fromIntegral l == natVal (Proxy :: Proxy (SerializationLength a))) $ + throwM $ CiphertextConversionFailed str + return . Just $ paddedLength l + encode str = CI.mk . dropWhileEnd (== '=') . ByteString.Char8.unpack $ Base32.encode str + + +-- | Decrypt an arbitrary serializable value +-- +-- Since no integrity guarantees can be made (we do not sign the values we +-- 'encrypt') it is likely that deserialization will fail emitting +-- 'DeserializationError' or 'InvalidNamespaceDetected'. +decrypt :: forall a m namespace. + ( KnownSymbol namespace + , Binary a + , MonadThrow m + , HasFixedSerializationLength a + ) => CryptoIDKey -> CryptoFileName namespace -> m a +decrypt = Poly.decrypt $ (\str -> either (const . throwM $ CiphertextConversionFailed str) return $ Base32.decode str) . ByteString.Char8.pack . padding (natVal (Proxy :: Proxy (SerializationLength a))) . map toUpper . CI.original + where + padding l str = str ++ replicate (genericIndex paddingTable $ l' `mod` 5) '=' + where + l' = paddedLength l + paddingTable = [0, 6, 4, 3, 1] + +instance ( MonadCrypto m + , MonadCryptoKey m ~ CryptoIDKey + , KnownSymbol namespace + , Binary a + , HasFixedSerializationLength a + ) => HasCryptoID namespace (CI FilePath) a m where + encrypt = cryptoIDKey . flip encrypt + decrypt = cryptoIDKey . flip decrypt diff --git a/src/System/FilePath/Cryptographic/ImplicitNamespace.hs b/src/System/FilePath/Cryptographic/ImplicitNamespace.hs new file mode 100644 index 0000000..adf9e53 --- /dev/null +++ b/src/System/FilePath/Cryptographic/ImplicitNamespace.hs @@ -0,0 +1,20 @@ +{-| +Description: Reversably generate filepaths from arbitrary serializable types with implicit type level nonces +License: BSD3 +-} +module System.FilePath.Cryptographic.ImplicitNamespace + ( CryptoFileName + , HasCryptoFileName + , module System.FilePath.Cryptographic + , module Data.CryptoID.Class.ImplicitNamespace + ) where + +import Data.CryptoID.Class.ImplicitNamespace + +import System.FilePath.Cryptographic hiding (encrypt, decrypt, CryptoID, HasCryptoID, CryptoFileName, HasCryptoFileName) + +import System.FilePath (FilePath) +import Data.CaseInsensitive (CI) + +type CryptoFileName plaintext = CryptoID (CI FilePath) plaintext +type HasCryptoFileName plaintext = HasCryptoID (CI FilePath) plaintext diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..060c4f0 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,9 @@ +snapshot: lts-24.0 +compiler: ghc-9.10.1 + +packages: + - . + +extra-deps: + - git: https://gitea.uniworx.systems/haskell/cryptoid.git + commit: 1d3f4843377664f1679f2a18ca3160a0d02b8b1b \ No newline at end of file