chore(db): use runDBRead more often

src/Handler/Admin/Avs.hs

@@ -560,7 +560,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
         , sortable (Just "avspersonno")  (i18nCell MsgAvsPersonNo)    $ \(view  resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a
         -- , colUserCompany
         , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
-            companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
+            companies' <- liftHandler . runDBRead . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
               E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
               E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
               E.orderBy [E.asc (comp E.^. CompanyName)]
@@ -639,8 +639,8 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
       mkOption :: E.Value Text -> Option Text
       mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
       suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
-      suggestionsBlock   = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_)
+      suggestionsBlock   = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons E.not_)
-      suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
+      suggestionsUnblock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons id)
 
       acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
       acts = mconcat
@@ -949,4 +949,3 @@ getProblemAvsErrorR = do
   siteLayoutMsg MsgMenuAvsSynchError $ do
     setTitleI MsgMenuAvsSynchError
     [whamlet|^{avsSyncErrTbl}|]
-    

src/Handler/Course/Register.hs

@@ -68,7 +68,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
       | otherwise
         -> return $ FormSuccess ()
 
-    mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \course -> do
+    mayViewCourseAfterDeregistration <- liftHandler . runDBRead $ E.selectExists . E.from $ \course -> do
       E.where_ $  course E.^. CourseId E.==. E.val cid
            E.&&. (       isSchoolAdminLike muid ata (course E.^. CourseSchool)
                    E.||. mayEditCourse muid ata course

src/Handler/Firm.hs

@@ -119,7 +119,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
     faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
 
     faHandler (FirmActNotifyData, Set.toList -> fids) = do
-      usrs <- runDB $ E.select $ E.distinct $ do
+      usrs <- runDBRead $ E.select $ E.distinct $ do
         (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
         E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids
         return $ usr E.^. UserId
@@ -1374,14 +1374,14 @@ handleFirmCommR ultDest cs = do
     csKeys = CompanyKey <$> cs
   mbUser <- maybeAuthId
   -- get employees of chosen companies
-  empys <- mkCompanyUsrList <$> runDB (E.select $ do
+  empys <- mkCompanyUsrList <$> runDBRead (E.select $ do
       (emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser)
       E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys
       E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany]
       return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId)
     )
   -- get supervisors of employees
-  sprs <- mkCompanyUsrList <$> runDB (E.select $ do
+  sprs <- mkCompanyUsrList <$> runDBRead (E.select $ do
       (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser)
       E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys)
         E.||. (spr E.^. UserId E.=?. E.val mbUser)

src/Handler/LMS.hs

@@ -792,7 +792,7 @@ viewLmsUserR :: Maybe SchoolId -> Maybe QualificationShorthand -> CryptoUUIDUser
 viewLmsUserR msid mqsh uuid = do
   uid <- decrypt uuid
   now <- liftIO getCurrentTime
-  (user@User{userDisplayName}, quals, qblocks) <- runDB $ do 
+  (user@User{userDisplayName}, quals, qblocks) <- runDBRead $ do
     usr <- get404 uid
     qs  <- Ex.select $ do
           (qual :& qualUsr :& lmsUsr) <-

src/Handler/Profile.hs

@@ -156,7 +156,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
   where
     schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
     schoolsForm' = do
-      allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName]
+      allSchools <- liftHandler . runDBRead $ selectList [] [Asc SchoolName]
 
       let
         schoolForm (Entity ssh School{schoolName})

src/Handler/SAP.hs

@@ -98,7 +98,7 @@ getQualificationSAPDirectR = do
   now   <- liftIO getCurrentTime
   fdate <- formatTime' "%Y%m%d_%H-%M" now
   let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
-  qualUsers <- runDB $ E.select $ do
+  qualUsers <- runDBRead $ E.select $ do
     (qual :& qualUser :& user :& qualBlock) <-
       E.from $ E.table @Qualification
       `E.innerJoin` E.table @QualificationUser

src/Handler/Users.hs

@@ -121,7 +121,7 @@ postUsersR = do
 --           (AdminUserR <$> encrypt uid)
 --           (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
       , sortable (Just "user-supervisor") (i18nCell MsgTableSupervisor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
-            supervisors' <- liftHandler . runDB . E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
+            supervisors' <- liftHandler . runDBRead . E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
               E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
               E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
               E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
@@ -135,7 +135,7 @@ postUsersR = do
       , sortable (Just "ldap-sync")  (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
       , flip foldMap universeF $ \function ->
           sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
-            schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
+            schools <- liftHandler . runDBRead . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
               E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
               E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
                    E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
@@ -148,7 +148,7 @@ postUsersR = do
                   <li>#{sh}
               |]
       , sortable (Just "system-function") (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
-          let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDB $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
+          let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDBRead $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
            in listCell' getFunctions i18nCell
       , sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgTableActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
           { formCellAttrs    = []

src/Handler/Utils/Avs.hs

@@ -171,11 +171,11 @@ lookupAvsUsers apis = do
 updateReceivers :: UserId -> Handler  (Entity User, [Entity User], Bool)
 updateReceivers uid = do
   -- First perform AVS update for receiver
-  runDB (getBy (UniqueUserAvsUser uid)) >>= \case
+  runDBRead (getBy (UniqueUserAvsUser uid)) >>= \case
       Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> catchAll2log $ upsertAvsUserById apid
       Nothing -> return ()
   -- Retrieve updated user and supervisors now
-  (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,)
+  (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDBRead $ (,)
     <$> getJustEntity uid
     <*> (E.select $ do
           (usrSuper :& usrAvs) <-
@@ -194,7 +194,7 @@ updateReceivers uid = do
   if null receiverIDs
     then directResult
     else do
-      receivers <- runDB $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
+      receivers <- runDBRead $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
       if null receivers
         then directResult
         else return (underling, receivers, uid `elem` (entityKey <$> receivers))
@@ -450,7 +450,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
 
 linktoAvsUserByUIDs :: Set UserId -> Handler ()
 linktoAvsUserByUIDs uids = do
-    ips <- runDB $ E.select $ do
+    ips <- runDBRead $ E.select $ do
       usr <- E.from $ E.table @User
       let uid = usr E.^. UserId
           ipn = usr E.^. UserCompanyPersonalNumber
@@ -490,7 +490,7 @@ createAvsUserById muid api = do
         -- check for matching existing user
         let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
             -- persMail  :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
-        oldUsr <- runDB $ do
+        oldUsr <- runDBRead $ do
           mbUid <- if isJust muid
               then return muid
               else firstJustM $ catMaybes
@@ -736,15 +736,15 @@ guessAvsUser :: Text -> Handler (Maybe UserId)
 guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
   | prefix=="AVSID:" =
       let avsid = AvsPersonId nr in
-      runDB (getBy $ UniqueUserAvsId avsid)          >>= \case
+      runDBRead (getBy $ UniqueUserAvsId avsid)          >>= \case
         (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
         Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid
   | prefix=="AVSNO:" =
-      runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
+      runDBRead (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
 guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
     catchAVS2message $ upsertAvsUserByCard someavsid >>= \case
       Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
-        runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
+        runDBRead (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
       other -> return other
 guessAvsUser someid = do
     try (runDB $ ldapLookupAndUpsert someid) >>= \case

src/Handler/Utils/Qualification.hs

@@ -112,12 +112,14 @@ validQualification' cutoff qualUser =
            E.&&. quserBlock' False cutoff qualUser
 
 -- selectValidQualifications :: QualificationId -> [UserId] -> UTCTime -> DB [Entity QualificationUser]
-selectValidQualifications ::
+-- selectValidQualifications ::
-  ( MonadIO m
+--   ( MonadIO m
-  , BackendCompatible SqlBackend backend
+--   , BackendCompatible SqlBackend backend
-  , PersistQueryRead backend
+--   , PersistQueryRead backend
-  , PersistUniqueRead backend
+--   , PersistUniqueRead backend
-  ) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
+--   ) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
+selectValidQualifications :: (MonadIO m, E.SqlBackendCanRead backend)
+  => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
 selectValidQualifications qid uids cutoff =
   -- cutoff <- utctDay <$> liftIO getCurrentTime
   E.select $ do

src/Handler/Utils/Widgets.hs

@@ -62,7 +62,7 @@ userWidget :: HasUser c => c -> Widget
 userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname)
 
 userIdWidget :: UserId -> Widget
-userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDB $ get uid)
+userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDBRead $ get uid)
 
 linkUserWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget
 linkUserWidget lnk (Entity uid usr) = do
@@ -71,7 +71,7 @@ linkUserWidget lnk (Entity uid usr) = do
 
 -- | like linkUserWidget, but on Id only. Requires DB access, use with caution
 linkUserIdWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> UserId -> Widget
-linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDB $ get uid)
+linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDBRead $ get uid)
 
 userEmailWidget :: HasUser c => c -> Widget
 userEmailWidget x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname)

src/Jobs/Handler/SynchroniseAvs.hs

@@ -101,7 +101,7 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
 
 dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX
 dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
-    jobs <- runDB $ do
+    jobs <- runDBRead $ do
       E.select (do
           (avsSync :& usrAvs) <- E.from $  E.table @AvsSync
                               `E.leftJoin` E.table @UserAvs