Introduce filepath-crypto

filepath-crypto/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.

filepath-crypto/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

filepath-crypto/changes.md

@@ -0,0 +1,3 @@
+# 0.0.0.0
+
+First published version

filepath-crypto/filepath-crypto.cabal

@@ -0,0 +1,45 @@
+name:                filepath-crypto
+version:             0.0.0.0
+synopsis:            Reversable and secure encoding of object ids as filepaths
+license:             BSD3
+license-file:        LICENSE
+author:              Gregor Kleen
+maintainer:          aethoago@141.li
+category:            cryptography
+build-type:          Simple
+cabal-version:       >=1.10
+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
+  other-modules:       Data.Binary.SerializationLength.Class
+  default-extensions:  KindSignatures
+                     , ViewPatterns
+                     , FlexibleContexts
+                     , GeneralizedNewtypeDeriving
+                     , PatternGuards
+                     , RecordWildCards
+                     , DataKinds
+                     , DeriveDataTypeable
+                     , DeriveGeneric
+  other-extensions:    ScopedTypeVariables
+  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
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  ghc-options:         -Wall -fno-warn-name-shadowing

filepath-crypto/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)

filepath-crypto/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

filepath-crypto/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)
+  |]

filepath-crypto/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 <https://hackage.haskell.org/package/sandi/docs/Codec-Binary-Base32.html base32>-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]

stack.yaml

@@ -15,7 +15,7 @@
 # resolver:
 #  name: custom-snapshot
 #  location: "./custom-snapshot.yaml"
-resolver: lts-9.3
+resolver: lts-9.9
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -39,9 +39,12 @@ packages:
   - cryptoids-types
   - cryptoids
   - uuid-crypto
+  - filepath-crypto
 # Dependency packages to be pulled from upstream that are not in the resolver
 # (e.g., acme-missiles-0.3)
-extra-deps: []
+extra-deps:
+  - regex-compat-0.93.1
+  - encoding-0.8.2
 
 # Override default flag values for local packages and extra-deps
 flags: {}