diff --git a/.gitignore b/.gitignore index 973be71ae..44f8bb6b1 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ dist* static/tmp/ static/combined/ client_session_key.aes +cryptoid_key.bf *.hi *.o *.sqlite3 diff --git a/config/settings.yml b/config/settings.yml index 9416f93a6..4697c77da 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -32,5 +32,7 @@ database: database: "_env:PGDATABASE:uniworx" poolsize: "_env:PGPOOLSIZE:10" +cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf" + copyright: Insert copyright statement here #analytics: UA-YOURCODE diff --git a/package.yaml b/package.yaml index 9ef1ecd1b..6f8c2b650 100644 --- a/package.yaml +++ b/package.yaml @@ -58,6 +58,13 @@ dependencies: - filepath - transformers - wl-pprint-text +- uuid-types +- path-pieces +- uuid-crypto +- cryptoids-types +- cryptoids +- binary +- mtl # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/routes b/routes index afea21d20..889bead74 100644 --- a/routes +++ b/routes @@ -18,3 +18,5 @@ /course/#TermIdentifier/#Text/edit CourseEditExistR GET /course/#TermIdentifier/#Text/show CourseShowR GET +-- For demonstration +/course/#CryptoUUIDCourse/edit CourseEditExistIDR GET \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index 6a16acf4e..563c208fa 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -55,14 +55,16 @@ mkYesodDispatch "UniWorX" resourcesUniWorX -- the place to put your migrate statements to have automatic database -- migrations handled by Yesod. makeFoundation :: AppSettings -> IO UniWorX -makeFoundation appSettings = do +makeFoundation appSettings@(AppSettings{..}) = do -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. appHttpManager <- newManager appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger appStatic <- - (if appMutableStatic appSettings then staticDevel else static) - (appStaticDir appSettings) + (if appMutableStatic then staticDevel else static) + appStaticDir + + appCryptoIDKey <- readKeyFile appCryptoIDKeyFile -- We need a log function to create a connection pool. We need a connection -- pool to create our foundation. And we need our foundation to get a @@ -78,8 +80,8 @@ makeFoundation appSettings = do -- Create the database connection pool pool <- flip runLoggingT logFunc $ createPostgresqlPool - (pgConnStr $ appDatabaseConf appSettings) - (pgPoolSize $ appDatabaseConf appSettings) + (pgConnStr appDatabaseConf) + (pgPoolSize appDatabaseConf) -- Perform database migration using our application's logging settings. runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc diff --git a/src/CryptoID.hs b/src/CryptoID.hs new file mode 100644 index 000000000..5e87a84d5 --- /dev/null +++ b/src/CryptoID.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module CryptoID + ( module CryptoID + , module Data.UUID.Cryptographic + , module Data.CryptoID.Poly + ) where + +import CryptoID.TH + +import ClassyPrelude hiding (fromString) +import Model + +import Data.CryptoID +import Data.CryptoID.Poly hiding (decrypt, encrypt) + +import Data.UUID.Cryptographic +import Data.UUID.Types +import Web.PathPieces + + +instance PathPiece UUID where + fromPathPiece = fromString . unpack + toPathPiece = pack . toString + +decKeysBinary [ ''SubmissionId + , ''CourseId + ] + +decTypeAliases [ "Submission" + , "Course" + ] diff --git a/src/CryptoID/TH.hs b/src/CryptoID/TH.hs new file mode 100644 index 000000000..81c8a984d --- /dev/null +++ b/src/CryptoID/TH.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module CryptoID.TH where + +import ClassyPrelude + +import Language.Haskell.TH + +import Data.CryptoID (CryptoID) +import Data.UUID.Types (UUID) +import Data.Binary (Binary(..)) + +import Database.Persist.Sql (toSqlKey, fromSqlKey) + + +decTypeAliases :: [String] -> Q [Dec] +decTypeAliases = return . concatMap decTypeAliases' + where + decTypeAliases' :: String -> [Dec] + decTypeAliases' n + = [ TySynD cryptoIDn [] $ ConT ''CryptoID `AppT` LitT (StrTyLit n) + , TySynD cryptoUUIDn [] $ ConT cryptoIDn `AppT` ConT ''UUID + ] + where + cryptoIDn = mkName $ "CryptoID" ++ n + cryptoUUIDn = mkName $ "CryptoUUID" ++ 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) + |] diff --git a/src/Foundation.hs b/src/Foundation.hs index 024f17928..836911410 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -50,6 +50,7 @@ data UniWorX = UniWorX , appConnPool :: ConnectionPool -- ^ Database connection pool. , appHttpManager :: Manager , appLogger :: Logger + , appCryptoIDKey :: CryptoIDKey } data MenuItem = MenuItem @@ -177,6 +178,7 @@ instance Yesod UniWorX where isAuthorized (TermEditExistR _) _ = return Authorized isAuthorized CourseEditR _ = return Authorized isAuthorized (CourseEditExistR _ _) _ = return Authorized + isAuthorized (CourseEditExistIDR _) _ = return Authorized diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 71c7c54cf..6fbcdc9e1 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -19,6 +19,8 @@ import Yesod.Form.Bootstrap3 import Colonnade import Yesod.Colonnade +import qualified Data.UUID.Cryptographic as UUID + getCourseListR :: Handler TypedContent getCourseListR = redirect TermShowR @@ -77,6 +79,12 @@ getCourseEditExistR tid csh = do course <- runDB $ getBy $ CourseTermShort (TermKey tid) csh courseEditHandler course +getCourseEditExistIDR :: CryptoUUIDCourse -> Handler Html +getCourseEditExistIDR cID = do + cIDKey <- getsYesod appCryptoIDKey + courseID <- UUID.decrypt cIDKey cID + courseEditHandler =<< runDB (getEntity courseID) + courseEditHandler :: Maybe (Entity Course) -> Handler Html courseEditHandler course = do diff --git a/src/Handler/Utils/Zip/Rating.hs b/src/Handler/Utils/Zip/Rating.hs index 4f08c8db1..06a43c2da 100644 --- a/src/Handler/Utils/Zip/Rating.hs +++ b/src/Handler/Utils/Zip/Rating.hs @@ -34,12 +34,16 @@ import Data.Text.Encoding.Error (UnicodeException(..)) import qualified Data.Text.Lazy.Encoding as Lazy.Text import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Lazy as Lazy.ByteString import Text.Read (readEither) import GHC.Generics (Generic) import Data.Typeable (Typeable) +import Data.Binary (encode, decode) +import qualified Data.CryptoID.Poly as Poly + instance HasResolution prec => Pretty (Fixed prec) where pretty = pretty . show @@ -48,7 +52,7 @@ instance HasResolution prec => Pretty (Fixed prec) where data Rating = Rating { ratingCourseName :: Text , ratingSheetName :: Text - , ratingSubmissionId :: SubmissionId + , ratingSubmissionId :: CryptoIDSubmission ByteString -- ^ 'SubmissionId' , ratingComment :: Maybe Text , ratingPoints :: Maybe Points } deriving (Read, Show, Eq, Generic, Typeable) @@ -67,10 +71,12 @@ instance Exception RatingException getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating) -getRating ratingSubmissionId = runMaybeT $ do - Submission{ submissionSheetId, submissionRatingComment = ratingComment, submissionRatingPoints = ratingPoints } <- MaybeT $ get ratingSubmissionId +getRating submissionId = runMaybeT $ do + Submission{ submissionSheetId, submissionRatingComment = ratingComment, submissionRatingPoints = ratingPoints } <- MaybeT $ get submissionId Sheet{ sheetCourseId, sheetName = ratingSheetName } <- MaybeT $ get submissionSheetId Course{ courseName = ratingCourseName } <- MaybeT $ get sheetCourseId + cIDKey <- getsYesod appCryptoIDKey + ratingSubmissionId <- Poly.encrypt cIDKey . Lazy.ByteString.toStrict $ encode submissionId return Rating{..} formatRating :: Rating -> Lazy.ByteString diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index cf17f5064..324a88840 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -12,3 +12,5 @@ import Yesod.Core.Types as Import (loggerSet) import Yesod.Default.Config2 as Import import Data.Fixed as Import + +import CryptoID as Import diff --git a/src/Settings.hs b/src/Settings.hs index 0486fce43..437985178 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -59,6 +59,7 @@ data AppSettings = AppSettings -- ^ Copyright text to appear in the footer of the page , appAnalytics :: Maybe Text -- ^ Google Analytics code + , appCryptoIDKeyFile :: FilePath , appAuthDummyLogin :: Bool -- ^ Indicate if auth dummy login should be enabled. @@ -87,6 +88,7 @@ instance FromJSON AppSettings where appCopyright <- o .: "copyright" appAnalytics <- o .:? "analytics" + appCryptoIDKeyFile <- o .: "cryptoid-keyfile" appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev diff --git a/stack.yaml b/stack.yaml index ab4813dbb..b4070ab13 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,4 +10,7 @@ extra-deps: - colonnade-1.1.1 - yesod-colonnade-1.1.0 - zip-stream-0.1.0.1 +- uuid-crypto-1.1.0 +- cryptoids-0.1.0 +- cryptoids-types-0.0.0 resolver: lts-9.3