fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

merge attempt

Browse Source
This commit is contained in:
SJost 2019-02-27 17:37:42 +01:00
commit 801f1f1597
9 changed files with 112 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
models/users
View File

@ -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

26
src/Database/Esqueleto/Utils.hs
View File

@ -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])

48
src/Database/Esqueleto/Utils/TH.hs Normal file
View File

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

36
src/Foundation.hs
View File

@ -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

2
src/Handler/Course.hs
View File

@ -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!

9
src/Handler/Utils/StudyFeatures.hs
View File

@ -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
studyFeaturesType <- pType
void $ char '!'
studyFeaturesSemester <- decimal
let studyFeaturesValid = True
return StudyFeatures{..}
pStudyFeature `sepBy1` char '#'

8
src/Handler/Utils/Table/Pagination.hs
View File

@ -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)

41
src/Handler/Utils/Table/Pagination/Types.hs
View File

@ -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)

1
src/Model/Types.hs
View File

@ -8,6 +8,7 @@ module Model.Types
, module Numeric.Natural
, module Mail
, module Utils.DateTime
, module Data.UUID.Types
) where
import ClassyPrelude