diff --git a/LICENSE b/LICENSE new file mode 100644 --- /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 --- /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 --- /dev/null +++ b/changes.md @@ -0,0 +1,3 @@ +# 0.0.0.0 + +First published version diff --git a/filepath-crypto.cabal b/filepath-crypto.cabal new file mode 100644 --- /dev/null +++ b/filepath-crypto.cabal @@ -0,0 +1,45 @@ +name: filepath-crypto +version: 0.0.0.0 +cabal-version: >=1.10 +build-type: Simple +license: BSD3 +license-file: LICENSE +maintainer: aethoago@141.li +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 + subdir: filepath-crypto + +library + exposed-modules: + System.FilePath.Cryptographic + Data.Binary.SerializationLength + Data.Binary.SerializationLength.TH + build-depends: + base >=4.9 && <4.11, + cryptoids-types ==0.0.0, + cryptoids ==0.4.0.*, + filepath >=1.4.1.1 && <1.5, + sandi >=0.4.1 && <0.5, + case-insensitive >=1.2.0.10 && <1.3, + binary >=0.8.3.0 && <0.9, + bytestring >=0.10.8.1 && <0.11, + exceptions >=0.8.3 && <0.9, + encoding >=0.8.2 && <0.9, + template-haskell >=2.11.0.0 && <2.13 + default-language: Haskell2010 + default-extensions: KindSignatures ViewPatterns FlexibleContexts + GeneralizedNewtypeDeriving PatternGuards RecordWildCards DataKinds + DeriveDataTypeable DeriveGeneric + other-extensions: ScopedTypeVariables + hs-source-dirs: src + other-modules: + Data.Binary.SerializationLength.Class + ghc-options: -Wall -fno-warn-name-shadowing + diff --git a/src/Data/Binary/SerializationLength.hs b/src/Data/Binary/SerializationLength.hs new file mode 100644 --- /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 --- /dev/null +++ b/src/Data/Binary/SerializationLength/Class.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies #-} + +module Data.Binary.SerializationLength.Class + ( HasFixedSerializationLength(..) + ) where + +import GHC.TypeLits + +class KnownNat (SerializationLength a) => HasFixedSerializationLength a where + type SerializationLength a :: Nat diff --git a/src/Data/Binary/SerializationLength/TH.hs b/src/Data/Binary/SerializationLength/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/SerializationLength/TH.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +module Data.Binary.SerializationLength.TH + ( hasFixedSerializationLength + ) where + +import Language.Haskell.TH + +import Data.Binary.SerializationLength.Class + + +hasFixedSerializationLength :: Name -> Integer -> DecsQ +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 --- /dev/null +++ b/src/System/FilePath/Cryptographic.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{-| +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 \cdot \left \lceil \frac{l}{b} \right \rceil-l}]) +where \(l\) is the length of the serialized payload. +-} +module System.FilePath.Cryptographic + ( CryptoID(..) + , CryptoFileName + , module Data.Binary.SerializationLength + , encrypt + , decrypt + , CryptoIDError(..) + ) where + +import Data.CryptoID +import Data.CryptoID.Poly hiding (encrypt, decrypt) +import Data.CryptoID.ByteString (cipherBlockSize) +import qualified Data.CryptoID.Poly as Poly (encrypt, decrypt) + +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.Encoding.UTF8 +import Data.Encoding (decodeStrictByteString, encodeStrictByteString) +import Data.Char (toUpper) + +import Data.Ratio ((%)) +import Data.List + +import qualified Data.ByteString as ByteString + +import Control.Monad +import Control.Monad.Catch + +import Data.Proxy +import GHC.TypeLits + + +-- | @serializedLength@ is given in bytes. +type CryptoFileName (namespace :: Symbol) = CryptoID namespace (CI FilePath) + + +paddedLength :: Integral a => a -> a +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 (== '=') . decodeStrictByteString UTF8 $ 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) . encodeStrictByteString UTF8 . 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]