From db92528884d6b8b310470fc0f94ef46d3157682e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 14 Jan 2018 01:17:31 +0100 Subject: [PATCH 1/6] Framework & dispatch submissions --- package.yaml | 1 + routes | 2 ++ src/Application.hs | 1 + src/Foundation.hs | 1 + src/Handler/CryptoIDDispatch.hs | 50 +++++++++++++++++++++++++++++++++ src/Import/NoFoundation.hs | 1 + 6 files changed, 56 insertions(+) create mode 100644 src/Handler/CryptoIDDispatch.hs diff --git a/package.yaml b/package.yaml index 9d3b509b1..99ef36dd0 100644 --- a/package.yaml +++ b/package.yaml @@ -75,6 +75,7 @@ dependencies: - yesod-auth-ldap - LDAP - parsec +- uuid # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/routes b/routes index 4085fd935..835f50270 100644 --- a/routes +++ b/routes @@ -29,5 +29,7 @@ !/submission/archive/#FilePath SubmissionDownloadArchiveR GET !/submission/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET +!/#UUID CryptoUUIDDispatchR GET + -- For demonstration /course/#CryptoUUIDCourse/edit CourseEditExistIDR GET diff --git a/src/Application.hs b/src/Application.hs index 403bf072c..4b558617d 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -46,6 +46,7 @@ import Handler.Term import Handler.Course import Handler.Sheet import Handler.Submission +import Handler.CryptoIDDispatch -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/src/Foundation.hs b/src/Foundation.hs index ae0b849bb..954a132e0 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -133,6 +133,7 @@ instance Yesod UniWorX where isAuthorized CourseListR _ = return Authorized isAuthorized (CourseListTermR _) _ = return Authorized isAuthorized (CourseShowR _ _) _ = return Authorized + isAuthorized (CryptoUUIDDispatchR _) _ = return Authorized isAuthorized SubmissionListR _ = isAuthenticated isAuthorized SubmissionDownloadMultiArchiveR _ = isAuthenticated -- isAuthorized TestR _ = return Authorized diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs new file mode 100644 index 000000000..450f6944e --- /dev/null +++ b/src/Handler/CryptoIDDispatch.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE NoImplicitPrelude + , DataKinds + , KindSignatures + , TypeFamilies + , FlexibleInstances + , TypeOperators + , RankNTypes + , PolyKinds + , RecordWildCards + , MultiParamTypeClasses + , ScopedTypeVariables + #-} + +module Handler.CryptoIDDispatch + ( getCryptoUUIDDispatchR + ) where + +import GHC.TypeLits +import Import hiding (Proxy) + +import Data.Proxy + + +class KnownSymbol namespace => CryptoRoute ciphertext namespace where + cryptoIDRoute :: CryptoID namespace ciphertext -> Handler (Route UniWorX) + +instance CryptoRoute UUID "Submission" where + cryptoIDRoute = return . SubmissionR + + +class Dispatch ciphertext (x :: [Symbol]) where + dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX)) + +instance Dispatch ciphertext '[] where + dispatchID _ _ = return Nothing + +instance (CryptoRoute ciphertext namespace, Dispatch ciphertext ns) => Dispatch ciphertext (namespace ': ns) where + dispatchID _ ciphertext = (<|>) <$> dispatchHead <*> dispatchTail + where + headID :: CryptoID namespace ciphertext + headID = CryptoID{..} + dispatchHead = (Just <$> cryptoIDRoute headID) `catchAny` (\_ -> return Nothing) + dispatchTail = dispatchID (Proxy :: Proxy ns) ciphertext + + +getCryptoUUIDDispatchR :: UUID -> Handler () +getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound redirect + where + p :: Proxy '["Submission"] + p = Proxy diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 324a88840..9b688de60 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -14,3 +14,4 @@ import Yesod.Default.Config2 as Import import Data.Fixed as Import import CryptoID as Import +import Data.UUID as Import (UUID) From 6bf0f321cf41cd536aac3987a9fd2598da844bcf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 14 Jan 2018 01:37:01 +0100 Subject: [PATCH 2/6] Check decryption before redirecting (as was intended) --- src/Handler/CryptoIDDispatch.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 450f6944e..7666225f7 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -20,12 +20,18 @@ import Import hiding (Proxy) import Data.Proxy +import qualified Data.UUID.Cryptographic as UUID + class KnownSymbol namespace => CryptoRoute ciphertext namespace where cryptoIDRoute :: CryptoID namespace ciphertext -> Handler (Route UniWorX) instance CryptoRoute UUID "Submission" where - cryptoIDRoute = return . SubmissionR + cryptoIDRoute cID = do + cIDKey <- getsYesod appCryptoIDKey + sId <- UUID.decrypt cIDKey cID + + return $ SubmissionR cID class Dispatch ciphertext (x :: [Symbol]) where From 7c5c12dc6bbca3c77f39246be97754ac69129545 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 14 Jan 2018 02:30:12 +0100 Subject: [PATCH 3/6] Fix type error --- src/Handler/CryptoIDDispatch.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 7666225f7..04fe31baf 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -29,7 +29,7 @@ class KnownSymbol namespace => CryptoRoute ciphertext namespace where instance CryptoRoute UUID "Submission" where cryptoIDRoute cID = do cIDKey <- getsYesod appCryptoIDKey - sId <- UUID.decrypt cIDKey cID + (_ :: SubmissionId) <- UUID.decrypt cIDKey cID return $ SubmissionR cID From d37ee331f68004e97fb458cb70449c81f4d929af Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 14 Jan 2018 02:30:21 +0100 Subject: [PATCH 4/6] Use correct status header --- src/Handler/CryptoIDDispatch.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 04fe31baf..68890b823 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -50,7 +50,7 @@ instance (CryptoRoute ciphertext namespace, Dispatch ciphertext ns) => Dispatch getCryptoUUIDDispatchR :: UUID -> Handler () -getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound redirect +getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302) where p :: Proxy '["Submission"] p = Proxy From b6dbd27eb0fe550c0d3689c5f041438348fa69b1 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 20 Jan 2018 09:42:26 +0100 Subject: [PATCH 5/6] Cleanup --- package.yaml | 1 + src/Handler/CryptoIDDispatch.hs | 15 +++++++++++++-- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index 99ef36dd0..767109324 100644 --- a/package.yaml +++ b/package.yaml @@ -76,6 +76,7 @@ dependencies: - LDAP - parsec - uuid +- exceptions # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 68890b823..eb76377ac 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -22,6 +22,10 @@ import Data.Proxy import qualified Data.UUID.Cryptographic as UUID +import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) + +import qualified Control.Monad.Catch as E (Handler(..)) + class KnownSymbol namespace => CryptoRoute ciphertext namespace where cryptoIDRoute :: CryptoID namespace ciphertext -> Handler (Route UniWorX) @@ -45,12 +49,19 @@ instance (CryptoRoute ciphertext namespace, Dispatch ciphertext ns) => Dispatch where headID :: CryptoID namespace ciphertext headID = CryptoID{..} - dispatchHead = (Just <$> cryptoIDRoute headID) `catchAny` (\_ -> return Nothing) + dispatchHead = (Just <$> cryptoIDRoute headID) `catches` [ E.Handler handleHCError, E.Handler handleCryptoID ] + where + handleHCError :: HandlerContents -> Handler (Maybe a) + handleHCError (HCError NotFound) = return Nothing + handleHCError e = throwM e + handleCryptoID :: CryptoIDError -> Handler (Maybe a) + handleCryptoID _ = return Nothing dispatchTail = dispatchID (Proxy :: Proxy ns) ciphertext getCryptoUUIDDispatchR :: UUID -> Handler () getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302) where - p :: Proxy '["Submission"] + p :: Proxy '[ "Submission" + ] p = Proxy From fddd8bef4c8173baaaee3e3e13a40f4db6226b93 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 9 Feb 2018 14:22:01 +0100 Subject: [PATCH 6/6] Make CryptoIDKey implicit using new cryptoids-class --- ghci.sh | 8 ++++++ package.yaml | 2 ++ src/CryptoID.hs | 20 +++++++------- src/CryptoID/TH.hs | 48 +++++++++++++++++---------------- src/Foundation.hs | 14 +++++----- src/Handler/CryptoIDDispatch.hs | 27 ++++++++----------- src/Handler/Submission.hs | 30 +++++++-------------- stack.yaml | 8 +++--- 8 files changed, 78 insertions(+), 79 deletions(-) create mode 100755 ghci.sh diff --git a/ghci.sh b/ghci.sh new file mode 100755 index 000000000..64adc58eb --- /dev/null +++ b/ghci.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +unset HOST +export DETAILED_LOGGING=true +export LOG_ALL=true +export DUMMY_LOGIN=true + +exec -- stack ghci --flag uniworx:dev --flag uniworx:library-only diff --git a/package.yaml b/package.yaml index 767109324..aa46feb3e 100644 --- a/package.yaml +++ b/package.yaml @@ -10,6 +10,7 @@ dependencies: # version 1.0 had a bug in reexporting Handler, causing trouble - classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1 +- foreign-store - yesod >=1.4.3 && <1.5 - yesod-core >=1.4.30 && <1.5 - yesod-auth >=1.4.0 && <1.5 @@ -64,6 +65,7 @@ dependencies: - filepath-crypto - cryptoids-types - cryptoids +- cryptoids-class - binary - mtl - sandi diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 9eecc80a0..b8889ebac 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -7,8 +7,9 @@ module CryptoID ( module CryptoID - , module Data.UUID.Cryptographic - , module Data.CryptoID.Poly + , module Data.CryptoID.Poly.ImplicitNamespace + , module Data.UUID.Cryptographic.ImplicitNamespace + , module System.FilePath.Cryptographic.ImplicitNamespace ) where import CryptoID.TH @@ -16,10 +17,10 @@ import CryptoID.TH import ClassyPrelude hiding (fromString) import Model -import Data.CryptoID -import Data.CryptoID.Poly hiding (encrypt, decrypt) +import Data.CryptoID.Poly.ImplicitNamespace +import Data.UUID.Cryptographic.ImplicitNamespace +import System.FilePath.Cryptographic.ImplicitNamespace -import Data.UUID.Cryptographic import Data.UUID.Types import Web.PathPieces @@ -28,10 +29,7 @@ instance PathPiece UUID where fromPathPiece = fromString . unpack toPathPiece = pack . toString -decKeysBinary [ ''SubmissionId - , ''CourseId - ] -decTypeAliases [ "Submission" - , "Course" - ] +decCryptoIDs [ ''SubmissionId + , ''CourseId + ] diff --git a/src/CryptoID/TH.hs b/src/CryptoID/TH.hs index 20073bb85..23122dadf 100644 --- a/src/CryptoID/TH.hs +++ b/src/CryptoID/TH.hs @@ -8,7 +8,7 @@ import ClassyPrelude import Language.Haskell.TH -import Data.CryptoID (CryptoID) +import Data.CryptoID.Class.ImplicitNamespace import Data.UUID.Types (UUID) import Data.Binary (Binary(..)) import Data.Binary.SerializationLength @@ -19,28 +19,30 @@ import System.FilePath (FilePath) import Database.Persist.Sql (toSqlKey, fromSqlKey) -decTypeAliases :: [String] -> Q [Dec] -decTypeAliases = return . concatMap decTypeAliases' +decCryptoIDs :: [Name] -> DecsQ +decCryptoIDs = fmap concat . mapM decCryptoID where - decTypeAliases' :: String -> [Dec] - decTypeAliases' n - = [ TySynD cryptoIDn [] $ ConT ''CryptoID `AppT` LitT (StrTyLit n) - , TySynD cryptoUUIDn [] $ ConT cryptoIDn `AppT` ConT ''UUID - , TySynD cryptoBase32n [] $ ConT cryptoIDn `AppT` (ConT ''CI `AppT` ConT ''FilePath) + decCryptoID :: Name -> DecsQ + decCryptoID n@(conT -> t) = do + instances <- [d| + instance Binary $(t) where + get = $(varE 'toSqlKey) <$> get + put = put . $(varE 'fromSqlKey) + instance HasFixedSerializationLength $(t) where + type SerializationLength $(t) = SerializationLength Int64 + + type instance CryptoIDNamespace a $(t) = $(litT $ strTyLit ns) + |] + + synonyms <- mapM cryptoIDSyn + [ (ConT ''UUID, "UUID") + , (ConT ''CI `AppT` ConT ''FilePath, "FileName") + ] + + return $ concat + [ instances + , synonyms ] where - cryptoIDn = mkName $ "CryptoID" ++ n - cryptoUUIDn = mkName $ "CryptoUUID" ++ n - cryptoBase32n = mkName $ "CryptoFileName" ++ n - -decKeysBinary :: [Name] -> DecsQ -decKeysBinary = fmap concat . mapM decKeyBinary - where - decKeyBinary :: Name -> DecsQ - decKeyBinary (conT -> t) - = [d| instance Binary $(t) where - get = $(varE 'toSqlKey) <$> get - put = put . $(varE 'fromSqlKey) - instance HasFixedSerializationLength $(t) where - type SerializationLength $(t) = SerializationLength Int64 - |] + ns = (\nb -> fromMaybe nb $ stripSuffix "Id" nb) $ nameBase n + cryptoIDSyn (ct, str) = tySynD (mkName $ "Crypto" ++ str ++ ns) [] $ conT ''CryptoID `appT` return ct `appT` t diff --git a/src/Foundation.hs b/src/Foundation.hs index 954a132e0..fde407991 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -8,6 +8,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module Foundation where @@ -48,8 +49,6 @@ import Data.Conduit.List (sourceList) import Control.Monad.Except (MonadError(..), runExceptT) import Handler.Utils.StudyFeatures -import qualified Data.UUID.Cryptographic as UUID -import qualified System.FilePath.Cryptographic as FilePath import System.FilePath -- | The foundation datatype for your application. This can be a good place to @@ -187,16 +186,14 @@ isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing isAuthorizedDB CourseEditR _ = lecturerAccess Nothing isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort (TermKey t) c) isAuthorizedDB (CourseEditExistIDR cID) _ = do - cIDKey <- getsYesod appCryptoIDKey - courseId <- UUID.decrypt cIDKey cID + courseId <- decrypt cID courseLecturerAccess courseId isAuthorizedDB route isWrite = return $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop! submissionAccess :: Either CryptoFileNameSubmission CryptoUUIDSubmission -> YesodDB UniWorX AuthResult submissionAccess cID = do authId <- lift requireAuthId - cIDKey <- getsYesod appCryptoIDKey - submissionId <- either (FilePath.decrypt cIDKey) (UUID.decrypt cIDKey) cID + submissionId <- either decrypt decrypt cID Submission{..} <- get404 submissionId submissionUsers <- map (submissionUserUserId . entityVal) <$> selectList [SubmissionUserSubmissionId ==. submissionId] [] let auth = authId `elem` submissionUsers || Just authId == submissionRatingBy @@ -428,6 +425,11 @@ instance HasHttpManager UniWorX where unsafeHandler :: UniWorX -> Handler a -> IO a unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger + +instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where + type MonadCryptoKey m = CryptoIDKey + cryptoIDKey f = getsYesod appCryptoIDKey >>= f + -- Note: Some functionality previously present in the scaffolding has been -- moved to documentation in the Wiki. Following are some hopefully helpful -- links: diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index eb76377ac..0eff808f2 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -9,59 +9,54 @@ , RecordWildCards , MultiParamTypeClasses , ScopedTypeVariables + , ViewPatterns #-} module Handler.CryptoIDDispatch ( getCryptoUUIDDispatchR ) where -import GHC.TypeLits import Import hiding (Proxy) import Data.Proxy -import qualified Data.UUID.Cryptographic as UUID - import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) import qualified Control.Monad.Catch as E (Handler(..)) -class KnownSymbol namespace => CryptoRoute ciphertext namespace where - cryptoIDRoute :: CryptoID namespace ciphertext -> Handler (Route UniWorX) +class CryptoRoute ciphertext plaintext where + cryptoIDRoute :: p plaintext -> ciphertext -> Handler (Route UniWorX) -instance CryptoRoute UUID "Submission" where - cryptoIDRoute cID = do - cIDKey <- getsYesod appCryptoIDKey - (_ :: SubmissionId) <- UUID.decrypt cIDKey cID +instance CryptoRoute UUID SubmissionId where + cryptoIDRoute _ (CryptoID -> cID) = do + (_ :: SubmissionId) <- decrypt cID return $ SubmissionR cID -class Dispatch ciphertext (x :: [Symbol]) where +class Dispatch ciphertext (x :: [*]) where dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX)) instance Dispatch ciphertext '[] where dispatchID _ _ = return Nothing -instance (CryptoRoute ciphertext namespace, Dispatch ciphertext ns) => Dispatch ciphertext (namespace ': ns) where +instance (CryptoRoute ciphertext plaintext, Dispatch ciphertext ps) => Dispatch ciphertext (plaintext ': ps) where dispatchID _ ciphertext = (<|>) <$> dispatchHead <*> dispatchTail where - headID :: CryptoID namespace ciphertext - headID = CryptoID{..} - dispatchHead = (Just <$> cryptoIDRoute headID) `catches` [ E.Handler handleHCError, E.Handler handleCryptoID ] + dispatchHead = (Just <$> cryptoIDRoute (Proxy :: Proxy plaintext) ciphertext) `catches` [ E.Handler handleHCError, E.Handler handleCryptoID ] where handleHCError :: HandlerContents -> Handler (Maybe a) handleHCError (HCError NotFound) = return Nothing handleHCError e = throwM e handleCryptoID :: CryptoIDError -> Handler (Maybe a) handleCryptoID _ = return Nothing - dispatchTail = dispatchID (Proxy :: Proxy ns) ciphertext + dispatchTail = dispatchID (Proxy :: Proxy ps) ciphertext getCryptoUUIDDispatchR :: UUID -> Handler () getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302) where - p :: Proxy '[ "Submission" + p :: Proxy '[ SubmissionId ] p = Proxy diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 87e760998..ee5b54e5e 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -27,8 +27,6 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.CaseInsensitive as CI -import qualified Data.UUID.Cryptographic as UUID - import qualified Database.Esqueleto as E import qualified Data.Conduit.List as Conduit @@ -38,7 +36,6 @@ 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 @@ -52,9 +49,8 @@ submissionTable = do return (sub, sheet, course) - cIDKey <- getsYesod appCryptoIDKey cryptedSubs <- forM subs $ \s@(Entity submissionId _, _, _) -> - (,,) <$> FilePath.encrypt cIDKey submissionId <*> UUID.encrypt cIDKey submissionId <*> pure s + (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s let anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR (unTermKey courseTermId) courseShorthand @@ -69,7 +65,7 @@ submissionTable = do toExternal :: (CryptoFileNameSubmission, CryptoUUIDSubmission, a) -> Handler CryptoUUIDSubmission toExternal (_, cID, _) = return cID fromExternal :: CryptoUUIDSubmission -> Handler SubmissionId - fromExternal = UUID.decrypt cIDKey + fromExternal = decrypt headedRowSelector toExternal fromExternal (HA.class_ "table table-striped table-hover") colonnade cryptedSubs @@ -106,8 +102,7 @@ postSubmissionListR = do (Left f@File{..}) -> case splitDirectories fileTitle of (cID:rest) | not (null rest) -> do - cIDKey <- getsYesod appCryptoIDKey - sId <- FilePath.decrypt cIDKey (CryptoID $ CI.mk cID :: CryptoFileNameSubmission) + sId <- decrypt (CryptoID $ CI.mk cID :: CryptoFileNameSubmission) lift . feed sId $ Left f{ fileTitle = joinPath rest } | otherwise -> return () [] -> invalidArgs ["Encountered file/directory with empty name"] @@ -121,9 +116,8 @@ postSubmissionListR = do getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent getSubmissionDownloadSingleR cID path = do - cIDKey <- getsYesod appCryptoIDKey - submissionID <- UUID.decrypt cIDKey cID - cID' <- FilePath.encrypt cIDKey submissionID + submissionID <- decrypt cID + cID' <- encrypt submissionID runDB $ do isRating <- maybe False (== submissionID) <$> isRatingFile path @@ -172,9 +166,7 @@ postSubmissionDownloadMultiArchiveR = do let fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File fileEntitySource' (rating, Entity submissionID Submission{..}) = do - cID <- lift $ do - cIDKey <- getsYesod appCryptoIDKey - FilePath.encrypt cIDKey submissionID + cID <- encrypt submissionID let directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission) @@ -202,9 +194,8 @@ getSubmissionDownloadArchiveR path = do cID :: CryptoFileNameSubmission cID = CryptoID $ CI.mk baseName unless (ext == ".zip") notFound - cIDKey <- getsYesod appCryptoIDKey - submissionID <- FilePath.decrypt cIDKey cID - cUUID <- UUID.encrypt cIDKey submissionID + submissionID <- decrypt cID + cUUID <- encrypt submissionID respondSourceDB "application/zip" $ do rating <- lift $ getRating submissionID case rating of @@ -218,8 +209,7 @@ getSubmissionDownloadArchiveR path = do getSubmissionR, postSubmissionR :: CryptoUUIDSubmission -> Handler Html getSubmissionR = postSubmissionR postSubmissionR cID = do - cIDKey <- getsYesod appCryptoIDKey - submissionId <- UUID.decrypt cIDKey cID + submissionId <- decrypt cID ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderBootstrap3 BootstrapBasicForm $ (,) <$> areq checkBoxField (bfs ("Dies ist eine Korrektur" :: Text)) (Just False) @@ -260,7 +250,7 @@ postSubmissionR cID = do , ratingTime = submissionRatingTime submission } - cID' <- FilePath.encrypt cIDKey submissionId + cID' <- encrypt submissionId let archiveBaseName = CI.foldedCase $ ciphertext (cID' :: CryptoFileNameSubmission) archiveName = archiveBaseName <.> "zip" diff --git a/stack.yaml b/stack.yaml index 4ffa5300f..8cb20da7f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -26,13 +26,15 @@ extra-deps: - yesod-colonnade-1.1.0 # - zip-stream-0.1.0.1 - conduit-resumablesink-0.2 -- uuid-crypto-1.3.1.0 -- filepath-crypto-0.0.0.0 -- cryptoids-0.4.0.0 +- uuid-crypto-1.4.0.0 +- filepath-crypto-0.1.0.0 +- cryptoids-0.5.0.0 - cryptoids-types-0.0.0 +- cryptoids-class-0.0.0 - encoding-0.8.2 - regex-compat-0.93.1 - LDAP-0.6.11 resolver: lts-9.3 +allow-newer: true