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

Button cleanup

Browse Source
This commit is contained in:
Gregor Kleen 2019-01-31 11:12:20 +01:00
parent 73a19863b1
commit 8684ca016f
11 changed files with 121 additions and 147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
src/Auth/Dummy.hs
View File

@ -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

13
src/Auth/LDAP.hs
View File

@ -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

11
src/Auth/PWHash.hs
View File

@ -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

25
src/Foundation.hs
View File

@ -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

24
src/Handler/Admin.hs
View File

@ -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|Ma<i>thema</i>tik|]
label CreateInf = "Informatik"
instance Button UniWorX ButtonCreate where
btnLabel CreateMath = [whamlet|Ma<i>thema</i>tik|]
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"

2
src/Handler/Profile.hs
View File

@ -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")

6
src/Handler/Sheet.hs
View File

@ -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

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

@ -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| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
linkButton :: Widget -> [ButtonClass UniWorX] -> SomeRoute UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
linkButton lbl cls url = do
url' <- toTextUrl url
[whamlet|
$newline never
<a href=#{url'} class=#{unwords $ map toPathPiece cls} role=button>
^{lbl}
|]
-- [whamlet|
-- <form method=post action=@{url}>
-- <input type="hidden" name="_formid" value="identify-linkButton">
@ -128,31 +123,16 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
-- <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
-- 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}
|])

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

@ -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

52
src/Utils/Form.hs
View File

@ -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
<button .btn .#{bcc2txt cssClass'} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid} :not validate:formnovalidate>^{label btn}
<button class=#{unwords $ map toPathPiece classes} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid} :not validate:formnovalidate>^{btnLabel btn}
|]
fieldParse [] [] = return $ Right Nothing
@ -255,8 +253,6 @@ buttonField btn = Field{..}
combinedButtonField :: forall a m.
( Button (HandlerSite m) a
, Show (ButtonCssClass (HandlerSite m))
, RenderMessage (HandlerSite m) ButtonMessage
, MonadHandler m
) => [a] -> FieldSettings (HandlerSite m) -> AForm m [Maybe a]
combinedButtonField bs FieldSettings{..} = formToAForm $ do
@ -280,8 +276,6 @@ combinedButtonField bs FieldSettings{..} = formToAForm $ do
combinedButtonFieldF :: forall m a.
( Button (HandlerSite m) a
, Show (ButtonCssClass (HandlerSite m))
, RenderMessage (HandlerSite m) ButtonMessage
, Finite a
, MonadHandler m
) => FieldSettings (HandlerSite m) -> AForm m [Maybe a]
@ -298,26 +292,22 @@ disambiguateButtons = traverseAForm $ \case
combinedButtonField_ :: forall a m.
( Button (HandlerSite m) a
, Show (ButtonCssClass (HandlerSite m))
, RenderMessage (HandlerSite m) ButtonMessage
, MonadHandler m
) => [a] -> FieldSettings (HandlerSite m) -> AForm m ()
combinedButtonField_ = (void .) . combinedButtonField
combinedButtonFieldF_ :: forall m a p.
( Button (HandlerSite m) a
, Show (ButtonCssClass (HandlerSite m))
, RenderMessage (HandlerSite m) ButtonMessage
, MonadHandler m
, Finite a
) => p a -> FieldSettings (HandlerSite m) -> AForm m ()
combinedButtonFieldF_ _ = void . combinedButtonFieldF @m @a
submitButton :: (Button (HandlerSite m) SubmitButton, Show (ButtonCssClass (HandlerSite m)), MonadHandler m, RenderMessage (HandlerSite m) ButtonMessage) => AForm m ()
submitButton = combinedButtonFieldF_ (Proxy @SubmitButton) ""
submitButton :: (Button (HandlerSite m) ButtonSubmit, MonadHandler m) => AForm m ()
submitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) ""
autosubmitButton :: (Button (HandlerSite m) SubmitButton, Show (ButtonCssClass (HandlerSite m)), MonadHandler m, RenderMessage (HandlerSite m) ButtonMessage) => AForm m ()
autosubmitButton = combinedButtonFieldF_ (Proxy @SubmitButton) $ "" & addAutosubmit
autosubmitButton :: (Button (HandlerSite m) ButtonSubmit, MonadHandler m) => AForm m ()
autosubmitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) $ "" & addAutosubmit
-------------------
-- Custom Fields --

2
templates/table/layout-filter-default.hamlet
View File

@ -3,6 +3,6 @@ $newline never
<form method=GET action=#{filterAction} enctype=#{filterEnctype}>
^{filterWgdt}
<button>
^{label BtnSubmit}
^{btnLabel BtnSubmit}
<section>
^{scrolltable}