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 9d3b509b1..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 @@ -75,6 +77,8 @@ dependencies: - yesod-auth-ldap - LDAP - parsec +- uuid +- exceptions # 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/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 ae0b849bb..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 @@ -133,6 +132,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 @@ -186,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 @@ -427,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 new file mode 100644 index 000000000..0eff808f2 --- /dev/null +++ b/src/Handler/CryptoIDDispatch.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE NoImplicitPrelude + , DataKinds + , KindSignatures + , TypeFamilies + , FlexibleInstances + , TypeOperators + , RankNTypes + , PolyKinds + , RecordWildCards + , MultiParamTypeClasses + , ScopedTypeVariables + , ViewPatterns + #-} + +module Handler.CryptoIDDispatch + ( getCryptoUUIDDispatchR + ) where + +import Import hiding (Proxy) + +import Data.Proxy + +import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) + +import qualified Control.Monad.Catch as E (Handler(..)) + + +class CryptoRoute ciphertext plaintext where + cryptoIDRoute :: p plaintext -> ciphertext -> Handler (Route UniWorX) + +instance CryptoRoute UUID SubmissionId where + cryptoIDRoute _ (CryptoID -> cID) = do + (_ :: SubmissionId) <- decrypt cID + + return $ SubmissionR cID + + +class Dispatch ciphertext (x :: [*]) where + dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX)) + +instance Dispatch ciphertext '[] where + dispatchID _ _ = return Nothing + +instance (CryptoRoute ciphertext plaintext, Dispatch ciphertext ps) => Dispatch ciphertext (plaintext ': ps) where + dispatchID _ ciphertext = (<|>) <$> dispatchHead <*> dispatchTail + where + 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 ps) ciphertext + + +getCryptoUUIDDispatchR :: UUID -> Handler () +getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302) + where + 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/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) 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