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

Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

Browse Source 
Refactoring for FileTypes complete
This commit is contained in:
SJost 2018-07-21 13:09:15 +02:00
commit d5064151ee
19 changed files with 253 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
config/submission-blacklist Normal file
View File

@ -0,0 +1,12 @@
$# Syntax:
$# - Leere zeilen werden ignoriert
$# - Zeilen, die mit '$#' beginnen, werden ignoriert
$# - Verbleibende Zeilen werden jeweils als `Glob`-Pattern kompiliert
$# Ignoriere rekursiv alle Ordner __MACOSX und ihren Inhalt
**/__MACOSX
**/__MACOSX/*
**/__MACOSX/**/*
$# Ignoriere rekursiv alle Dateien .DS_Store
**/.DS_Store

4
messages/de.msg
View File

@ -174,6 +174,7 @@ UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den
CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden:
CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:
NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden.
RatingBy: Korrigiert von
AchievedBonusPoints: Erreichte Bonuspunkte
@ -221,3 +222,6 @@ AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC ko
LastEdits: Letzte Änderungen
EditedBy name@Text time@Text: Durch #{name} um #{time}
LastEdit: Letzte Änderung
SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}.

2
package.yaml
View File

@ -86,6 +86,8 @@ dependencies:
- tz
- system-locale
- th-lift-instances
- gitrev
- Glob
# The library contains all of our application code. The executable
# defined below is just a thin wrapper.

23
src/Handler/Corrections.hs
View File

