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

refactor(dbtable): optimize

Browse Source
This commit is contained in:
Gregor Kleen 2020-03-03 15:16:23 +01:00
parent 42089e17a1
commit 432a77f705
18 changed files with 140 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
src/CryptoID.hs
View File

@ -15,9 +15,9 @@ import Model
import CryptoID.TH
import qualified Data.CryptoID as E
import Data.CryptoID.Poly.ImplicitNamespace
import Data.UUID.Cryptographic.ImplicitNamespace
import System.FilePath.Cryptographic.ImplicitNamespace
import Data.CryptoID.Poly.ImplicitNamespace hiding (decrypt, encrypt)
import Data.UUID.Cryptographic.ImplicitNamespace hiding (decrypt, encrypt)
import System.FilePath.Cryptographic.ImplicitNamespace hiding (decrypt, encrypt)
import qualified Data.Text as Text
@ -28,6 +28,28 @@ import Data.Aeson.Encoding (text)
import Text.Blaze (ToMarkup(..))
import qualified Data.CryptoID.Class.ImplicitNamespace as I
encrypt :: forall plaintext ciphertext m.
( I.HasCryptoID ciphertext plaintext m
, KnownSymbol (CryptoIDNamespace ciphertext plaintext)
, MonadHandler m
, Typeable ciphertext
, PathPiece plaintext
)
=> plaintext -> m (I.CryptoID ciphertext plaintext)
encrypt plain = $cachedHereBinary (toPathPiece plain) $ I.encrypt plain
decrypt :: forall plaintext ciphertext m.
( I.HasCryptoID ciphertext plaintext m
, MonadHandler m
, Typeable plaintext
, PathPiece ciphertext
)
=> I.CryptoID ciphertext plaintext -> m plaintext
decrypt cipher = $cachedHereBinary (toPathPiece $ ciphertext cipher) $ I.decrypt cipher
instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where
type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey

30
src/Foundation.hs
View File

