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

Cleanup

Browse Source
This commit is contained in:
Gregor Kleen 2019-04-15 16:41:14 +02:00
parent 4520c1be49
commit 5b6c35fedd
12 changed files with 127 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
messages/uniworx/de.msg
View File

@ -736,3 +736,7 @@ CommRecipients: Empfänger
AddRecipientGroups: Empfängergruppen
AddRecipientCustom: Weitere Empfänger
RGCourseParticipants: Kursteilnehmer
RGCourseLecturers: Kursverwalter
RGCourseCorrectors: Korrektoren

2
routes
View File

@ -78,7 +78,7 @@
/users CUsersR GET POST
/users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant
/correctors CHiWisR GET
/mail CCommR GET POST
/communication CCommR GET POST
/notes CNotesR GET POST !corrector
/subs CCorrectionsR GET POST
/ex SheetListR GET !registered !materials !corrector

14
src/Data/Set/Instances.hs Normal file
View File

@ -0,0 +1,14 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Set.Instances
(
) where
import ClassyPrelude
import Data.Set (Set)
import qualified Data.Set as Set
instance (Ord a, Hashable a) => Hashable (Set a) where
hashWithSalt s xs = hashWithSalt s $ Set.toAscList xs

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

@ -1,9 +1,18 @@
module Handler.Utils.Communication where
import Import
import Handler.Utils.Form
import Handler.Utils.Form.MassInput
import Utils.Lens
import Jobs.Types
import qualified Database.Esqueleto as E
import qualified Data.Map as Map
import qualified Data.Set as Set
data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
@ -13,17 +22,19 @@ nullaryPathPiece ''RecipientGroup $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''RecipientGroup id
data RecipientAddOptions
data RecipientAddOption
= AddRecipientGroups
| AddRecipientGroup RecipientGroup
| AddRecipientCustom
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Universe RecipientAddOptions where
universe = AddRecipientGroups:
[AddRecipientGroup g | g <- universe]
++ [AddRecipientCustom]
instance Finite RecipientAddOptions
instance Universe RecipientAddOption where
universe = concat
[ pure AddRecipientGroups
, [ AddRecipientGroup g | g <- universe ]
, pure AddRecipientCustom
]
instance Finite RecipientAddOption
instance PathPiece RecipientAddOption where
toPathPiece AddRecipientGroups = "recipient-groups"
@ -37,19 +48,17 @@ instance RenderMessage UniWorX RecipientAddOption where
AddRecipientGroups -> renderMessage' MsgAddRecipientGroups
AddRecipientCustom -> renderMessage' MsgAddRecipientCustom
AddRecipientGroup g -> renderMessage' g
where renderMessage' = renderMessage foundation ls
where
renderMessage' :: forall msg. RenderMessage UniWorX msg => msg -> Text
renderMessage' = renderMessage foundation ls
data CommunicationRoute = CommuncationRoute
data CommunicationRoute = CommunicationRoute
{ crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User)))
, crJob :: MailT Handler () -> Handler Job
, crJob :: Communication -> DB Job
}
data Communication = Communication
{ cRecipients :: Set (Either Email UserId)
, cSubject :: Text
}
-- `Communication` is defined in `Jobs.Types`
commR :: CommunicationRoute -> Handler Html
@ -57,32 +66,40 @@ commR CommunicationRoute{..} = do
MsgRenderer mr <- getMsgRenderer
suggestedRecipients' <- runDB $ traverse E.select crRecipients
suggestedRecipients <- forM suggestedRecipients' . mapM $ \ent@(Entity rid _) -> (,) <$> encrypt rid <*> pure ent
suggestedRecipients <- forM suggestedRecipients' . mapM $ \ent@(Entity rid _) -> (,) <$> (encrypt rid :: Handler CryptoUUIDUser) <*> pure ent
let recipientAForm :: AForm (Set (Either Email UserId))
recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients) True Nothing
where miAdd _ _ nudge submitButton = Just $ \csrf -> do
let addOptions = Map.fromList . concat $
[ pure (AddRecipientGroups, apreq (selectField . return $ mkOptionsList
[ Option (mr g) (Set.fromList $ map (Right . entityKey . snd) recs) (toPathPiece g) | (g,recs) <- Map.toList suggestedRecipients ]
) )
, do
(g,recs) <- Map.toList suggestedRecipients
return ( AddRecipientGroup g
, apreq (selectField . return $ mkOptionsList
[ Option userDisplayName (Right rid) (toPathPiece cid) | (cid, Entity rid User{..}) <- recs ]
)
-- , pure (AddRecipientCustom, _ )
]
multiAction ()
miCell
miDelete
miAllowAdd
miButtonAction
let recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients) True (Nothing {- TODO -})
where
miAdd _ _ nudge submitView = Just $ \csrf -> do
let addOptions :: Map RecipientAddOption (AForm Handler (Set (Either UserEmail UserId)))
addOptions = Map.fromList . concat $
[ pure ( AddRecipientGroups
, Set.unions <$> apreq (multiSelectField . return $ mkOptionList
[ Option (mr g) (Set.fromList $ map (Right . entityKey . snd) recs) (toPathPiece g) | (g,recs) <- Map.toList suggestedRecipients ]
) ("" & addName (nudge . toPathPiece $ AddRecipientGroups)) Nothing
)
, do
(g,recs) <- Map.toList suggestedRecipients
return ( AddRecipientGroup g
, Set.unions <$> apreq (multiSelectField . return $ mkOptionList
[ Option userDisplayName (Set.singleton $ Right rid) (toPathPiece cid) | (cid, Entity rid User{..}) <- recs ]
) ("" & addName (nudge . toPathPiece $ AddRecipientGroup g)) Nothing
)
-- , pure (AddRecipientCustom, _ )
]
(addRes, addWdgt) <- multiActionM addOptions ("" & addName (nudge "select")) Nothing csrf
error "miAdd" :: MForm Handler (FormResult (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))), Widget)
miCell = error "miCell"
miDelete :: ListLength -> ListPosition -> MaybeT (MForm Handler) (Map ListPosition ListPosition) -- This type signature is needed, so GHC can infer the type of @MassInput{..}@, above
miDelete = error "miDelete"
miAllowAdd = error "miAllowAdd"
miButtonAction = error "miButtonAction"
postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId)
postProcess = Set.fromList . map fst . Map.elems
runFormPost . identifyForm FIDCommunication $ renderAForm FormStandard $ Communication
<$> recipientAForm
<*> areq textField (fslI MsgCommSubject) Nothing
<*> aopt textField (fslI MsgCommSubject) Nothing
error "commR"

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

