refactoring: move each widget into its own subfolder
This commit is contained in:
parent
a017168ecb
commit
3db08a841c
@ -7,7 +7,7 @@ import Import.NoFoundation
|
|||||||
import Database.Persist.Sql (SqlBackendCanRead)
|
import Database.Persist.Sql (SqlBackendCanRead)
|
||||||
|
|
||||||
import Utils.Form
|
import Utils.Form
|
||||||
|
|
||||||
import Data.CaseInsensitive (CI)
|
import Data.CaseInsensitive (CI)
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
@ -54,4 +54,4 @@ dummyLogin = AuthPlugin{..}
|
|||||||
apDispatch _ _ = notFound
|
apDispatch _ _ = notFound
|
||||||
apLogin toMaster = do
|
apLogin toMaster = do
|
||||||
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm
|
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm
|
||||||
$(widgetFile "widgets/dummy-login-form")
|
$(widgetFile "widgets/dummy-login-form/dummy-login-form")
|
||||||
|
|||||||
@ -36,7 +36,7 @@ data CampusMessage = MsgCampusIdentNote
|
|||||||
| MsgCampusSubmit
|
| MsgCampusSubmit
|
||||||
| MsgCampusInvalidCredentials
|
| MsgCampusInvalidCredentials
|
||||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||||
|
|
||||||
|
|
||||||
findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
||||||
findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter
|
findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter
|
||||||
@ -48,7 +48,7 @@ findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSet
|
|||||||
, Ldap.time ldapSearchTimeout
|
, Ldap.time ldapSearchTimeout
|
||||||
, Ldap.derefAliases Ldap.DerefAlways
|
, Ldap.derefAliases Ldap.DerefAlways
|
||||||
]
|
]
|
||||||
|
|
||||||
userPrincipalName :: Ldap.Attr
|
userPrincipalName :: Ldap.Attr
|
||||||
userPrincipalName = Ldap.Attr "userPrincipalName"
|
userPrincipalName = Ldap.Attr "userPrincipalName"
|
||||||
|
|
||||||
@ -105,7 +105,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
|||||||
apDispatch _ _ = notFound
|
apDispatch _ _ = notFound
|
||||||
apLogin toMaster = do
|
apLogin toMaster = do
|
||||||
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm
|
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm
|
||||||
$(widgetFile "widgets/campus-login-form")
|
$(widgetFile "widgets/campus-login/campus-login-form")
|
||||||
|
|
||||||
data CampusUserException = CampusUserLdapError LdapPoolError
|
data CampusUserException = CampusUserLdapError LdapPoolError
|
||||||
| CampusUserHostNotResolved String
|
| CampusUserHostNotResolved String
|
||||||
|
|||||||
@ -35,7 +35,7 @@ hashForm = HashLogin
|
|||||||
<*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing
|
<*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing
|
||||||
<* submitButton
|
<* submitButton
|
||||||
|
|
||||||
|
|
||||||
hashLogin :: ( YesodAuth site
|
hashLogin :: ( YesodAuth site
|
||||||
, YesodPersist site
|
, YesodPersist site
|
||||||
, SqlBackendCanRead (YesodPersistBackend site)
|
, SqlBackendCanRead (YesodPersistBackend site)
|
||||||
@ -90,5 +90,5 @@ hashLogin pwHashAlgo = AuthPlugin{..}
|
|||||||
apDispatch _ _ = notFound
|
apDispatch _ _ = notFound
|
||||||
apLogin toMaster = do
|
apLogin toMaster = do
|
||||||
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard hashForm
|
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard hashForm
|
||||||
$(widgetFile "widgets/hash-login-form")
|
$(widgetFile "widgets/hash-login-form/hash-login-form")
|
||||||
|
|
||||||
|
|||||||
@ -969,19 +969,19 @@ siteLayout' headingOverride widget = do
|
|||||||
-- you to use normal widget features in default-layout.
|
-- you to use normal widget features in default-layout.
|
||||||
|
|
||||||
navbar :: Widget
|
navbar :: Widget
|
||||||
navbar = $(widgetFile "widgets/navbar")
|
navbar = $(widgetFile "widgets/navbar/navbar")
|
||||||
asidenav :: Widget
|
asidenav :: Widget
|
||||||
asidenav = $(widgetFile "widgets/asidenav/asidenav")
|
asidenav = $(widgetFile "widgets/asidenav/asidenav")
|
||||||
footer :: Widget
|
footer :: Widget
|
||||||
footer = $(widgetFile "widgets/footer")
|
footer = $(widgetFile "widgets/footer/footer")
|
||||||
alerts :: Widget
|
alerts :: Widget
|
||||||
alerts = $(widgetFile "widgets/alerts/alerts")
|
alerts = $(widgetFile "widgets/alerts/alerts")
|
||||||
contentHeadline :: Maybe Widget
|
contentHeadline :: Maybe Widget
|
||||||
contentHeadline = headingOverride <|> (pageHeading =<< mcurrentRoute)
|
contentHeadline = headingOverride <|> (pageHeading =<< mcurrentRoute)
|
||||||
breadcrumbsWgt :: Widget
|
breadcrumbsWgt :: Widget
|
||||||
breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs")
|
breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs/breadcrumbs")
|
||||||
pageaction :: Widget
|
pageaction :: Widget
|
||||||
pageaction = $(widgetFile "widgets/pageaction")
|
pageaction = $(widgetFile "widgets/pageaction/pageaction")
|
||||||
-- functions to determine if there are page-actions (primary or secondary)
|
-- functions to determine if there are page-actions (primary or secondary)
|
||||||
hasPageActions, hasSecondaryPageActions, hasPrimaryPageActions :: Bool
|
hasPageActions, hasSecondaryPageActions, hasPrimaryPageActions :: Bool
|
||||||
hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions
|
hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions
|
||||||
|
|||||||
@ -162,7 +162,7 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E
|
|||||||
cid <- encrypt subId
|
cid <- encrypt subId
|
||||||
return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
|
return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
|
||||||
in mconcat
|
in mconcat
|
||||||
[ anchorCellM mkRoute $(widgetFile "widgets/rating")
|
[ anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
|
||||||
, writerCell $ do
|
, writerCell $ do
|
||||||
let
|
let
|
||||||
summary :: SheetTypeSummary
|
summary :: SheetTypeSummary
|
||||||
|
|||||||
@ -295,7 +295,7 @@ registerForm registered msecret extra = do
|
|||||||
(Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
|
(Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
|
||||||
_ -> return (Nothing,Nothing)
|
_ -> return (Nothing,Nothing)
|
||||||
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
|
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
|
||||||
let widget = $(widgetFile "widgets/registerForm")
|
let widget = $(widgetFile "widgets/register-form/register-form")
|
||||||
let msecretRes | Just res <- msecretRes' = Just <$> res
|
let msecretRes | Just res <- msecretRes' = Just <$> res
|
||||||
| otherwise = FormSuccess Nothing
|
| otherwise = FormSuccess Nothing
|
||||||
return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes
|
return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes
|
||||||
|
|||||||
@ -221,7 +221,7 @@ getProfileDataR = do
|
|||||||
-- Delete Button
|
-- Delete Button
|
||||||
(btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete)
|
(btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete)
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
let delWdgt = $(widgetFile "widgets/data-delete")
|
let delWdgt = $(widgetFile "widgets/data-delete/data-delete")
|
||||||
$(widgetFile "profileData")
|
$(widgetFile "profileData")
|
||||||
$(widgetFile "dsgvDisclaimer")
|
$(widgetFile "dsgvDisclaimer")
|
||||||
|
|
||||||
|
|||||||
@ -205,7 +205,7 @@ getSheetListR tid ssh csh = do
|
|||||||
mkRoute = do
|
mkRoute = do
|
||||||
cid' <- mkCid
|
cid' <- mkCid
|
||||||
return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
|
return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
|
||||||
acell = anchorCellM mkRoute $(widgetFile "widgets/rating")
|
acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
|
||||||
in cellTell acell $ stats submissionRatingPoints
|
in cellTell acell $ stats submissionRatingPoints
|
||||||
|
|
||||||
, sortable Nothing -- (Just "percent")
|
, sortable Nothing -- (Just "percent")
|
||||||
|
|||||||
@ -144,7 +144,7 @@ postAdminUserR uuid = do
|
|||||||
return (school, cbAdmin, cbLecturer)
|
return (school, cbAdmin, cbLecturer)
|
||||||
let result = forM boxRights $ \(Entity sid _, (resAdmin,_), (resLecturer, _)) ->
|
let result = forM boxRights $ \(Entity sid _, (resAdmin,_), (resLecturer, _)) ->
|
||||||
(,,) <$> pure sid <*> resAdmin <*> resLecturer
|
(,,) <$> pure sid <*> resAdmin <*> resLecturer
|
||||||
return (result,$(widgetFile "widgets/user-rights-form"))
|
return (result,$(widgetFile "widgets/user-rights-form/user-rights-form"))
|
||||||
let userRightsAction changes = do
|
let userRightsAction changes = do
|
||||||
void . runDB $
|
void . runDB $
|
||||||
forM changes $ \(sid, userAdmin, userLecturer) ->
|
forM changes $ \(sid, userAdmin, userLecturer) ->
|
||||||
|
|||||||
@ -90,9 +90,9 @@ getDeleteR DeleteRoute{..} = do
|
|||||||
(deleteFormWdgt, deleteFormEnctype) <- generateFormPost $ confirmForm' drRecords confirmString
|
(deleteFormWdgt, deleteFormEnctype) <- generateFormPost $ confirmForm' drRecords confirmString
|
||||||
|
|
||||||
Just targetRoute <- getCurrentRoute
|
Just targetRoute <- getCurrentRoute
|
||||||
|
|
||||||
sendResponse =<<
|
sendResponse =<<
|
||||||
defaultLayout $(widgetFile "widgets/delete-confirmation")
|
defaultLayout $(widgetFile "widgets/delete-confirmation/delete-confirmation")
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -588,9 +588,9 @@ multiAction acts defAction = do
|
|||||||
widgets <- mapM mToWidget results
|
widgets <- mapM mToWidget results
|
||||||
let actionWidgets = Map.foldrWithKey accWidget [] widgets
|
let actionWidgets = Map.foldrWithKey accWidget [] widgets
|
||||||
accWidget _act Nothing = id
|
accWidget _act Nothing = id
|
||||||
accWidget act (Just w) = cons $(widgetFile "widgets/multiAction")
|
accWidget act (Just w) = cons $(widgetFile "widgets/multi-action/multi-action")
|
||||||
actionResults = Map.map fst results
|
actionResults = Map.map fst results
|
||||||
return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect"))
|
return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multi-action/multi-action-collect"))
|
||||||
|
|
||||||
multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
|
multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
|
||||||
=> FieldSettings UniWorX
|
=> FieldSettings UniWorX
|
||||||
|
|||||||
@ -25,7 +25,7 @@ gradeSummaryWidget title sts =
|
|||||||
hasMarkedPasses = positiveSum $ numMarkedPasses sumSummaries
|
hasMarkedPasses = positiveSum $ numMarkedPasses sumSummaries
|
||||||
hasPoints = positiveSum $ numSheetsPoints sumSummaries
|
hasPoints = positiveSum $ numSheetsPoints sumSummaries
|
||||||
hasMarkedPoints = positiveSum $ numMarkedPoints sumSummaries
|
hasMarkedPoints = positiveSum $ numMarkedPoints sumSummaries
|
||||||
rowWdgts = [ $(widgetFile "widgets/gradingSummaryRow")
|
rowWdgts = [ $(widgetFile "widgets/grading-summary/grading-summary-row")
|
||||||
| (sumHeader,summary) <-
|
| (sumHeader,summary) <-
|
||||||
[ (MsgSheetTypeNormal' ,normalSummary)
|
[ (MsgSheetTypeNormal' ,normalSummary)
|
||||||
, (MsgSheetTypeBonus' ,bonusSummary)
|
, (MsgSheetTypeBonus' ,bonusSummary)
|
||||||
@ -33,4 +33,4 @@ gradeSummaryWidget title sts =
|
|||||||
] ]
|
] ]
|
||||||
in if 0 == numSheets sumSummaries
|
in if 0 == numSheets sumSummaries
|
||||||
then mempty
|
then mempty
|
||||||
else $(widgetFile "widgets/gradingSummary")
|
else $(widgetFile "widgets/grading-summary/grading-summary")
|
||||||
|
|||||||
@ -9,7 +9,7 @@ modal modalTrigger modalContent = do
|
|||||||
let modalDynamic = isLeft modalContent
|
let modalDynamic = isLeft modalContent
|
||||||
modalId <- newIdent
|
modalId <- newIdent
|
||||||
triggerId <- newIdent
|
triggerId <- newIdent
|
||||||
$(widgetFile "widgets/modal")
|
$(widgetFile "widgets/modal/modal")
|
||||||
case modalContent of
|
case modalContent of
|
||||||
Left route -> do
|
Left route -> do
|
||||||
route' <- toTextUrl route
|
route' <- toTextUrl route
|
||||||
|
|||||||
@ -41,7 +41,7 @@ data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize
|
|||||||
renderAForm :: Monad m => FormLayout -> FormRender m a
|
renderAForm :: Monad m => FormLayout -> FormRender m a
|
||||||
renderAForm formLayout aform fragment = do
|
renderAForm formLayout aform fragment = do
|
||||||
(res, ($ []) -> fieldViews) <- aFormToForm aform
|
(res, ($ []) -> fieldViews) <- aFormToForm aform
|
||||||
let widget = $(widgetFile "widgets/form")
|
let widget = $(widgetFile "widgets/form/form")
|
||||||
return (res, widget)
|
return (res, widget)
|
||||||
|
|
||||||
--------------------
|
--------------------
|
||||||
@ -367,7 +367,7 @@ reorderField optList = Field{..}
|
|||||||
isSel n = (==) (either (const $ map optionInternalValue olOptions) id val !! pred n) . optionInternalValue
|
isSel n = (==) (either (const $ map optionInternalValue olOptions) id val !! pred n) . optionInternalValue
|
||||||
nums = map (id &&& withNum theId) [1..length olOptions]
|
nums = map (id &&& withNum theId) [1..length olOptions]
|
||||||
withNum t n = tshow n <> "." <> t
|
withNum t n = tshow n <> "." <> t
|
||||||
$(widgetFile "widgets/permutation")
|
$(widgetFile "widgets/permutation/permutation")
|
||||||
|
|
||||||
optionsFinite :: ( MonadHandler m
|
optionsFinite :: ( MonadHandler m
|
||||||
, Finite a
|
, Finite a
|
||||||
|
|||||||
@ -51,4 +51,4 @@ $#
|
|||||||
\ (_{title $ getSum $ summary ^. _numSheetsPoints})
|
\ (_{title $ getSum $ summary ^. _numSheetsPoints})
|
||||||
$# Kurze Alternative mit Hashtag-Symbol für "Anzahl"
|
$# Kurze Alternative mit Hashtag-Symbol für "Anzahl"
|
||||||
$# \ (##{display $ summary ^. _numSheetsPoints})
|
$# \ (##{display $ summary ^. _numSheetsPoints})
|
||||||
<td .table__td>#{display $ summary ^. _numSheets}
|
<td .table__td>#{display $ summary ^. _numSheets}
|
||||||
Loading…
Reference in New Issue
Block a user