chore(avs): remove avs_cards, add generic queries WIP
This commit is contained in:
parent
ad2375b338
commit
b39f69df12
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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]
|
||||
|
||||
@ -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
|
||||
@ -129,7 +129,6 @@ makeClassyFor_ ''LmsUser
|
||||
-- makeClassyFor_ ''LmsUserStatus
|
||||
makeClassyFor_ ''LmsReport
|
||||
makeClassyFor_ ''UserAvs
|
||||
makeClassyFor_ ''UserAvsCard
|
||||
|
||||
makeLenses_ ''UserCompany
|
||||
makeLenses_ ''Company
|
||||
|
||||
@ -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|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]
|
||||
let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user