@ -377,7 +377,7 @@ nullaryPathPiece ''SheetGroup' (camelToPathPiece . dropSuffix "'")
embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'")
sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading
sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
sheetGradingAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
where
selOptions = Map.fromList
[ ( Points', Points <$> maxPointsReq )
@ -395,7 +395,7 @@ sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> tem
sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
sheetTypeAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
where
selOptions = Map.fromList
[ ( Normal', Normal <$> gradingReq )
@ -414,8 +414,8 @@ sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> templa
NotGraded -> NotGraded'
sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
let
sheetGroupAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
where
selOptions = Map.fromList
[ ( Arbitrary', Arbitrary
<$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
@ -423,25 +423,6 @@ sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
, ( RegisteredGroups', pure RegisteredGroups )
, ( NoGroups', pure NoGroups )
]
(res, selView) <- multiAction selOptions (classify' <$> template)
fvId <- maybe newIdent return fsId
MsgRenderer mr <- getMsgRenderer
return (res,
[ FieldView
{ fvLabel = toHtml $ mr fsLabel
, fvTooltip = toHtml . mr <$> fsTooltip
, fvId
, fvInput = selView
, fvErrors = case res of
FormFailure [e] -> Just $ toHtml e
_ -> Nothing
, fvRequired = True
}
])
where
classify' :: SheetGroup -> SheetGroup'
classify' = \case
Arbitrary _ -> Arbitrary'
@ -621,48 +602,41 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
, optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
}) cPairs
multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
multiAction :: forall action a.
( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
=> Map action (AForm (HandlerT UniWorX IO) a)
-> FieldSettings UniWorX
-> Maybe action
-> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
multiAction acts defAction = do
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
multiAction acts fs@FieldSettings{..} defAction csrf = do
mr <- getMessageRender
let
options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
(actionRes, actionView) <- mreq (selectField $ return options) "" defAction
(actionRes, actionView) <- mreq (selectField $ return options) fs defAction
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
let mToWidget (_, []) = return Nothing
mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty
widgets <- mapM mToWidget results
let actionWidgets = Map.foldrWithKey accWidget [] widgets
accWidget _act Nothing = id
accWidget act (Just w) = cons $(widgetFile "widgets/multi-action/multi-action")
actionResults = Map.map fst results
return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multi-action/multi-action-collect"))
let actionResults = view _1 <$> results
actionViews = Map.foldrWithKey accViews [] results
accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX]
accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> FieldSettings UniWorX
-> Map action (AForm (HandlerT UniWorX IO) a)
-> Maybe action
-> AForm (HandlerT UniWorX IO) a
multiActionA FieldSettings{..} acts defAction = formToAForm $ do
(res, selView) <- multiAction acts defAction
=> Map action (AForm (HandlerT UniWorX IO) a)
-> FieldSettings UniWorX
-> Maybe action
-> AForm Handler a
multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
fvId <- maybe newIdent return fsId
MsgRenderer mr <- getMsgRenderer
return (res,
[ FieldView
{ fvLabel = toHtml $ mr fsLabel
, fvTooltip = toHtml . mr <$> fsTooltip
, fvId
, fvInput = selView
, fvErrors = case res of
FormFailure [e] -> Just $ toHtml e
_ -> Nothing
, fvRequired = True
}
])
multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
-> FieldSettings UniWorX
-> Maybe action
-> (Html -> MForm Handler (FormResult a, Widget))
multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction
formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m ()
formResultModal res finalDest handler = maybeT_ $ do

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

@ -29,7 +29,6 @@ import qualified Data.Map as Map
import qualified Data.Foldable as Fold
import Data.List (genericLength, genericIndex, iterate)
import Control.Monad.Trans.Maybe
import Control.Monad.Reader.Class (MonadReader(local))
@ -407,4 +406,4 @@ massInputA :: forall handler cellData cellResult liveliness.
-> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
-> AForm handler (Map (BoxCoord liveliness) (cellData, cellResult))
massInputA mi fs fvRequired initialResult = formToAForm $
over _2 pure <$> massInput mi fs fvRequired initialResult mempty
over _2 pure <$> massInput mi fs fvRequired initialResult mempty

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

@ -18,8 +18,6 @@ import Import
import Text.PrettyPrint.Leijen.Text hiding ((<$>))
import Control.Monad.Trans.Maybe
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Text.Encoding.Error (UnicodeException(..))

1
src/Import/NoFoundation.hs
View File

@ -47,6 +47,7 @@ import Data.Text.Encoding.Error as Import(UnicodeException(..))
import Data.Semigroup as Import (Semigroup)
import Data.Monoid as Import (Last(..), First(..))
import Data.Monoid.Instances as Import ()
import Data.Set.Instances as Import ()
import Data.Binary as Import (Binary)

21
src/Jobs/Types.hs
View File

@ -1,5 +1,6 @@
module Jobs.Types
( Job(..), Notification(..)
, Communication(..)
, JobCtl(..)
, JobContext(..)
) where
@ -34,20 +35,32 @@ instance Hashable Job
instance Hashable Notification
deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
{ constructorTagModifier = camelToPathPiece' 1
, fieldLabelModifier = camelToPathPiece' 1
, tagSingleConstructors = True
, sumEncoding = TaggedObject "job" "data"
} ''Job
deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
{ constructorTagModifier = camelToPathPiece' 1
, fieldLabelModifier = camelToPathPiece' 1
, tagSingleConstructors = True
, sumEncoding = TaggedObject "notification" "data"
} ''Notification
data Communication = Communication
{ cRecipients :: Set (Either UserEmail UserId)
, cSubject :: Maybe Text
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Hashable Communication
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
} ''Communication
data JobCtl = JobCtlFlush
| JobCtlPerform QueuedJobId
| JobCtlDetermineCrontab

2
src/Utils.hs
View File

@ -45,7 +45,7 @@ import Control.Lens as Utils (none)
import Control.Arrow as Utils ((>>>))
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
import Control.Monad.Except (MonadError(..))
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.Maybe as Utils (MaybeT(..))
import Control.Monad.Catch hiding (throwM)

4
src/Utils/Lens.hs
View File

@ -1,7 +1,7 @@
module Utils.Lens ( module Utils.Lens ) where
import Import.NoFoundation
import Control.Lens as Utils.Lens hiding ((<.>))
import Control.Lens as Utils.Lens hiding ((<.>), universe)
import Control.Lens.Extras as Utils.Lens (is)
import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
@ -90,6 +90,8 @@ makeLenses_ ''StudyTerms
makeLenses_ ''StudyTermCandidate
makeLenses_ ''FieldView
-- makeClassy_ ''Load

4
templates/widgets/multi-action/multi-action-collect.hamlet
View File

@ -1,4 +0,0 @@
^{fvInput actionView}
$forall w <- actionWidgets
^{w}