merge attempt

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

src/Database/Esqueleto/Utils.hs

@@ -1,8 +1,16 @@
-module Database.Esqueleto.Utils where
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
-import ClassyPrelude.Yesod hiding (isInfixOf, (||.))
+module Database.Esqueleto.Utils
-import Data.Foldable as F
+  ( true, false
-import Database.Esqueleto as E
+  , 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)
+  (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
-any test = F.foldr (\needle acc -> acc ||. test needle) false
+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)
+  (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
-all test = F.foldr (\needle acc -> acc &&. test needle) true
+all test = F.foldr (\needle acc -> acc E.&&. test needle) true
-
 
+$(sqlInTuples [2..16])

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)|]
+          ]
+        ) []
+      ]
+    ]
+
+

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
+            termNames = do
-          -- TODO: just update StudyFeaturesUpdate in case of no-change
+              (k, v) <- ldapData
-          -- TODO: keep old is referenced in CourseParticipant
+              guard $ k == Attr "dfnEduPersonFieldOfStudyString"
-          lift $ deleteWhere [StudyFeaturesUser ==. userId]
+              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
 

src/Handler/Course.hs

@@ -327,7 +327,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!

src/Handler/Utils/StudyFeatures.hs

@@ -8,12 +8,12 @@ import Text.Parsec
 import Text.Parsec.Text
 
 
-parseStudyFeatures :: UserId -> Text -> Either Text [StudyFeatures]
+parseStudyFeatures :: UserId -> UTCTime -> Text -> Either Text [StudyFeatures]
-parseStudyFeatures uId = first tshow . parse (pStudyFeatures uId <* eof) ""
+parseStudyFeatures uId now = first tshow . parse (pStudyFeatures uId now <* eof) ""
 
 
-pStudyFeatures :: UserId -> Parser [StudyFeatures]
+pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures]
-pStudyFeatures studyFeaturesUser = do
+pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do
   studyFeaturesDegree <- StudyDegreeKey' <$> pKey
   void $ string "$$"
 
@@ -29,6 +29,7 @@ pStudyFeatures studyFeaturesUser = do
       studyFeaturesType <- pType
       void $ char '!'
       studyFeaturesSemester <- decimal
+      let studyFeaturesValid = True
       return StudyFeatures{..}
 
   pStudyFeature `sepBy1` char '#'

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)

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)
 

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