diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index bb26aa344..e7033f3d8 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -14,15 +14,14 @@ import qualified Data.CaseInsensitive as CI data DummyMessage = MsgDummyIdent | MsgDummyNoFormData + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) dummyForm :: ( RenderMessage site FormMessage , RenderMessage site DummyMessage - , RenderMessage site ButtonMessage , YesodPersist site , SqlBackendCanRead (YesodPersistBackend site) - , Button site SubmitButton - , Show (ButtonCssClass site) + , Button site ButtonSubmit ) => AForm (HandlerT site IO) (CI Text) dummyForm = areq (selectField userList) (fslI MsgDummyIdent) Nothing <* submitButton @@ -35,9 +34,7 @@ dummyLogin :: ( YesodAuth site , SqlBackendCanRead (YesodPersistBackend site) , RenderMessage site FormMessage , RenderMessage site DummyMessage - , RenderMessage site ButtonMessage - , Button site SubmitButton - , Show (ButtonCssClass site) + , Button site ButtonSubmit ) => AuthPlugin site dummyLogin = AuthPlugin{..} where diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index ee658b195..cd2a9a037 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -28,13 +28,14 @@ import qualified Yesod.Auth.Message as Msg data CampusLogin = CampusLogin { campusIdent :: CI Text , campusPassword :: Text - } + } deriving (Generic, Typeable) data CampusMessage = MsgCampusIdentNote | MsgCampusIdent | MsgCampusPassword | MsgCampusSubmit | MsgCampusInvalidCredentials + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] @@ -53,9 +54,7 @@ userPrincipalName = Ldap.Attr "userPrincipalName" campusForm :: ( RenderMessage site FormMessage , RenderMessage site CampusMessage - , RenderMessage site ButtonMessage - , Button site SubmitButton - , Show (ButtonCssClass site) + , Button site ButtonSubmit ) => AForm (HandlerT site IO) CampusLogin campusForm = CampusLogin <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing @@ -66,9 +65,7 @@ campusLogin :: forall site. ( YesodAuth site , RenderMessage site FormMessage , RenderMessage site CampusMessage - , RenderMessage site ButtonMessage - , Button site SubmitButton - , Show (ButtonCssClass site) + , Button site ButtonSubmit ) => LdapConf -> LdapPool -> AuthPlugin site campusLogin conf@LdapConf{..} pool = AuthPlugin{..} where @@ -116,7 +113,7 @@ data CampusUserException = CampusUserLdapError LdapPoolError | CampusUserHostCannotConnect String [IOException] | CampusUserNoResult | CampusUserAmbiguous - deriving (Show, Eq, Typeable) + deriving (Show, Eq, Generic, Typeable) instance Exception CampusUserException diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index 53001ce92..68df34703 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -19,17 +19,16 @@ import qualified Yesod.Auth.Message as Msg data HashLogin = HashLogin { hashIdent :: CI Text , hashPassword :: Text - } + } deriving (Generic, Typeable) data PWHashMessage = MsgPWHashIdent | MsgPWHashPassword + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) hashForm :: ( RenderMessage site FormMessage , RenderMessage site PWHashMessage - , RenderMessage site ButtonMessage - , Button site SubmitButton - , Show (ButtonCssClass site) + , Button site ButtonSubmit ) => AForm (HandlerT site IO) HashLogin hashForm = HashLogin <$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing @@ -42,9 +41,7 @@ hashLogin :: ( YesodAuth site , SqlBackendCanRead (YesodPersistBackend site) , RenderMessage site FormMessage , RenderMessage site PWHashMessage - , RenderMessage site ButtonMessage - , Button site SubmitButton - , Show (ButtonCssClass site) + , Button site ButtonSubmit ) => PWHashAlgorithm -> AuthPlugin site hashLogin pwHashAlgo = AuthPlugin{..} where diff --git a/src/Foundation.hs b/src/Foundation.hs index 9ac8fb834..6f69c53b6 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -276,13 +276,28 @@ menuItemAccessCallback MenuItem{..} = and2M ((==) Authorized <$> authCheck) menu $(return []) -data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink - deriving (Enum, Eq, Ord, Bounded, Read, Show) +data instance ButtonClass UniWorX + = BCIsButton + | BCDefault + | BCPrimary + | BCSuccess + | BCInfo + | BCWarning + | BCDanger + | BCLink + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe (ButtonClass UniWorX) +instance Finite (ButtonClass UniWorX) -instance Button UniWorX SubmitButton where - label BtnSubmit = [whamlet|_{MsgBtnSubmit}|] +instance PathPiece (ButtonClass UniWorX) where + toPathPiece BCIsButton = "btn" + toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass + fromPathPiece = finiteFromPathPiece - cssClass BtnSubmit = BCPrimary + +embedRenderMessage ''UniWorX ''ButtonSubmit id +instance Button UniWorX ButtonSubmit where + btnClasses BtnSubmit = [BCIsButton, BCPrimary] getTimeLocale' :: [Lang] -> TimeLocale diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index feea45783..17bc943b9 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -13,8 +13,6 @@ import Control.Monad.Trans.Except -- import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 -import Web.PathPieces (showToPathPiece, readFromPathPiece) - import Database.Persist.Sql (fromSqlKey) -- import Colonnade hiding (fromMaybe) @@ -23,19 +21,19 @@ import Database.Persist.Sql (fromSqlKey) -- import qualified Data.UUID.Cryptographic as UUID -- BEGIN - Buttons needed only here -data CreateButton = CreateMath | CreateInf -- Dummy for Example - deriving (Enum, Eq, Ord, Bounded, Read, Show) +data ButtonCreate = CreateMath | CreateInf -- Dummy for Example + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonCreate +instance Finite ButtonCreate -instance PathPiece CreateButton where -- for displaying the button only, not really for paths - toPathPiece = showToPathPiece - fromPathPiece = readFromPathPiece +nullaryPathPiece ''ButtonCreate camelToPathPiece -instance Button UniWorX CreateButton where - label CreateMath = [whamlet|Mathematik|] - label CreateInf = "Informatik" +instance Button UniWorX ButtonCreate where + btnLabel CreateMath = [whamlet|Mathematik|] + btnLabel CreateInf = "Informatik" - cssClass CreateMath = BCInfo - cssClass CreateInf = BCPrimary + btnClasses CreateMath = [BCIsButton, BCInfo] + btnClasses CreateInf = [BCIsButton, BCPrimary] -- END Button needed here emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext) @@ -60,7 +58,7 @@ emailTestForm = (,) getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden! getAdminTestR = postAdminTestR postAdminTestR = do - ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form CreateButton) + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form ButtonCreate) case btnResult of (FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt" (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt" diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 12a99c604..38f064dd8 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -222,7 +222,7 @@ getProfileDataR = do let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|] -- Delete Button - (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete) + (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete) defaultLayout $ do let delWdgt = $(widgetFile "widgets/data-delete") $(widgetFile "profileData") diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index e798f9ca9..fd15fa58b 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -277,15 +277,15 @@ getSheetListR tid ssh csh = do $(widgetFile "sheetList") data ButtonGeneratePseudonym = BtnGenerate - deriving (Enum, Eq, Ord, Bounded, Read, Show) + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonGeneratePseudonym instance Finite ButtonGeneratePseudonym nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1) instance Button UniWorX ButtonGeneratePseudonym where - label BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|] - cssClass BtnGenerate = BCDefault + btnLabel BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|] + btnClasses BtnGenerate = [BCIsButton, BCDefault] -- Show single sheet getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 35297475e..152d53186 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -15,8 +15,6 @@ import qualified Data.Char as Char import qualified Data.CaseInsensitive as CI -import qualified Data.Foldable as Foldable - -- import Yesod.Core import qualified Data.Text as T -- import Yesod.Form.Types @@ -51,64 +49,55 @@ import Data.Aeson.Text (encodeToLazyText) -- Buttons (new version ) -- ---------------------------- -data BtnDelete = BtnDelete - deriving (Enum, Eq, Ord, Bounded, Read, Show) +data ButtonDelete = BtnDelete + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonDelete +instance Finite ButtonDelete -instance Universe BtnDelete -instance Finite BtnDelete +nullaryPathPiece ''ButtonDelete $ camelToPathPiece' 1 -nullaryPathPiece ''BtnDelete $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''ButtonDelete id +instance Button UniWorX ButtonDelete where + btnClasses BtnDelete = [BCIsButton, BCDanger] -instance Button UniWorX BtnDelete where - label BtnDelete = [whamlet|_{MsgBtnDelete}|] +data ButtonRegister = BtnRegister | BtnDeregister + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonRegister +instance Finite ButtonRegister - cssClass BtnDelete = BCDanger +nullaryPathPiece ''ButtonRegister $ camelToPathPiece' 1 -data RegisterButton = BtnRegister | BtnDeregister - deriving (Enum, Eq, Ord, Bounded, Read, Show) +embedRenderMessage ''UniWorX ''ButtonRegister id +instance Button UniWorX ButtonRegister where + btnClasses BtnRegister = [BCIsButton, BCPrimary] + btnClasses BtnDeregister = [BCIsButton, BCDanger] -instance Universe RegisterButton -instance Finite RegisterButton +data ButtonHijack = BtnHijack + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonHijack +instance Finite ButtonHijack -nullaryPathPiece ''RegisterButton $ camelToPathPiece' 1 +nullaryPathPiece ''ButtonHijack $ camelToPathPiece' 1 -instance Button UniWorX RegisterButton where - label BtnRegister = [whamlet|_{MsgBtnRegister}|] - label BtnDeregister = [whamlet|_{MsgBtnDeregister}|] +embedRenderMessage ''UniWorX ''ButtonHijack id +instance Button UniWorX ButtonHijack where + btnClasses BtnHijack = [BCIsButton, BCDefault] - cssClass BtnRegister = BCPrimary - cssClass BtnDeregister = BCDanger +data ButtonSubmitDelete = BtnSubmit' | BtnDelete' + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) -data AdminHijackUserButton = BtnHijack - deriving (Enum, Eq, Ord, Bounded, Read, Show) +instance Universe ButtonSubmitDelete +instance Finite ButtonSubmitDelete -instance Universe AdminHijackUserButton -instance Finite AdminHijackUserButton - -nullaryPathPiece ''AdminHijackUserButton $ camelToPathPiece' 1 - -instance Button UniWorX AdminHijackUserButton where - label BtnHijack = [whamlet|_{MsgBtnHijack}|] - - cssClass BtnHijack = BCDefault - -data BtnSubmitDelete = BtnSubmit' | BtnDelete' - deriving (Enum, Eq, Ord, Bounded, Read, Show) - -instance Universe BtnSubmitDelete -instance Finite BtnSubmitDelete - -instance Button UniWorX BtnSubmitDelete where - label BtnSubmit' = [whamlet|_{MsgBtnSubmit}|] - label BtnDelete' = [whamlet|_{MsgBtnDelete}|] - - cssClass BtnSubmit' = BCPrimary - cssClass BtnDelete' = BCDanger +embedRenderMessage ''UniWorX ''ButtonSubmitDelete $ dropSuffix "'" +instance Button UniWorX ButtonSubmitDelete where + btnClasses BtnSubmit' = [BCIsButton, BCPrimary] + btnClasses BtnDelete' = [BCIsButton, BCDanger] btnValidate _ BtnSubmit' = True btnValidate _ BtnDelete' = False -nullaryPathPiece ''BtnSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'" +nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'" -- -- Looks like a button, but is just a link (e.g. for create course, etc.) @@ -118,8 +107,14 @@ nullaryPathPiece ''BtnSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'" -- instance PathPiece LinkButton where -- LinkButton route = ??? -linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink -linkButton lbl cls url = [whamlet| ^{lbl} |] +linkButton :: Widget -> [ButtonClass UniWorX] -> SomeRoute UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink +linkButton lbl cls url = do + url' <- toTextUrl url + [whamlet| + $newline never + + ^{lbl} + |] -- [whamlet| --
-- @@ -128,31 +123,16 @@ linkButton lbl cls url = [whamlet| --- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ())) -buttonForm :: (Button UniWorX a, Show a) => Form a +-- buttonForm :: (Button UniWorX a, Finite a) => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, Widget) +buttonForm :: (Button UniWorX a, Finite a) => Form a buttonForm csrf = do - buttonIdent <- newFormIdent - let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing - (results, btnViews) <- unzip <$> mapM button [minBound..maxBound] - let widget = - [whamlet| - #{csrf} - $forall bView <- btnViews - ^{fvInput bView} - |] - return (accResult results,widget) - where - accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a - accResult = Foldable.foldr accResult' FormMissing - - accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a - -- Find the single FormSuccess Just _; Expected behaviour: all buttons deliver FormFailure, except for one. - accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"] - accResult' (FormSuccess (Just x)) _ = FormSuccess x - accResult' _ x@(FormSuccess _) = x --Safe: most buttons deliver FormFailure, one delivers FormSuccess - accResult' (FormSuccess Nothing) x = x - accResult' FormMissing _ = FormMissing - accResult' (FormFailure errs) _ = FormFailure errs + (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonFieldF "" + return (res, [whamlet| + $newline never + #{csrf} + $forall bView <- fViews + ^{fvInput bView} + |]) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index c42a85dda..9b205b1a9 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -519,7 +519,7 @@ dbParamsFormWrap DBParamsForm{..} tableForm frag = do return . (res,) $ do btnId <- newIdent act <- traverse toTextUrl dbParamsFormAction - let submitField :: Field Handler SubmitButton + let submitField :: Field Handler ButtonSubmit submitField = buttonField BtnSubmit submitView :: Widget submitView = fieldView submitField btnId "" mempty (Right BtnSubmit) False diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index a7f6d0e31..6fab13a32 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -7,7 +7,6 @@ import Settings import qualified Text.Blaze.Internal as Blaze (null) import qualified Data.Text as T -import qualified Data.Char as Char import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -200,37 +199,36 @@ identForm = identifyForm . toPathPiece -- Buttons (new version ) -- ---------------------------- -data family ButtonCssClass site :: * +data family ButtonClass site :: * -bcc2txt :: Show (ButtonCssClass site) => ButtonCssClass site -> Text -- a Hack; maybe define Read/Show manually -bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> drop 2 (show bcc)) +class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessage) => Button site a where + btnLabel :: a -> WidgetT site IO () -class (Enum a, Bounded a, Ord a, PathPiece a) => Button site a where - label :: a -> WidgetT site IO () - label = toWidget . toPathPiece + default btnLabel :: RenderMessage site a => a -> WidgetT site IO () + btnLabel = toWidget <=< ap getMessageRender . return btnValidate :: forall p. p site -> a -> Bool btnValidate _ _ = True - cssClass :: a -> ButtonCssClass site + btnClasses :: a -> [ButtonClass site] + btnClasses _ = [] data ButtonMessage = MsgAmbiguousButtons | MsgWrongButtonValue | MsgMultipleButtonValues + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -data SubmitButton = BtnSubmit - deriving (Enum, Eq, Ord, Bounded, Read, Show) +data ButtonSubmit = BtnSubmit + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -instance Universe SubmitButton -instance Finite SubmitButton +instance Universe ButtonSubmit +instance Finite ButtonSubmit -nullaryPathPiece ''SubmitButton $ camelToPathPiece' 1 +nullaryPathPiece ''ButtonSubmit $ camelToPathPiece' 1 buttonField :: forall a m. ( Button (HandlerSite m) a - , Show (ButtonCssClass (HandlerSite m)) - , RenderMessage (HandlerSite m) ButtonMessage - , Monad m + , MonadHandler m ) => a -> Field m a -- | Already validates that the correct button press was received (result only neccessary for combinedButtonField) buttonField btn = Field{..} @@ -239,12 +237,12 @@ buttonField btn = Field{..} fieldView :: FieldViewFunc m a fieldView fid name attrs _val _ = let - cssClass' :: ButtonCssClass (HandlerSite m) - cssClass' = cssClass btn validate = btnValidate (Proxy @(HandlerSite m)) btn + classes :: [ButtonClass (HandlerSite m)] + classes = btnClasses btn in [whamlet| $newline never -