From fddd8bef4c8173baaaee3e3e13a40f4db6226b93 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 9 Feb 2018 14:22:01 +0100 Subject: [PATCH] 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