From 5f7b134292a318232cad683aa1add37755a71182 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 27 Feb 2019 17:29:17 +0100 Subject: [PATCH] Write StudyTermCandidates during login --- models/users | 9 +++- src/Database/Esqueleto/Utils.hs | 26 +++++++---- src/Database/Esqueleto/Utils/TH.hs | 48 +++++++++++++++++++++ src/Foundation.hs | 36 +++++++++++++--- src/Handler/Course.hs | 2 +- src/Handler/Utils/StudyFeatures.hs | 9 ++-- src/Handler/Utils/Table/Pagination.hs | 8 ++-- src/Handler/Utils/Table/Pagination/Types.hs | 41 ------------------ src/Model/Types.hs | 1 + 9 files changed, 112 insertions(+), 68 deletions(-) create mode 100644 src/Database/Esqueleto/Utils/TH.hs diff --git a/models/users b/models/users index 94f1cb559..59f9ecb6b 100644 --- a/models/users +++ b/models/users @@ -30,7 +30,9 @@ StudyFeatures field StudyTermsId type StudyFieldType semester Int - updated UTCTime default=now -- zuletzt als gültig gesehen + updated UTCTime default='NOW()' -- zuletzt als gültig gesehen + valid Bool default=true + UniqueStudyFeatures user degree field type semester -- UniqueUserSubject user degree field -- There exists a counterexample StudyDegree key Int @@ -42,3 +44,8 @@ StudyTerms shorthand Text Maybe name Text Maybe Primary key +StudyTermCandidate + incidence UUID + key Int + name Text + deriving Show Eq Ord \ No newline at end of file diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 41464cc00..003b26168 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -1,8 +1,16 @@ -module Database.Esqueleto.Utils where +{-# OPTIONS_GHC -fno-warn-orphans #-} -import ClassyPrelude.Yesod hiding (isInfixOf, (||.)) -import Data.Foldable as F -import Database.Esqueleto as E +module Database.Esqueleto.Utils + ( true, false + , isInfixOf, hasInfix + , any, all + , SqlIn(..) + ) where + +import ClassyPrelude.Yesod hiding (isInfixOf, (||.), any, all) +import qualified Data.Foldable as F +import qualified Database.Esqueleto as E +import Database.Esqueleto.Utils.TH -- @@ -33,13 +41,13 @@ hasInfix = flip isInfixOf -- | Given a test and a set of values, check whether anyone succeeds the test -- WARNING: SQL leaves it explicitely unspecified whether || is short curcuited (i.e. lazily evaluated) any :: Foldable f => - (a -> SqlExpr (E.Value Bool)) -> f a -> SqlExpr (E.Value Bool) -any test = F.foldr (\needle acc -> acc ||. test needle) false + (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool) +any test = F.foldr (\needle acc -> acc E.||. test needle) false -- | Given a test and a set of values, check whether all succeeds the test -- WARNING: SQL leaves it explicitely unspecified whether && is short curcuited (i.e. lazily evaluated) all :: Foldable f => - (a -> SqlExpr (E.Value Bool)) -> f a -> SqlExpr (E.Value Bool) -all test = F.foldr (\needle acc -> acc &&. test needle) true - + (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool) +all test = F.foldr (\needle acc -> acc E.&&. test needle) true +$(sqlInTuples [2..16]) diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs new file mode 100644 index 000000000..7ae382959 --- /dev/null +++ b/src/Database/Esqueleto/Utils/TH.hs @@ -0,0 +1,48 @@ +module Database.Esqueleto.Utils.TH + ( SqlIn(..) + , sqlInTuple, sqlInTuples + ) where + +import ClassyPrelude + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect) + +import Database.Persist (PersistField) + +import Language.Haskell.TH + +import Data.List (foldr1, foldl) + +class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where + sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool) + +instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where + x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs) + +sqlInTuples :: [Int] -> DecsQ +sqlInTuples = mapM sqlInTuple + +sqlInTuple :: Int -> DecQ +sqlInTuple arity = do + tyVars <- replicateM arity $ newName "t" + vVs <- replicateM arity $ newName "v" + xVs <- replicateM arity $ newName "x" + xsV <- newName "xs" + + let + matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs) + tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars + + instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|] + [ funD 'sqlIn + [ clause [tupP $ map varP xVs, varP xsV] + ( guardedB + [ normalGE [e|null $(varE xsV)|] [e|E.val False|] + , normalGE [e|otherwise|] [e|foldr1 (E.||.) $ map $(matchE) $(varE xsV)|] + ] + ) [] + ] + ] + + diff --git a/src/Foundation.hs b/src/Foundation.hs index 45ef28c0d..d98795969 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -50,6 +50,7 @@ import Data.Conduit (($$)) import Data.Conduit.List (sourceList) import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import Control.Monad.Except (MonadError(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) @@ -80,6 +81,8 @@ import Data.Bits (Bits(zeroBits)) import Network.Wai.Parse (lbsBackEnd) +import qualified Data.UUID.V4 as UUID + instance DisplayAble b => DisplayAble (E.CryptoID a b) where display = display . ciphertext @@ -2007,9 +2010,11 @@ instance YesodAuth UniWorX where ] userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate + studyTermCandidateIncidence <- liftIO UUID.nextRandom + now <- liftIO getCurrentTime let - userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures' + userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now userStudyFeatures' = do (k, v) <- ldapData guard $ k == Attr "dfnEduPersonFeaturesOfStudy" @@ -2017,16 +2022,33 @@ instance YesodAuth UniWorX where Right str <- return $ Text.decodeUtf8' v' return str - fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures - -- TODO: just update StudyFeaturesUpdate in case of no-change - -- TODO: keep old is referenced in CourseParticipant - lift $ deleteWhere [StudyFeaturesUser ==. userId] + termNames = do + (k, v) <- ldapData + guard $ k == Attr "dfnEduPersonFieldOfStudyString" + v' <- v + Right str <- return $ Text.decodeUtf8' v' + return str - forM_ fs $ \StudyFeatures{..} -> do + fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures + + let + studyTermCandidates = Set.fromList $ do + studyTermCandidateName <- termNames + StudyFeatures{ studyFeaturesField = StudyTermsKey' studyTermCandidateKey } <- fs + return StudyTermCandidate{..} + + lift . E.update $ \f -> do + E.set f [ StudyFeaturesValid E.=. E.false ] + E.where_ . E.not_ $ (f E.^. StudyFeaturesUser, f E.^. StudyFeaturesDegree, f E.^. StudyFeaturesField, f E.^. StudyFeaturesType, f E.^. StudyFeaturesSemester) + `E.sqlIn` map (\StudyFeatures{..} -> (E.Value studyFeaturesUser, E.Value studyFeaturesDegree, E.Value studyFeaturesField, E.Value studyFeaturesType, E.Value studyFeaturesSemester) ) fs + + lift . insertMany_ $ Set.toList studyTermCandidates + forM_ fs $ \f@StudyFeatures{..} -> do lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing - lift $ insertMany_ fs + void . lift $ insertUnique f + return $ Authenticated userId Nothing -> acceptExisting diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index e635731b3..78ef16a73 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -320,7 +320,7 @@ postCRegisterR tid ssh csh = do addMessageI Info MsgCourseDeregisterOk | codeOk -> do actTime <- liftIO getCurrentTime - regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime + regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime Nothing -- TODO when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk | otherwise -> addMessageI Warning MsgCourseSecretWrong _other -> return () -- TODO check this! diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 9dbce258a..880321e01 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -8,12 +8,12 @@ import Text.Parsec import Text.Parsec.Text -parseStudyFeatures :: UserId -> Text -> Either Text [StudyFeatures] -parseStudyFeatures uId = first tshow . parse (pStudyFeatures uId <* eof) "" +parseStudyFeatures :: UserId -> UTCTime -> Text -> Either Text [StudyFeatures] +parseStudyFeatures uId now = first tshow . parse (pStudyFeatures uId now <* eof) "" -pStudyFeatures :: UserId -> Parser [StudyFeatures] -pStudyFeatures studyFeaturesUser = do +pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures] +pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do studyFeaturesDegree <- StudyDegreeKey' <$> pKey void $ string "$$" @@ -29,6 +29,7 @@ pStudyFeatures studyFeaturesUser = do void $ char '!' studyFeaturesSemester <- decimal + let studyFeaturesValid = True return StudyFeatures{..} pStudyFeature `sepBy1` char '#' diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 67e5a3f46..2b842d487 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -39,6 +39,7 @@ import Utils.Lens.TH import Import hiding (pi) import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue) import qualified Database.Esqueleto.Internal.Language as E (From) @@ -89,9 +90,6 @@ import qualified Data.ByteString.Base64.URL as Base64 (encode) import qualified Data.ByteString.Lazy as LBS -$(sqlInTuples [2..16]) - - data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) } data SortDirection = SortAsc | SortDesc @@ -370,7 +368,7 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter) data DBTable m x = forall a r r' h i t k k'. ( ToSortable h, Functor h - , E.SqlSelect a r, SqlIn k k', DBTableKey k' + , E.SqlSelect a r, E.SqlIn k k', DBTableKey k' , PathPiece i, Eq i , E.From E.SqlQuery E.SqlExpr E.SqlBackend t ) => DBTable @@ -642,7 +640,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db -> do E.limit l E.offset (psPage * l) - Just ps -> E.where_ $ dbtRowKey t `sqlIn` ps + Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps _other -> return () Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res) diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs index 44648cf21..187c679a6 100644 --- a/src/Handler/Utils/Table/Pagination/Types.hs +++ b/src/Handler/Utils/Table/Pagination/Types.hs @@ -6,8 +6,6 @@ module Handler.Utils.Table.Pagination.Types , sortable , ToSortable(..) , SortableP(..) - , SqlIn(..) - , sqlInTuples , DBTableInvalid(..) ) where @@ -20,13 +18,6 @@ import Data.CaseInsensitive (CI) import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey) -import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect) - -import Language.Haskell.TH - -import Data.List (foldr1, foldl) - newtype FilterKey = FilterKey { _unFilterKey :: CI Text } deriving (Show, Read, Generic) @@ -67,38 +58,6 @@ instance ToSortable Headless where pSortable = Nothing -class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where - sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool) - -instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where - x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs) - -sqlInTuples :: [Int] -> DecsQ -sqlInTuples = mapM sqlInTuple - -sqlInTuple :: Int -> DecQ -sqlInTuple arity = do - tyVars <- replicateM arity $ newName "t" - vVs <- replicateM arity $ newName "v" - xVs <- replicateM arity $ newName "x" - xsV <- newName "xs" - - let - matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs) - tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars - - instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|] - [ funD 'sqlIn - [ clause [tupP $ map varP xVs, varP xsV] - ( guardedB - [ normalGE [e|null $(varE xsV)|] [e|E.val False|] - , normalGE [e|otherwise|] [e|foldr1 (E.||.) $ map $(matchE) $(varE xsV)|] - ] - ) [] - ] - ] - - data DBTableInvalid = DBTIRowsMissing Int deriving (Eq, Ord, Read, Show, Generic, Typeable) diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 94655817d..d9cd98342 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -8,6 +8,7 @@ module Model.Types , module Numeric.Natural , module Mail , module Utils.DateTime + , module Data.UUID.Types ) where import ClassyPrelude