@ -58,7 +58,7 @@ import Data.Conduit.List (sourceList)
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import Control.Monad.Except (MonadError(..), ExceptT)
import Control.Monad.Except (MonadError(..))
import Control.Monad.Trans.State (execStateT)
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Memo.Class (MonadMemo(..), for4)
@ -448,11 +448,11 @@ tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route o
tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
lift . validateToken mAuthId route isWrite =<< askTokenUnsafe
tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
AdminHijackUserR cID -> exceptT return return $ do
AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
uid <- decrypt cID
otherSchoolsFunctions <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] []
mySchools <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] []
otherSchoolsFunctions <- lift . $cachedHereBinary uid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] []
mySchools <- lift . $cachedHereBinary myUid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] []
guardMExceptT (otherSchoolsFunctions `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
return Authorized
r -> $unsupportedAuthPredicate AuthNoEscalation r
@ -509,7 +509,7 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
return Authorized
tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
resList <- $cachedHereBinary (mAuthId) . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
resList <- $cachedHereBinary mAuthId . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
@ -536,9 +536,9 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
return Authorized
tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of
CExamR tid ssh csh examn _ -> exceptT return return $ do
CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isCorrector <- $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId
E.&&. examCorrector E.^. ExamCorrectorUser E.==. E.val authId
E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
@ -1036,14 +1036,14 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB ()
authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from
-- participant is currently registered
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant has at least one submission
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
@ -1052,7 +1052,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is member of a submissionGroup
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant
@ -1060,7 +1060,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is a sheet corrector
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant
@ -1068,7 +1068,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is a tutorial user
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant
@ -1076,7 +1076,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is tutor for this course
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
E.where_ $ tutor E.^. TutorUser E.==. E.val participant
@ -1084,7 +1084,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is lecturer for this course
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
@ -1419,7 +1419,7 @@ instance Finite (ButtonClass UniWorX)
instance PathPiece (ButtonClass UniWorX) where
toPathPiece BCIsButton = "btn"
toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass
fromPathPiece = finiteFromPathPiece
fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF
embedRenderMessage ''UniWorX ''ButtonSubmit id
instance Button UniWorX ButtonSubmit where

2
src/Handler/Admin/ErrorMessage.hs
View File

@ -6,8 +6,6 @@ import Import
import Handler.Utils
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
import Control.Monad.Trans.Except
getAdminErrMsgR, postAdminErrMsgR :: Handler Html
getAdminErrMsgR = postAdminErrMsgR

8
src/Handler/Corrections.hs
View File

@ -137,7 +137,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
mkRoute = do
cid <- mkCid
return $ CSubmissionR tid ssh csh shn cid SubShowR
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{cid}|])
in anchorCellCM $cacheIdentHere mkRoute (mkCid >>= \cid -> [whamlet|#{cid}|])
colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary))
colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> encrypt subId
@ -149,14 +149,14 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB
ssh = course ^. _4
link cid = CourseR tid ssh csh $ CUserR cid
protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) ->
anchorCellM (link <$> encrypt userId) $ case mPseudo of
anchorCellCM $cacheIdentHere (link <$> encrypt userId) $ case mPseudo of
Nothing -> nameWidget userDisplayName userSurname
Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review _PseudonymText p})|]
in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let
protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer)
protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellCM $cacheIdentHere (AdminUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer)
in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary))
@ -171,7 +171,7 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E
return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this
in mconcat
[ anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
[ anchorCellCM $cacheIdentHere mkRoute $(widgetFile "widgets/rating/rating")
, writerCell $ do
let
summary :: SheetTypeSummary

8
src/Handler/Course/Application/List.hs
View File

@ -264,13 +264,13 @@ postCApplicationsR tid ssh csh = do
allocationLink :: Allocation -> SomeRoute UniWorX
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
participantLink uid = do
participantLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (SomeRoute UniWorX)
participantLink uid = liftHandler $ do
cID <- encrypt uid
return . SomeRoute . CourseR tid ssh csh $ CUserR cID
applicationLink :: MonadCrypto m => CourseApplicationId -> m (SomeRoute UniWorX)
applicationLink appId = do
applicationLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseApplicationId -> m (SomeRoute UniWorX)
applicationLink appId = liftHandler $ do
cID <- encrypt appId
return . SomeRoute $ CApplicationR tid ssh csh cID CAEditR

4
src/Handler/ExamOffice/Exam.hs
View File

@ -204,8 +204,8 @@ postEGradesR tid ssh csh examn = do
userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] []
let
participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
participantLink partId = do
participantLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (SomeRoute UniWorX)
participantLink partId = liftHandler $ do
cID <- encrypt partId
return . SomeRoute . CourseR tid ssh csh $ CUserR cID

2
src/Handler/Sheet.hs
View File

@ -30,8 +30,6 @@ import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
-- import qualified Database.Esqueleto.Internal.Sql as E
import Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE)
import qualified Data.Set as Set
import qualified Data.Map as Map

3
src/Handler/Utils/Communication.hs
View File

@ -56,7 +56,8 @@ instance PathPiece RecipientCategory where
toPathPiece RecipientCustom = "custom"
toPathPiece (RecipientGroup g) = toPathPiece g
fromPathPiece = finiteFromPathPiece
fromPathPiece "custom" = Just RecipientCustom
fromPathPiece t = RecipientGroup <$> fromPathPiece t
instance RenderMessage UniWorX RecipientCategory where
renderMessage foundation ls = \case

2
src/Handler/Utils/Csv.hs
View File

@ -36,8 +36,6 @@ import qualified Data.ByteString.Lazy as LBS
import qualified Data.Attoparsec.ByteString.Lazy as A
import Control.Monad.Except (ExceptT)
import Handler.Utils.DateTime
import Data.Time.Format (iso8601DateFormat)

3
src/Handler/Utils/Form.hs
View File

@ -38,7 +38,6 @@ import qualified Data.Set as Set
import Data.Map ((!))
import qualified Data.Map as Map
import Control.Monad.Trans.Except (throwE, runExceptT)
import Control.Monad.Writer.Class
import Control.Monad.Error.Class (MonadError(..))
@ -1083,6 +1082,8 @@ optionsPersistCryptoId :: forall site backend a msg.
( YesodPersist site
, PersistQueryRead backend
, HasCryptoUUID (Key a) (HandlerFor site)
, KnownSymbol (CryptoIDNamespace UUID (Key a))
, PathPiece (Key a)
, RenderMessage site msg
, YesodPersistBackend site ~ backend
, PersistRecordBackend a backend

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

@ -35,6 +35,7 @@ module Handler.Utils.Table.Pagination
, anchorCell, anchorCell', anchorCellM, anchorCellM'
, linkEitherCell, linkEitherCellM, linkEitherCellM'
, maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM'
, cellTooltip
, listCell
, formCell, DBFormResult(..), getDBFormResult
@ -153,14 +154,8 @@ data SortDirection = SortAsc | SortDesc
instance Universe SortDirection
instance Finite SortDirection
instance PathPiece SortDirection where
toPathPiece SortAsc = "asc"
toPathPiece SortDesc = "desc"
fromPathPiece = finiteFromPathPiece
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
} ''SortDirection
nullaryPathPiece ''SortDirection $ camelToPathPiece' 1
pathPieceJSON ''SortDirection
sqlSortDirection :: t -> (SortColumn t, SortDirection) -> [E.SqlExpr E.OrderBy]
sqlSortDirection t (SortColumn e , SortAsc ) = pure . E.asc $ e t
@ -1291,6 +1286,7 @@ cellTooltip msg = cellContents.mapped %~ (<> tipWdgt)
<div .tooltip__content>_{msg}
|]
-- | Always display widget; maybe a link if user is Authorized.
-- Also see variant `linkEmptyCell`
anchorCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => url -> wgt -> DBCell m a
@ -1308,8 +1304,14 @@ anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX url -> wgt -> DBCell m a
anchorCellM routeM widget = anchorCellM' routeM id (const widget)
anchorCellCM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX url -> wgt -> DBCell m a
anchorCellCM cache routeM widget = anchorCellCM' cache routeM id (const widget)
anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget)
anchorCellCM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
anchorCellCM' cache xM x2route x2widget = linkEitherCellCM' cache xM x2route (x2widget, x2widget)
maybeAnchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => MaybeT (WidgetFor UniWorX) url -> wgt -> DBCell m a
maybeAnchorCellM routeM widget = maybeAnchorCellM' routeM id (const widget)
@ -1333,6 +1335,16 @@ linkEitherCellM' :: forall m url wgt wgt' a x.
=> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = maybeLinkEitherCellM' (lift xM) x2route (x2widgetAuth, x2widgetUnauth . fromJust)
linkEitherCellCM' :: forall m url wgt wgt' a x cache.
( HasRoute UniWorX url
, ToWidget UniWorX wgt
, ToWidget UniWorX wgt'
, IsDBTable m a
, Binary cache
)
=> cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
linkEitherCellCM' cache xM x2route (x2widgetAuth,x2widgetUnauth) = maybeLinkEitherCellCM' (Just . toStrict $ B.encode cache) (lift xM) x2route (x2widgetAuth, x2widgetUnauth . fromJust)
maybeLinkEitherCellM' :: forall m url wgt wgt' a x.
( HasRoute UniWorX url
, ToWidget UniWorX wgt
@ -1340,7 +1352,16 @@ maybeLinkEitherCellM' :: forall m url wgt wgt' a x.
, IsDBTable m a
)
=> MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (x -> wgt, Maybe x -> wgt') -> DBCell m a
maybeLinkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
maybeLinkEitherCellM' = maybeLinkEitherCellCM' Nothing
maybeLinkEitherCellCM' :: forall m url wgt wgt' a x.
( HasRoute UniWorX url
, ToWidget UniWorX wgt
, ToWidget UniWorX wgt'
, IsDBTable m a
)
=> Maybe ByteString -> MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (x -> wgt, Maybe x -> wgt') -> DBCell m a
maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
x' <- runMaybeT xM
case x' of
Just x -> do
@ -1348,17 +1369,15 @@ maybeLinkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
widget, widgetUnauth :: Widget
widget = toWidget $ x2widgetAuth x
widgetUnauth = toWidget . x2widgetUnauth $ Just x
authResult <- liftHandler $ isAuthorized (urlRoute route) False
authResult <- liftHandler . maybe id $cachedHereBinary mCache . hasReadAccessTo $ urlRoute route
linkUrl <- toTextUrl route
case authResult of
Authorized -> $(widgetFile "table/cell/link") -- show allowed link
_otherwise -> widgetUnauth -- show alternative widget
if
| authResult -> $(widgetFile "table/cell/link") -- show allowed link
| otherwise -> widgetUnauth
_otherwise -> do
toWidget $ x2widgetUnauth Nothing
listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a
listCell xs mkCell = review dbCell . ([], ) $ do
cells <- forM xs $

6
src/Import/NoModel.hs
View File

@ -90,6 +90,10 @@ import Control.Monad.Trans.Writer.Lazy as Import
( writer, Writer, runWriter, mapWriter, execWriter
, WriterT(..), mapWriterT, execWriterT
)
import Control.Monad.Trans.Except as Import
( except, Except, runExcept, mapExcept
, ExceptT(..), runExceptT, mapExceptT, throwE
)
import Control.Monad.Base as Import
import Control.Monad.Catch as Import hiding (Handler(..))
import Control.Monad.Trans.Control as Import hiding (embed)
@ -167,6 +171,8 @@ import Control.Arrow as Import (Kleisli(..))
import Data.Encoding as Import (DynEncoding, decodeLazyByteString, encodeLazyByteString)
import Data.Encoding.UTF8 as Import (UTF8(UTF8))
import GHC.TypeLits as Import (KnownSymbol)
import Control.Monad.Trans.RWS (RWST)

13
src/Model/Migration/Types.hs
View File

@ -10,6 +10,7 @@ import qualified Model as Current
import qualified Model.Types.TH.JSON as Current
import Data.Universe
import Data.Universe.TH
data SheetType
@ -32,16 +33,8 @@ data UploadMode = NoUpload | Upload { unpackZips :: Bool }
deriveJSON defaultOptions ''UploadMode
Current.derivePersistFieldJSON ''UploadMode
instance Universe UploadMode where
universe = NoUpload : (Upload <$> universe)
instance Finite UploadMode
instance PathPiece UploadMode where
toPathPiece = \case
NoUpload -> "no-upload"
Upload True -> "unpack"
Upload False -> "no-unpack"
fromPathPiece = finiteFromPathPiece
deriveFinite ''UploadMode
finitePathPiece ''UploadMode ["no-upload", "no-unpack", "unpack"]
data SheetSubmissionMode = NoSubmissions
| CorrectorSubmissions

6
src/Model/Tokens.hs
View File

@ -39,6 +39,8 @@ import Data.Time.Clock.POSIX
import Data.Binary (Binary)
import qualified Data.CryptoID.Class.ImplicitNamespace as I
-- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
@ -96,7 +98,7 @@ tokenToJSON :: forall m.
--
-- Monadic context is needed because `AuthId`s are encrypted during encoding
tokenToJSON BearerToken{..} = do
cID <- either (return . Left) (fmap Right . encrypt) tokenAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m))))
cID <- either (return . Left) (fmap Right . I.encrypt) tokenAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m))))
let stdPayload = Jose.JwtClaims
{ jwtIss = Just $ toPathPiece tokenIssuedBy
, jwtSub = Nothing
@ -128,7 +130,7 @@ tokenParseJSON :: forall site.
-- It's usually easier to use `Utils.Tokens.tokenParseJSON'`
tokenParseJSON v@(Object o) = do
tokenAuthority' <- lift $ (Right <$> o .: "authority") <|> (Left <$> o .: "authority") :: ReaderT CryptoIDKey Parser (Either Value (CryptoUUID (AuthId site)))
tokenAuthority <- either (return . Left) (fmap Right . decrypt) tokenAuthority'
tokenAuthority <- either (return . Left) (fmap Right . I.decrypt) tokenAuthority'
tokenRoutes <- lift $ o .:? "routes"
tokenAddAuth <- lift $ o .:? "add-auth"

7
src/Model/Types/Sheet.hs
View File

@ -157,12 +157,7 @@ derivePersistField "SheetFileType"
instance Universe SheetFileType
instance Finite SheetFileType
instance PathPiece SheetFileType where
toPathPiece SheetExercise = "file"
toPathPiece SheetHint = "hint"
toPathPiece SheetSolution = "solution"
toPathPiece SheetMarking = "marking"
fromPathPiece = finiteFromPathPiece
finitePathPiece ''SheetFileType ["file", "hint", "solution", "marking"]
sheetFile2markup :: SheetFileType -> Markup
sheetFile2markup SheetExercise = iconSFTQuestion

4
src/Utils.hs
View File

@ -56,6 +56,7 @@ import Control.Monad.Morph (hoist)
import Language.Haskell.TH
import Language.Haskell.TH.Instances ()
import Instances.TH.Lift ()
import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
import Text.Shakespeare.Text (st)
@ -916,6 +917,9 @@ encodedSecretBoxOpen ciphertext = do
cachedByBinary :: (Binary a, Typeable b, MonadHandler m) => a -> m b -> m b
cachedByBinary k = cachedBy (toStrict $ Binary.encode k)
cacheIdentHere :: Q Exp
cacheIdentHere = TH.lift =<< location
cachedHere :: Q Exp
cachedHere = do
loc <- location

54
src/Utils/PathPiece.hs
View File

@ -1,6 +1,5 @@
module Utils.PathPiece
( finiteFromPathPiece
, nullaryToPathPiece
( nullaryToPathPiece
, nullaryPathPiece, finitePathPiece
, splitCamel
, camelToPathPiece, camelToPathPiece'
@ -17,9 +16,11 @@ import Data.Universe
import qualified Data.Text as Text
import qualified Data.Char as Char
import Data.Map ((!), (!?))
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.HashMap.Strict as HashMap
import Numeric.Natural
import Data.List (foldl)
@ -30,10 +31,17 @@ import qualified Data.Aeson.Types as Aeson
import Control.Monad.Fail
finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a
finiteFromPathPiece text = case filter (\c -> toPathPiece c == text) universeF of
[x] -> Just x
_xs -> Nothing
mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp)
mkFiniteFromPathPiece finiteType = do
mapName <- newName $ "pathPieceMap" <> nameBase finiteType
let
decs = sequence
[ pragInlD mapName NoInline FunLike AllPhases
, sigD mapName [t|HashMap Text $(conT finiteType)|]
, funD mapName
[ clause [] (normalB [e|HashMap.fromList $ map (toPathPiece &&& id) universeF|]) [] ]
]
(,) <$> decs <*> [e|flip HashMap.lookup $(varE mapName)|]
nullaryToPathPiece :: Name -> (Text -> Text) -> ExpQ
nullaryToPathPiece nullaryType ((. Text.pack) -> mangle) = do
@ -46,22 +54,26 @@ nullaryToPathPiece nullaryType ((. Text.pack) -> mangle) = do
letE [helperDec] $ varE helperName
nullaryPathPiece :: Name -> (Text -> Text) -> DecsQ
nullaryPathPiece nullaryType mangle =
pure <$> instanceD (cxt []) [t|PathPiece $(conT nullaryType)|]
[ funD 'toPathPiece
[ clause [] (normalB $ nullaryToPathPiece nullaryType mangle) [] ]
, funD 'fromPathPiece
[ clause [] (normalB [e|finiteFromPathPiece|]) [] ]
]
nullaryPathPiece nullaryType mangle = do
(finDecs, finExp) <- mkFiniteFromPathPiece nullaryType
sequence . (map return finDecs ++) . pure $
instanceD (cxt []) [t|PathPiece $(conT nullaryType)|]
[ funD 'toPathPiece
[ clause [] (normalB $ nullaryToPathPiece nullaryType mangle) [] ]
, funD 'fromPathPiece
[ clause [] (normalB $ return finExp) [] ]
]
finitePathPiece :: Name -> [Text] -> DecsQ
finitePathPiece finiteType verbs =
pure <$> instanceD (cxt []) [t|PathPiece $(conT finiteType)|]
[ funD 'toPathPiece
[ clause [] (normalB [|(Map.fromList (zip universeF verbs) !)|]) [] ]
, funD 'fromPathPiece
[ clause [] (normalB [e|(Map.fromList (zip verbs universeF) !?)|]) [] ]
]
finitePathPiece finiteType verbs = do
(finDecs, finExp) <- mkFiniteFromPathPiece finiteType
sequence . (map return finDecs ++) . pure $
instanceD (cxt []) [t|PathPiece $(conT finiteType)|]
[ funD 'toPathPiece
[ clause [] (normalB [|(Map.fromList (zip universeF verbs) !)|]) [] ]
, funD 'fromPathPiece
[ clause [] (normalB $ return finExp) [] ]
]
splitCamel :: Textual t => t -> [t]

2
test/Database/Fill.hs
View File

@ -935,7 +935,7 @@ fillDb = do
void . insertMany $ do
uid <- manyUsers
return $ CourseParticipant bs uid now Nothing Nothing
forM_ [1..5] $ \shNr -> do
forM_ [1..14] $ \shNr -> do
shId <- insert Sheet
{ sheetCourse = bs
, sheetName = CI.mk [st|Blatt #{tshow shNr}|]