diff --git a/package.yaml b/package.yaml index 012fb7d07..2a11a9332 100644 --- a/package.yaml +++ b/package.yaml @@ -61,6 +61,7 @@ dependencies: - uuid-types - path-pieces - uuid-crypto +- filepath-crypto - cryptoids-types - cryptoids - binary diff --git a/src/CryptoID.hs b/src/CryptoID.hs index fbe19a830..9eecc80a0 100644 --- a/src/CryptoID.hs +++ b/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 diff --git a/src/CryptoID/Base32.hs b/src/CryptoID/Base32.hs deleted file mode 100644 index 732d40e5a..000000000 --- a/src/CryptoID/Base32.hs +++ /dev/null @@ -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 . (<> "===") diff --git a/src/CryptoID/TH.hs b/src/CryptoID/TH.hs index 149484ca1..20073bb85 100644 --- a/src/CryptoID/TH.hs +++ b/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 |] diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index ffb7ac937..ad7e9f3bc 100644 --- a/src/Handler/Submission.hs +++ b/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") diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index d5626e3b1..e90c9501c 100644 --- a/src/Handler/Utils/Rating.hs +++ b/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 diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index ee745e16c..8ce8df7e3 100644 --- a/src/Handler/Utils/Submission.hs +++ b/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 diff --git a/stack.yaml b/stack.yaml index a0b858e37..a976d4ac2 100644 --- a/stack.yaml +++ b/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