@ -14,6 +14,7 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiWayIf #-}
module Handler.Corrections where
@ -195,7 +196,7 @@ data ActionCorrectionsData = CorrDownloadData
correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) -> Handler TypedContent
correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator
((actionRes, table), tableEncoding) <- runFormPost . identForm FIDcorrectorTable $ \csrf -> do
((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
(actionRes, action) <- multiAction actions
return ((,) <$> actionRes <*> selectionRes, table <> action)
@ -215,7 +216,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
when (not $ null alreadyAssigned) $ do
mr <- (toHtml . ) <$> getMessageRender
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
when (not $ null unassigned) $ do
num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] [SubmissionRatingBy =. Just uid]
@ -238,7 +239,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
when (not $ null alreadyAssigned) $ do
mr <- (toHtml . ) <$> getMessageRender
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
when (not $ null unassigned) $ do
(assigned, unassigned) <- assignSubmissions shid (Just unassigned)
@ -247,7 +248,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
when (not $ null unassigned) $ do
mr <- (toHtml . ) <$> getMessageRender
unassigned' <- forM (Set.toList unassigned) $ \sid -> (encrypt sid :: DB CryptoFileNameSubmission)
addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
redirect currentRoute
fmap toTypedContent . defaultLayout $ do
@ -403,7 +404,7 @@ postCorrectionR tid csh shn cid = do
FormSuccess fileSource -> do
uid <- requireAuthId
runDB . runConduit $ transPipe lift fileSource .| extractRatings .| sinkSubmission uid (Right sub) True
runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
addMessageI "success" MsgRatingFilesUpdated
redirect $ CSubmissionR tid csh shn cid CorrectionR
@ -438,10 +439,14 @@ postCorrectionsUploadR = do
FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
FormSuccess files -> do
uid <- requireAuthId
subs <- runDB . runConduit $ transPipe lift files .| extractRatings .| sinkMultiSubmission uid True
subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
mr <- (toHtml .) <$> getMessageRender
addMessage "success" =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True
if
| null subs -> addMessageI "warning" MsgNoCorrectionsUploaded
| otherwise -> do
subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
mr <- (toHtml .) <$> getMessageRender
addMessage "success" =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
defaultLayout $ do
$(widgetFile "corrections-upload")

18
src/Handler/Home.hs
View File

@ -29,6 +29,8 @@ import qualified Database.Esqueleto as E
import Text.Shakespeare.Text
import Development.GitRev
-- import qualified Data.UUID.Cryptographic as UUID
@ -196,9 +198,13 @@ homeUser uid = do
$(widgetFile "dsgvDisclaimer")
getVersionR :: Handler Html
getVersionR = do
let features = $(widgetFile "featureList")
changeLog <- withUrlRenderer $(textFile "ChangeLog.md")
defaultLayout $ do
$(widgetFile "versionHistory")
getVersionR :: Handler TypedContent
getVersionR = selectRep $ do
provideRep . defaultLayout $ do
let features = $(widgetFile "featureList")
gitInfo :: Text
gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")"
changeLog <- withUrlRenderer $(textFile "ChangeLog.md")
$(widgetFile "versionHistory")
provideRep $
return ($gitDescribe :: Text)

2
src/Handler/Sheet.hs
View File

@ -492,7 +492,7 @@ correctorForm shid = do
(defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
loads' <- fmap (Map.fromList [(uid, mempty) | uid <- formCIDs] `Map.union`) $ if
| Map.null currentLoads'
, null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warn" MsgCorrectorsDefaulted)
, null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warning" MsgCorrectorsDefaulted)
| otherwise -> return $ Map.fromList (map (, mempty) formCIDs) `Map.union` currentLoads'
deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')

2
src/Handler/Submission.hs
View File

@ -220,7 +220,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
(Nothing, Just smid) -- no new files, existing submission partners updated
-> return smid
(Just files, _) -- new files
-> runConduit $ transPipe lift files .| extractRatings .| sinkSubmission uid (maybe (Left shid) Right msmid) False
-> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
_ -> error "Impossible, because of definition of `makeSubmissionForm`"
-- Determine members of pre-registered group
groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do

2
src/Handler/Utils.hs
View File

@ -17,7 +17,7 @@ import Handler.Utils.Table as Handler.Utils
import Handler.Utils.Table.Pagination as Handler.Utils
import Handler.Utils.Zip as Handler.Utils
import Handler.Utils.Rating as Handler.Utils
import Handler.Utils.Rating as Handler.Utils hiding (extractRatings)
import Handler.Utils.Submission as Handler.Utils
import Handler.Utils.Sheet as Handler.Utils
import Handler.Utils.Templates as Handler.Utils

6
src/Handler/Utils/Rating.hs
View File

@ -153,9 +153,11 @@ parseRating :: MonadThrow m => File -> m Rating'
parseRating File{ fileContent = Just input, .. } = do
inputText <- either (throw . RatingNotUnicode) return $ Text.decodeUtf8' input
let
(headerLines, commentLines) = break (sep `Text.isInfixOf`) $ Text.lines inputText
ratingLines = filter (rating `Text.isInfixOf`) headerLines
(headerLines', commentLines) = break (sep `Text.isInfixOf`) $ Text.lines inputText
(reverse -> ratingLines, reverse -> headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines'
ratingLines' = filter (rating `Text.isInfixOf`) ratingLines
sep = "Beginn der Kommentare"
sep' = Text.pack $ replicate 40 '='
rating = "Bewertung:"
comment' <- case commentLines of
(_:commentLines') -> return . Text.strip $ Text.unlines commentLines'

119
src/Handler/Utils/Submission.hs
View File

@ -15,6 +15,7 @@
module Handler.Utils.Submission
( AssignSubmissionException(..)
, assignSubmissions
, submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg
, submissionFileSource, submissionFileQuery
, submissionMultiArchive
, SubmissionSinkException(..)
@ -23,12 +24,15 @@ module Handler.Utils.Submission
) where
import Import hiding ((.=), joinPath)
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
import Control.Lens
import Control.Lens.Extras (is)
import Utils.Lens
import Control.Monad.State hiding (forM_, mapM_,foldM)
import Control.Monad.Writer (MonadWriter(..))
import Control.Monad.RWS.Lazy (RWST)
import qualified Control.Monad.Random as Rand
import Data.Maybe
@ -45,16 +49,24 @@ import qualified Data.CaseInsensitive as CI
import Data.Monoid (Monoid, Any(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Handler.Utils.Rating
import Handler.Utils.Rating hiding (extractRatings)
import qualified Handler.Utils.Rating as Rating (extractRatings)
import Handler.Utils.Zip
import Handler.Utils.Sheet
import Handler.Utils.Submission.TH
import qualified Database.Esqueleto as E
import Data.Conduit
import qualified Data.Conduit.List as Conduit
import Data.Conduit.ResumableSink
import System.FilePath
import System.FilePath.Glob
import Text.Hamlet (ihamletFile)
import qualified Control.Monad.Catch as E (Handler(..))
data AssignSubmissionException = NoCorrectorsByProportion
@ -186,11 +198,46 @@ instance Monoid SubmissionSinkState where
data SubmissionSinkException = DuplicateFileTitle FilePath
| DuplicateRating
| RatingWithoutUpdate
| ForeignRating
| ForeignRating CryptoFileNameSubmission
deriving (Typeable, Show)
instance Exception SubmissionSinkException
submissionBlacklist :: [Pattern]
submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
filterSubmission :: MonadLogger m => ConduitM File File m (Set FilePath)
-- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s
filterSubmission = do
$logDebugS "filterSubmission" $ tshow submissionBlacklist
execWriterLC . awaitForever $ \case
File{fileTitle}
| any (`match'` fileTitle) submissionBlacklist -> tell $ Set.singleton fileTitle
file -> yield file
where
match' = matchWith $ matchDefault
{ matchDotsImplicitly = True -- Special treatment for . makes no sense since we're multiplatform
}
extractRatings :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
, MonadLogger m
) => ConduitM File SubmissionContent m (Set FilePath)
extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings
extractRatingsMsg :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
, MonadLogger m
) => Conduit File m SubmissionContent
extractRatingsMsg = do
ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings
let ignored :: Set (Either CryptoFileNameSubmission FilePath)
ignored = Right `Set.map` ignored'
mr <- (toHtml . ) <$> getMessageRender
addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
sinkSubmission :: UserId
-> Either SheetId SubmissionId
-> Bool -- ^ Is this a correction
@ -228,7 +275,7 @@ sinkSubmission userId mExists isUpdate = do
sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
Left file@(File{..}) -> do
$logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
alreadySeen <- gets (Set.member fileTitle . sinkFilenames)
when alreadySeen . throwM $ DuplicateFileTitle fileTitle
tell $ mempty{ sinkFilenames = Set.singleton fileTitle }
@ -277,7 +324,9 @@ sinkSubmission userId mExists isUpdate = do
Right (submissionId', Rating'{..}) -> do
$logDebugS "sinkSubmission" $ tshow submissionId'
unless (submissionId' == submissionId) $ throwM ForeignRating
unless (submissionId' == submissionId) $ do
cID <- encrypt submissionId'
throwM $ ForeignRating cID
alreadySeen <- gets $ getAny . sinkSeenRating
when alreadySeen $ throwM DuplicateRating
@ -373,6 +422,16 @@ sinkSubmission userId mExists isUpdate = do
, SubmissionRatingComment =. Nothing
]
data SubmissionMultiSinkException
= SubmissionSinkException
{ submissionSinkId :: CryptoFileNameSubmission
, submissionSinkFedFile :: Maybe FilePath
, submissionSinkException :: SubmissionSinkException
}
deriving (Typeable, Show)
instance Exception SubmissionMultiSinkException
sinkMultiSubmission :: UserId
-> Bool {-^ Are these corrections -}
-> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId)
@ -386,7 +445,9 @@ sinkMultiSubmission userId isUpdate = do
let
feed :: SubmissionId
-> SubmissionContent
-> StateT
-> RWST
()
_
(Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId))
(YesodDB UniWorX)
()
@ -396,8 +457,9 @@ sinkMultiSubmission userId isUpdate = do
Just sink -> return sink
Nothing -> do
lift $ do
Submission{..} <- get404 sId
cID <- encrypt sId
$(logDebugS) "sinkMultiSubmission" $ "Doing auth checks for " <> toPathPiece cID
Submission{..} <- get404 sId
Sheet{..} <- get404 submissionSheet
Course{..} <- get404 sheetCourse
authRes <- evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True
@ -410,20 +472,45 @@ sinkMultiSubmission userId isUpdate = do
case sink' of
Left _ -> error "sinkSubmission returned prematurely"
Right nSink -> modify $ Map.insert sId nSink
sinks <- execStateLC Map.empty . awaitForever $ \case
v@(Right (sId, _)) -> lift $ feed sId v
(sinks, ignored) <- execRWSLC () Map.empty . awaitForever $ \case
v@(Right (sId, _)) -> do
cID <- encrypt sId
$logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID
lift (feed sId v) `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ]
(Left f@File{..}) -> do
let
tryDecrypt :: FilePath -> _ (Either SomeException SubmissionId)
tryDecrypt (CI.mk -> ciphertext) = try $ decrypt (CryptoID{..} :: CryptoFileNameSubmission)
acc (Just cID, fp) segment = return (Just cID, fp ++ [segment])
acc :: (Maybe SubmissionId, [FilePath]) -> FilePath -> _ (Maybe SubmissionId, [FilePath])
acc (Just sId, fp) segment = return (Just sId, fp ++ [segment])
acc (Nothing , fp) segment = do
msId <- tryDecrypt segment
return . either (const id) (set _1 . Just) msId $ (Nothing, fp)
let
tryDecrypt ciphertext = do
sId <- decrypt (CryptoID (CI.mk segment) :: CryptoFileNameSubmission)
Just sId <$ get404 sId
msId <- lift (lift $ tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]
return (msId, fp)
(msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
$logDebugS "sinkMultiSubmission" $ tshow (splitDirectories fileTitle, msId, fileTitle')
lift . maybe (const $ return ()) feed msId $ Left f{ fileTitle = fileTitle' }
fmap Map.keysSet . lift $ mapM (void . closeResumableSink) sinks
case msId of
Nothing -> do
$logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileTitle, msId, fileTitle')
Just sId -> do
$logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileTitle, msId, fileTitle')
cID <- encrypt sId
handle (throwM . SubmissionSinkException cID (Just fileTitle)) $
lift . feed sId $ Left f{ fileTitle = fileTitle' }
when (not $ null ignored) $ do
mr <- (toHtml .) <$> getMessageRender
addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do
cID <- encrypt sId
handle (throwM . SubmissionSinkException cID Nothing) $
void $ closeResumableSink sink
where
handleHCError :: Either CryptoFileNameSubmission FilePath -> HandlerContents -> _ (Maybe a)
handleHCError ident (HCError NotFound) = Nothing <$ tell (Set.singleton ident)
handleHCError _ e = throwM e
handleCryptoID :: CryptoIDError -> _ (Maybe a)
handleCryptoID _ = return Nothing
submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB ()
submissionMatchesSheet tid csh shn cid = do

39
src/Handler/Utils/Submission/TH.hs Normal file
View File

@ -0,0 +1,39 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
, ViewPatterns
, OverloadedStrings
, StandaloneDeriving
, DeriveLift
#-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Utils.Submission.TH
( patternFile
) where
import ClassyPrelude.Yesod
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..))
import System.FilePath.Glob
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
deriving instance Lift CompOptions
-- $(patternFile compDefault file) :: [System.FilePath.Glob.Pattern]
patternFile :: CompOptions -> FilePath -> ExpQ
patternFile opts file = do
qAddDependentFile file
patternStrings <- runIO $ filter (not . isComment) . Text.lines <$> Text.readFile file
listE $ map (\(Text.unpack -> pat) -> [|compileWith opts pat|]) patternStrings
isComment :: Text -> Bool
isComment line = or
[ commentSymbol `Text.isPrefixOf` Text.stripStart line
, Text.null $ Text.strip line
]
where
commentSymbol = "$#"

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

@ -204,7 +204,7 @@ instance Default (PSValidator m x) where
l <- asks piLimit
case l of
Just l'
| l' >= 0 -> tell . pure $ SomeMessage MsgPSLimitNonPositive
| l' <= 0 -> tell . pure $ SomeMessage MsgPSLimitNonPositive
| otherwise -> modify $ \ps -> ps { psLimit = l' }
Nothing -> return ()
@ -242,10 +242,10 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
cellContents :: DBCell m x -> WriterT x m Widget
cell :: Widget -> DBCell m x
-- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Proxy m -> Proxy x -> DBResult m x -> m' Widget
dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> DBResult m x -> m' Widget
dbHandler :: forall m'. (MonadHandler m' , HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
instance IsDBTable (WidgetT UniWorX IO) () where
@ -262,7 +262,8 @@ instance IsDBTable (WidgetT UniWorX IO) () where
cell = WidgetCell []
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
dbWidget Proxy Proxy = return
dbWidget _ = return
dbHandler _ f x = return $ f x
runDBTable = return . join . fmap (view _2)
instance Monoid (DBCell (WidgetT UniWorX IO) ()) where
@ -282,7 +283,8 @@ instance IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) () where
cell = DBCell [] . return
dbWidget Proxy Proxy = return
dbWidget _ = return
dbHandler _ f x = return $ f x
-- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
runDBTable = fmap snd . mapReaderT liftHandlerT
@ -306,7 +308,8 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
-- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
dbWidget Proxy Proxy = liftHandlerT . fmap (view $ _1 . _2) . runFormPost
dbWidget DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . identifyForm dbtIdent
dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> identifyForm dbtIdent form csrf
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
-- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
@ -413,16 +416,13 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
pageNumbers = [0..pred pageCount]
return $(widgetFile "table/layout")
dbWidget' :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBResult m x -> m' Widget
dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)
bool return (sendResponse <=< tblLayout <=< dbWidget') psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
bool (dbHandler dbtable $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
where
tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
tblLayout tbl' = do
tbl <- liftHandlerT $ widgetToPageContent tbl'
withUrlRenderer $(hamletFile "templates/table/layout-wrapper.hamlet")
withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet")
setParam :: Text -> Maybe Text -> QueryText -> QueryText
setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]

10
templates/default-layout.lucius
View File

@ -171,6 +171,8 @@ h4 {
background-color: white;
overflow: hidden;
transition: padding-left .2s ease-out;
max-width: 1200px;
margin: 0 auto;
> .container {
margin: 20px 0;
@ -185,6 +187,13 @@ h4 {
}
}
.logged-in {
.main__content {
margin: 0;
max-width: none;
}
}
@media (max-width: 768px) {
.logged-in {
.main__content {
@ -210,7 +219,6 @@ h4 {
}
@media (min-width: 1200px) {
.logged-in {
.main__content {
padding-left: 320px;

9
templates/messages/submissionFilesIgnored.hamlet Normal file
View File

@ -0,0 +1,9 @@
_{MsgSubmissionFilesIgnored}
<ul>
$forall ident <- ignored
$case ident
$of Right fileTitle
<li style="font-family: monospace">#{fileTitle}
$of Left cID
<li>Bewertungsdatei für <span style="font-family: monospace">#{toPathPiece cID}</span>

1
templates/table/layout-standalone.hamlet Normal file
View File

@ -0,0 +1 @@
^{pageBody tbl}

4
templates/table/layout-wrapper.hamlet
View File

@ -1 +1,3 @@
^{pageBody tbl}
$newline never
<div ##{wIdent "table-wrapper"}>
^{table}

17
templates/table/layout.hamlet
View File

@ -2,12 +2,11 @@ $newline never
$if null wRows && (dbsEmptyStyle == DBESNoHeading)
_{dbsEmptyMessage}
$else
<div ##{wIdent "table-wrapper"}>
<div .scrolltable>
^{table}
$if pageCount > 1
<ul ##{wIdent "pagination"} .pagination>
$forall p <- pageNumbers
<li .pagination-link :p == psPage:.current>
<a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
_{MsgPage (succ p)}
<div .scrolltable>
^{table}
$if pageCount > 1
<ul ##{wIdent "pagination"} .pagination>
$forall p <- pageNumbers
<li .pagination-link :p == psPage:.current>
<a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
_{MsgPage (succ p)}

16
templates/versionHistory.hamlet
View File

@ -8,9 +8,11 @@
Vorabversion!
Die Implementierung von
Uni2work ist noch nicht abgeschlossen.
^{features}
<p>
<section>
^{features}
<section>
<h2>
Bekannte Bugs
<ul>
@ -21,13 +23,13 @@
<li>
Tabellen über mehrere Seiten müssen vor Seitenwechsel manuell sortiert werden
<p>
<section>
<h2>
Versionsgeschichte
<pre #changelog>
<p #changelog>
#{changeLog}
<p>
<section>
<h2>
Impressum
@ -46,3 +48,7 @@
Ludwig-Maximilians-Universität München
<li>
Oettingenstr. 67, 80538 München
<section>
<p #gitrev>
#{gitInfo}

9
templates/versionHistory.lucius
View File

@ -1,4 +1,11 @@
#changelog {
font-size: 14px;
white-space: pre-line;
white-space: pre-wrap;
font-family: monospace;
}
#gitrev {
font-size: 12px;
white-space: pre-wrap;
font-family: monospace;
}