Switch to newly released 'filepath-crypto'

package.yaml

@@ -61,6 +61,7 @@ dependencies:
 - uuid-types
 - path-pieces
 - uuid-crypto
+- filepath-crypto
 - cryptoids-types
 - cryptoids
 - binary

src/CryptoID.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -8,7 +9,6 @@ module CryptoID
   ( module CryptoID
   , module Data.UUID.Cryptographic
   , module Data.CryptoID.Poly
-  , module CryptoID.Base32
   ) where
 
 import CryptoID.TH
@@ -18,7 +18,6 @@ import Model
 
 import Data.CryptoID
 import Data.CryptoID.Poly hiding (encrypt, decrypt)
-import CryptoID.Base32 hiding (encrypt, decrypt)
 
 import Data.UUID.Cryptographic
 import Data.UUID.Types

src/CryptoID/Base32.hs

@@ -1,45 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module CryptoID.Base32
-  ( encrypt
-  , decrypt
-  , Base32
-  ) where
-
-import ClassyPrelude
-
-import qualified Codec.Binary.Base32 as Base32
-
-import Data.CaseInsensitive (CI)
-import qualified Data.CaseInsensitive as CI
-
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
-
-import qualified Data.CryptoID.Poly as Poly (encrypt, decrypt)
-import Data.CryptoID.Poly hiding (encrypt, decrypt)
-
-import GHC.TypeLits
-import Data.Binary (Binary)
-
-
-type Base32 = CI Text
-type CryptoFileName namespace = CryptoID namespace Base32
-
-
-encrypt :: ( KnownSymbol namespace
-           , MonadThrow m
-           , Binary a
-           ) => CryptoIDKey -> a -> m (CryptoFileName namespace)
-encrypt = Poly.encrypt Nothing base32
-  where
-    base32 = return . CI.mk . Text.dropWhileEnd (== '=') . Text.decodeUtf8 . Base32.encode
-  
-decrypt :: ( KnownSymbol namespace
-           , MonadThrow m
-           , Binary a
-           ) => CryptoIDKey -> CryptoFileName namespace -> m a
-decrypt = Poly.decrypt unbase32
-  where
-    unbase32 = (\bs -> either (const . throwM $ CiphertextConversionFailed bs) return $ Base32.decode bs) . Text.encodeUtf8 . Text.toUpper . CI.original . (<> "===")

src/CryptoID/TH.hs

@@ -11,7 +11,10 @@ import Language.Haskell.TH
 import Data.CryptoID (CryptoID)
 import Data.UUID.Types (UUID)
 import Data.Binary (Binary(..))
-import CryptoID.Base32 (Base32)
+import Data.Binary.SerializationLength
+
+import Data.CaseInsensitive (CI)
+import System.FilePath (FilePath)
 
 import Database.Persist.Sql (toSqlKey, fromSqlKey)
 
@@ -23,7 +26,7 @@ decTypeAliases = return . concatMap decTypeAliases'
     decTypeAliases' n
       = [ TySynD cryptoIDn [] $ ConT ''CryptoID `AppT` LitT (StrTyLit n)
         , TySynD cryptoUUIDn [] $ ConT cryptoIDn `AppT` ConT ''UUID
-        , TySynD cryptoBase32n [] $ ConT cryptoIDn `AppT` ConT ''Base32
+        , TySynD cryptoBase32n [] $ ConT cryptoIDn `AppT` (ConT ''CI `AppT` ConT ''FilePath)
         ]
       where
         cryptoIDn = mkName $ "CryptoID" ++ n
