diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index e42a02bf0..85a6a2a52 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -585,8 +585,7 @@ getForProfileDataR cID = do
makeProfileData :: Entity User -> DB Widget
makeProfileData (Entity uid User{..}) = do
now <- liftIO getCurrentTime
- avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
- -- avsCards <- maybe (pure mempty) (\a -> selectList [UserAvsCardPersonId ==. userAvsPersonId a] []) avsId
+ avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs
index a70285bba..68fe14c19 100644
--- a/src/Handler/Utils/Avs.hs
+++ b/src/Handler/Utils/Avs.hs
@@ -49,7 +49,7 @@ import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E
-
+import Servant.Client (ClientError)
@@ -573,12 +573,48 @@ updateReceivers uid = do
------------------
-- CR3 Functions
+
+class SomeAvsQuery q where
+ type SomeAvsResponse q :: Type
+ pickQuery :: (MonadIO m) => AvsQuery -> q -> m (Either ClientError (SomeAvsResponse q))
+ avsQuery :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
+ avsQuery qry = do
+ qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery)
+ throwLeftM $ qfun qry
+
+-- avsQueryCached :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
+avsQueryCached :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m
+ -- , MonadReader UniWorX ((->) (HandlerSite m))
+ , SomeAvsQuery q
+ , Typeable (SomeAvsResponse q), Binary q, NFData (SomeAvsResponse q)
+ , Binary (SomeAvsResponse q)
+ ) => q -> m (SomeAvsResponse q)
+avsQueryCached qry = do
+ cexpire <- getsYesod $ preview $ _appAvsConf . _Just . _avsCacheExpiry . to Right
+ memcachedBy cexpire qry $ avsQuery qry
+
+instance SomeAvsQuery AvsQueryPerson where
+ type SomeAvsResponse AvsQueryPerson = AvsResponsePerson
+ pickQuery = avsQueryPerson
+
+-- avsPersonQueryCached :: AvsQueryPerson -> Handler AvsResponsePerson
+-- avsPersonQueryCached = avsQueryCached
+
+-- avsPersonQueryCached :: AvsQueryPerson -> Handler AvsResponsePerson
+-- avsPersonQueryCached apq = do
+-- cexpire <- getsYesod $ preview $ _appAvsConf . _Just . _avsCacheExpiry . to Right
+-- memcachedBy cexpire apq $ do
+-- AvsQuery{avsQueryPerson} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
+-- throwLeftM $ avsQueryPerson apq
+
+
+
queryAvsCardNos :: Foldable t => t (Either AvsCardNo AvsFullCardNo) -> Handler (Set AvsPersonId)
queryAvsCardNos = foldMapM queryAvsCardNo
queryAvsCardNo :: Either AvsCardNo AvsFullCardNo -> Handler (Set AvsPersonId)
queryAvsCardNo crd = do
- AvsResponsePerson adps <- avsPersonQueryCached $ qry crd
+ AvsResponsePerson adps <- avsQueryCached $ qry crd
return $ Set.map avsPersonPersonID adps
where
qry (Left acno) = def{ avsPersonQueryCardNo = Just acno }
@@ -586,13 +622,6 @@ queryAvsCardNo crd = do
, avsPersonQueryVersionNo = Just avsFullCardVersion
}
-avsPersonQueryCached :: AvsQueryPerson -> Handler AvsResponsePerson
-avsPersonQueryCached apq = do
- cexpire <- getsYesod $ preview $ _appAvsConf . _Just . _avsCacheExpiry . to Right
- memcachedBy cexpire apq $ do
- AvsQuery{avsQueryPerson} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
- throwLeftM $ avsQueryPerson apq
-
-- A datatype for a specific heterogeneous list
-- data CheckAvsUpdate record iavs = forall typ f. (Eq typ, PersistField typ, Functor f) => CheckAvsUpdate (EntityField record typ) ((typ -> f typ) -> iavs -> f iavs) -- An Record Field and fitting Lens
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index 2fc2f2473..82fe491ea 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -275,7 +275,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
, Just True == matchesMatriculation x || didLdap
-> return $ Just $ Left $ NonEmpty.fromList xs
| not didLdap
- , userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria
+ , userMatrs <- ((Set.toList . Set.fromList) (mapMaybe getTermMatr criteria))
-> mapM doLdap userMatrs >>= maybe (go True) (return . Just) . convertLdapResults . catMaybes
| otherwise
-> return Nothing
@@ -908,7 +908,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
(Nothing, _)
-> return ()
(Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _)
- -> deleteWhere [UserAvsCardPersonId ==. oldAvsId] >> deleteBy (UniqueUserAvsUser oldUserId)
+ -> deleteBy (UniqueUserAvsId oldAvsId)
(Just Entity{entityVal=oldUserAvs}, Nothing)
-> -- deleteBy $ UniqueUserAvsUser oldUserId -- maybe we need this due to double uniqueness?!
void $ upsertBy (UniqueUserAvsId (oldUserAvs ^. _userAvsPersonId)) oldUserAvs{userAvsUser=newUserId} [UserAvsUser =. newUserId]
diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs
index 1ae912248..ab8b73c11 100644
--- a/src/Model/Types/Avs.hs
+++ b/src/Model/Types/Avs.hs
@@ -750,6 +750,7 @@ deriveJSON defaultOptions
-------------
-- Queries --
-------------
+
data AvsQueryPerson = AvsQueryPerson
{ avsPersonQueryCardNo :: Maybe AvsCardNo
, avsPersonQueryVersionNo :: Maybe AvsVersionNo
@@ -786,3 +787,7 @@ deriveJSON defaultOptions ''AvsQueryGetLicences
newtype AvsQuerySetLicences = AvsQuerySetLicences (Set AvsPersonLicence)
deriving (Eq, Ord, Show, Generic)
deriveJSON defaultOptions ''AvsQuerySetLicences
+
+type family SomeAvsQueryResonse a where
+ SomeAvsQueryResonse AvsQueryPerson = AvsResponsePerson
+ SomeAvsQueryResonse AvsQueryContact = AvsResponseContact
\ No newline at end of file
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 4045e937d..a5ac92d7e 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -129,7 +129,6 @@ makeClassyFor_ ''LmsUser
-- makeClassyFor_ ''LmsUserStatus
makeClassyFor_ ''LmsReport
makeClassyFor_ ''UserAvs
-makeClassyFor_ ''UserAvsCard
makeLenses_ ''UserCompany
makeLenses_ ''Company
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index cecba6f38..6482d2bf2 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -729,10 +729,6 @@ fillDb = do
void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 now Nothing Nothing Nothing
void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 now (Just "another message from avs synch") Nothing Nothing
void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 now Nothing Nothing Nothing
- insert_ $ UserAvsCard (AvsPersonId 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") now
- insert_ $ UserAvsCard (AvsPersonId 2) (AvsFullCardNo (AvsCardNo "3344") "1") (AvsDataPersonCard True Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "3344") "1") now
- insert_ $ UserAvsCard (AvsPersonId 3) (AvsFullCardNo (AvsCardNo "7788") "1") (AvsDataPersonCard False Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "7788") "1") now
- insert_ $ UserAvsCard (AvsPersonId 4) (AvsFullCardNo (AvsCardNo "9999") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "9999") "4") now
let f_descr = Just $ htmlToStoredMarkup [shamlet|Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]
let r_descr = Just $ htmlToStoredMarkup [shamlet|
Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]