@@ -38,4 +41,6 @@ decKeysBinary = fmap concat . mapM decKeyBinary
       = [d| instance Binary $(t) where
               get = $(varE 'toSqlKey) <$> get
               put = put . $(varE 'fromSqlKey)
+            instance HasFixedSerializationLength $(t) where
+              type SerializationLength $(t) = SerializationLength Int64
           |]

src/Handler/Submission.hs

@@ -28,7 +28,6 @@ import qualified Data.Text.Encoding as Text
 import qualified Data.CaseInsensitive as CI
 
 import qualified Data.UUID.Cryptographic as UUID
-import qualified CryptoID.Base32 as Base32
 
 import qualified Database.Esqueleto as E
 
@@ -39,6 +38,7 @@ import Data.Map (Map)
 import qualified Data.Map as Map
 
 import System.FilePath
+import qualified System.FilePath.Cryptographic as FilePath (decrypt, encrypt)
 
 import Colonnade
 import Yesod.Colonnade
@@ -54,7 +54,7 @@ submissionTable = do
 
   cIDKey <- getsYesod appCryptoIDKey
   cryptedSubs <- forM subs $ \s@(Entity submissionId _, _, _) ->
-    (,,) <$> Base32.encrypt cIDKey submissionId <*> UUID.encrypt cIDKey submissionId <*> pure s
+    (,,) <$> FilePath.encrypt cIDKey submissionId <*> UUID.encrypt cIDKey submissionId <*> pure s
 
   let
     anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR (unTermKey courseTermId) courseShorthand
@@ -107,7 +107,7 @@ postSubmissionListR = do
                   (cID:rest)
                     | not (null rest) -> do
                         cIDKey <- getsYesod appCryptoIDKey
-                        sId <- Base32.decrypt cIDKey (CryptoID . CI.mk $ Text.pack cID :: CryptoFileNameSubmission)
+                        sId <- FilePath.decrypt cIDKey (CryptoID $ CI.mk cID :: CryptoFileNameSubmission)
                         lift . feed sId $ Left f{ fileTitle = joinPath rest }
                     | otherwise -> return ()
                   [] -> invalidArgs ["Encountered file/directory with empty name"]
@@ -123,7 +123,7 @@ getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler Type
 getSubmissionDownloadSingleR cID path = do
   cIDKey <- getsYesod appCryptoIDKey
   submissionID <- UUID.decrypt cIDKey cID
-  cID' <- Base32.encrypt cIDKey submissionID
+  cID' <- FilePath.encrypt cIDKey submissionID
 
   runDB $ do
     isRating <- maybe False (== submissionID) <$> isRatingFile path
@@ -174,10 +174,10 @@ postSubmissionDownloadMultiArchiveR = do
           fileEntitySource' (rating, Entity submissionID Submission{..}) = do
             cID <- lift $ do
               cIDKey <- getsYesod appCryptoIDKey
-              Base32.encrypt cIDKey submissionID
+              FilePath.encrypt cIDKey submissionID
 
             let
-              directoryName = Text.unpack . CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
+              directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
               
               fileEntitySource = do
                 submissionFileSource submissionID =$= Conduit.map entityVal
@@ -200,10 +200,10 @@ getSubmissionDownloadArchiveR :: FilePath -> Handler TypedContent
 getSubmissionDownloadArchiveR path = do
   let (baseName, ext) = splitExtension path
       cID :: CryptoFileNameSubmission
-      cID = CryptoID . CI.mk $ Text.pack baseName
+      cID = CryptoID $ CI.mk baseName
   unless (ext == ".zip") notFound
   cIDKey <- getsYesod appCryptoIDKey
-  submissionID <- Base32.decrypt cIDKey cID
+  submissionID <- FilePath.decrypt cIDKey cID
   cUUID <- UUID.encrypt cIDKey submissionID
   respondSourceDB "application/zip" $ do
     rating <- lift $ getRating submissionID
@@ -260,9 +260,9 @@ postSubmissionR cID = do
       , ratingTime = submissionRatingTime submission
       }
 
-  cID' <- Base32.encrypt cIDKey submissionId
+  cID' <- FilePath.encrypt cIDKey submissionId
   let
-    archiveBaseName = Text.unpack . CI.foldedCase $ ciphertext (cID' :: CryptoFileNameSubmission)
+    archiveBaseName = CI.foldedCase $ ciphertext (cID' :: CryptoFileNameSubmission)
     archiveName = archiveBaseName <.> "zip"
 
   defaultLayout $(widgetFile "submission")

src/Handler/Utils/Rating.hs

@@ -50,9 +50,8 @@ import Text.Read (readEither)
 import GHC.Generics (Generic)
 import Data.Typeable (Typeable)
 
-import CryptoID.Base32 as Base32
-
 import System.FilePath
+import qualified System.FilePath.Cryptographic as FilePath (decrypt)
 
 import qualified Database.Esqueleto as E
 
@@ -137,7 +136,7 @@ ratingFile :: MonadIO m => CryptoFileNameSubmission -> Rating -> m File
 ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do
   fileModified <- maybe (liftIO getCurrentTime) return ratingTime
   let
-    fileTitle = "bewertung_" <> (Text.unpack . CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)) <.> "txt"
+    fileTitle = "bewertung_" <> (CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)) <.> "txt"
     fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating
   return File{..}
 
@@ -190,7 +189,7 @@ isRatingFile :: ( MonadHandler m
 isRatingFile fName
   | Just cID <- isRatingFile' fName = do
       cIDKey <- getsYesod appCryptoIDKey
-      (Just <$> Base32.decrypt cIDKey cID) `catch` decryptErrors
+      (Just <$> FilePath.decrypt cIDKey cID) `catch` decryptErrors
   | otherwise = return Nothing
   where
 
@@ -202,7 +201,7 @@ isRatingFile fName
 isRatingFile' :: FilePath -> Maybe CryptoFileNameSubmission
 isRatingFile' (takeFileName -> fName)
   | (bName, ".txt") <- splitExtension fName
-  , Just (CI.mk . Text.pack -> ciphertext) <- stripPrefix "bewertung_" bName
+  , Just (CI.mk -> ciphertext) <- stripPrefix "bewertung_" bName
   = Just CryptoID{..}
   | otherwise
   = Nothing

src/Handler/Utils/Submission.hs

@@ -31,8 +31,6 @@ import qualified Database.Esqueleto as E
 
 import qualified Data.Conduit.List as Conduit
 
-import qualified Data.Text as Text
-
 
 data SubmissionSinkState = SubmissionSinkState
   { sinkSeenRating :: Any

stack.yaml

@@ -18,8 +18,9 @@ extra-deps:
 - colonnade-1.1.1
 - yesod-colonnade-1.1.0
 # - zip-stream-0.1.0.1
-- uuid-crypto-1.3.0.0
-- cryptoids-0.3.0.0
+- uuid-crypto-1.3.1.0
+- filepath-crypto-0.0.0.0
+- cryptoids-0.4.0.0
 - cryptoids-types-0.0.0
 
 - encoding-0.8.2