diff --git a/Yesod/Goodies/PNotify.hs b/Yesod/Goodies/PNotify.hs --- a/Yesod/Goodies/PNotify.hs +++ b/Yesod/Goodies/PNotify.hs @@ -1,12 +1,20 @@ module Yesod.Goodies.PNotify - ( PNotify(..) - , NotifyType(..) - , NotifyStyling(..) + ( module Yesod.Goodies.PNotify.Types + , module Yesod.Goodies.PNotify.Types.Instances + , module Buttons + , module Confirm + , module Desktop + , module History + , module Nonblock + , module Reference + , module Stack + , PNotify(..) , YesodJqueryPnotify(..) , getPNotify , setPNotify -- Utility , pnotify + , defaultPNotify ) where import Yesod @@ -14,111 +22,226 @@ import Control.Monad (mzero) import Control.Monad.Trans.Maybe -import Data.Aeson (FromJSON(..), ToJSON(..), encode, decode) -import Data.Aeson.Parser (value) -import Data.Char (toLower) +import Data.Aeson (FromJSON(..), ToJSON(..), encode, decode, (.:?)) import Data.List (nub) -import Data.Monoid ((<>), mempty) +import Data.Maybe (isJust, fromJust) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL (decodeUtf8, encodeUtf8) import Text.Julius (RawJS(..)) -data PNotify = PNotify - { sty :: NotifyStyling - , typ :: NotifyType - , ttl :: Text - , msg :: Text +import Yesod.Goodies.PNotify.Types +import Yesod.Goodies.PNotify.Types.Instances +import qualified Yesod.Goodies.PNotify.Modules.Buttons as Buttons +import qualified Yesod.Goodies.PNotify.Modules.Confirm as Confirm +import qualified Yesod.Goodies.PNotify.Modules.Desktop as Desktop +import qualified Yesod.Goodies.PNotify.Modules.History as History +import qualified Yesod.Goodies.PNotify.Modules.Nonblock as Nonblock +import qualified Yesod.Goodies.PNotify.Modules.Reference as Reference +import qualified Yesod.Goodies.PNotify.Modules.Stack as Stack + +data PNotify = PNotify + { _title :: Maybe (Either Bool Text) + , _title_escape :: Maybe (Either Bool Text) + , _text :: Maybe (Either Bool Text) + , _text_escape :: Maybe (Either Bool Text) + , _styling :: Maybe NotifyStyling + , _addclass :: Maybe Text + , _cornerclass :: Maybe Text + , _auto_display :: Maybe Bool + , _width :: Maybe Text + , _min_height :: Maybe Text + , _type :: Maybe NotifyType + , _icon :: Maybe (Either Bool Text) + , _animation :: Maybe AnimationType + , _animate_speed :: Maybe AnimateSpeed + , _position_animate_speed :: Maybe Int + , _opacity :: Maybe Double + , _shadow :: Maybe Bool + , _hide :: Maybe Bool + , _delay :: Maybe Int + , _mouse_reset :: Maybe Bool + , _remove :: Maybe Bool + , _insert_brs :: Maybe Bool + + , _stack :: Maybe Stack.Stack + , _buttons :: Maybe Buttons.Buttons + , _confirm :: Maybe Confirm.Confirm + , _desktop :: Maybe Desktop.Desktop + , _history :: Maybe History.History + , _nonblock :: Maybe Nonblock.Nonblock + , _reference :: Maybe Reference.Reference } - deriving (Show, Read, Eq) + deriving (Show, Read, Eq, Ord) instance FromJSON PNotify where parseJSON (Object v) = PNotify <$> - v .: "styling" <*> - v .: "type" <*> - v .: "title" <*> - v .: "text" + v .:? "title" <*> + v .:? "title_escape" <*> + v .:? "text" <*> + v .:? "text_escape" <*> + v .:? "styling" <*> + v .:? "addclass" <*> + v .:? "cornerclass" <*> + v .:? "auto_display" <*> + v .:? "width" <*> + v .:? "min_height" <*> + v .:? "type" <*> + v .:? "icon" <*> + v .:? "animation" <*> + v .:? "animate_speed" <*> + v .:? "position_animate_speed" <*> + v .:? "opacity" <*> + v .:? "shadow" <*> + v .:? "hide" <*> + v .:? "delay" <*> + v .:? "mouse_reset" <*> + v .:? "remove" <*> + v .:? "insert_brs" <*> + v .:? "stack" <*> + v .:? "buttons" <*> + v .:? "confirm" <*> + v .:? "desktop" <*> + v .:? "history" <*> + v .:? "nonblock" <*> + v .:? "reference" parseJSON _ = mzero instance ToJSON PNotify where - toJSON (PNotify sty typ ttl msg) = object ["styling" .= sty - ,"type" .= typ - ,"title" .= ttl - ,"text" .= msg - ] + toJSON (PNotify { _title + , _title_escape + , _text + , _text_escape + , _styling + , _addclass + , _cornerclass + , _auto_display + , _width + , _min_height + , _type + , _icon + , _animation + , _animate_speed + , _position_animate_speed + , _opacity + , _shadow + , _hide + , _delay + , _mouse_reset + , _remove + , _insert_brs + , _stack + , _buttons + , _confirm + , _desktop + , _history + , _nonblock + , _reference + }) + = object $ maybe [] (\x -> ["title" .= x]) _title ++ + maybe [] (\x -> ["title_escape" .= x]) _title_escape ++ + maybe [] (\x -> ["text" .= x]) _text ++ + maybe [] (\x -> ["text_escape" .= x]) _text_escape ++ + maybe [] (\x -> ["styling" .= x]) _styling ++ + maybe [] (\x -> ["addclass" .= x]) _addclass ++ + maybe [] (\x -> ["cornerclass" .= x]) _cornerclass ++ + maybe [] (\x -> ["auto_display" .= x]) _auto_display ++ + maybe [] (\x -> ["width" .= x]) _width ++ + maybe [] (\x -> ["min_height" .= x]) _min_height ++ + maybe [] (\x -> ["type" .= x]) _type ++ + maybe [] (\x -> ["icon" .= x]) _icon ++ + maybe [] (\x -> ["animation" .= x]) _animation ++ + maybe [] (\x -> ["animate_speed" .= x]) _animate_speed ++ + maybe [] (\x -> ["position_animate_speed" .= x]) _position_animate_speed ++ + maybe [] (\x -> ["opacity" .= x]) _opacity ++ + maybe [] (\x -> ["shadow" .= x]) _shadow ++ + maybe [] (\x -> ["hide" .= x]) _hide ++ + maybe [] (\x -> ["delay" .= x]) _delay ++ + maybe [] (\x -> ["mouse_reset" .= x]) _mouse_reset ++ + maybe [] (\x -> ["remove" .= x]) _remove ++ + maybe [] (\x -> ["insert_brs" .= x]) _insert_brs ++ + maybe [] (\x -> ["stack" .= x]) _stack ++ + maybe [] (\x -> ["buttons" .= x]) _buttons ++ + maybe [] (\x -> ["confirm" .= x]) _confirm ++ + maybe [] (\x -> ["desktop" .= x]) _desktop ++ + maybe [] (\x -> ["history" .= x]) _history ++ + maybe [] (\x -> ["nonblcok" .= x]) _nonblock ++ + maybe [] (\x -> ["reference" .= x]) _reference ++ + [] +defaultPNotify :: PNotify +defaultPNotify = PNotify + { _title = Nothing + , _title_escape = Nothing + , _text = Nothing + , _text_escape = Nothing + , _styling = Nothing + , _addclass = Nothing + , _cornerclass = Nothing + , _auto_display = Nothing + , _width = Nothing + , _min_height = Nothing + , _type = Nothing + , _icon = Nothing + , _animation = Nothing + , _animate_speed = Nothing + , _position_animate_speed = Nothing + , _opacity = Nothing + , _shadow = Nothing + , _hide = Nothing + , _delay = Nothing + , _mouse_reset = Nothing + , _remove = Nothing + , _insert_brs = Nothing + , _stack = Nothing + , _buttons = Nothing + , _confirm = Nothing + , _desktop = Nothing + , _history = Nothing + , _nonblock = Nothing + , _reference = Nothing + } + instance RawJS [PNotify] where rawJS = rawJS . TL.decodeUtf8 . encode -data NotifyType = Notice | Info | Success | Error - deriving (Eq) - -instance Read NotifyType where - readsPrec d r = do - (v, s') <- lex r - return $ case v of - "notice" -> (Notice, s') - "info" -> (Info, s') - "success" -> (Success, s') - "error" -> (Error, s') - _ -> error $ "invalid NotifyType: " ++ v - -instance Show NotifyType where - show Notice = "notice" - show Info = "info" - show Success = "success" - show Error = "error" - -instance FromJSON NotifyType where - parseJSON (String v) = return $ read $ T.unpack v - parseJSON _ = mzero - -instance ToJSON NotifyType where - toJSON Notice = String "notice" - toJSON Info = String "info" - toJSON Success = String "success" - toJSON Error = String "error" - -data NotifyStyling = JqueryUI | Bootstrap3 | BrightTheme | FontAwesome - deriving (Eq) - -instance Read NotifyStyling where - readsPrec d r = do - (v, s') <- lex r - return $ case v of - "jqueryui" -> (JqueryUI, s') - "bootstrap3" -> (Bootstrap3, s') - "brighttheme" -> (BrightTheme, s') - "fontawesome" -> (FontAwesome, s') - _ -> error $ "invalid NotifyStyling: " ++ v - -instance Show NotifyStyling where - show JqueryUI = "jqueryui" - show Bootstrap3 = "bootstrap3" - show BrightTheme = "brighttheme" - show FontAwesome = "fontawesome" - -instance FromJSON NotifyStyling where - parseJSON (String v) = return $ read $ T.unpack v - parseJSON _ = mzero - -instance ToJSON NotifyStyling where - toJSON JqueryUI = String "jqueryui" - toJSON Bootstrap3 = String "bootstrap3" - toJSON BrightTheme = String "brighttheme" - toJSON FontAwesome = String "fontawesome" - class YesodJquery a => YesodJqueryPnotify a where urlJqueryJs :: a -> Either (Route a) Text urlJqueryJs _ = Right "//ajax.googleapis.com/ajax/libs/jquery/2.1.4/jquery.min.js" urlJqueryUiCss :: a -> Either (Route a) Text urlJqueryUiCss _ = Right "//ajax.googleapis.com/ajax/libs/jqueryui/1.11.4/themes/smoothness/jquery-ui.css" - urlPnotifyJs :: a -> Either (Route a) Text - urlPnotifyJs _ = Right "//cdnjs.cloudflare.com/ajax/libs/pnotify/2.1.0/pnotify.core.min.js" - urlPnotifyCss :: a -> Either (Route a) Text - urlPnotifyCss _ = Right "//cdnjs.cloudflare.com/ajax/libs/pnotify/2.1.0/pnotify.core.min.css" + urlPnotifyBrightthemeCss :: a -> Either (Route a) Text + urlPnotifyBrightthemeCss _ = Right "//cdn.css.net/libs/pnotify/2.1.0/pnotify.brighttheme.min.css" + urlPnotifyButtonsJs :: a -> Either (Route a) Text + urlPnotifyButtonsJs _ = Right "//cdn.css.net/libs/pnotify/2.1.0/pnotify.buttons.min.js" + urlPnotifyButtonsCss :: a -> Either (Route a) Text + urlPnotifyButtonsCss _ = Right "//cdn.css.net/libs/pnotify/2.1.0/pnotify.buttons.min.css" + urlPnotifyCallbacksJs :: a -> Either (Route a) Text + urlPnotifyCallbacksJs _ = Right "//cdn.css.net/libs/pnotify/2.1.0/pnotify.callbacks.min.js" + urlPnotifyConfirmJs :: a -> Either (Route a) Text + urlPnotifyConfirmJs _ = Right "//cdn.css.net/libs/pnotify/2.1.0/pnotify.confirm.min.js" + urlPnotifyCoreJs :: a -> Either (Route a) Text + urlPnotifyCoreJs _ = Right "//cdn.css.net/libs/pnotify/2.1.0/pnotify.core.min.js" + urlPnotifyCoreCss :: a -> Either (Route a) Text + urlPnotifyCoreCss _ = Right "//cdn.css.net/libs/pnotify/2.1.0/pnotify.core.min.css" + urlPnotifyDesktopJs :: a -> Either (Route a) Text + urlPnotifyDesktopJs _ = Right "//cdn.css.net/libs/pnotify/2.1.0/pnotify.desktop.min.js" + urlPnotifyHistoryJs :: a -> Either (Route a) Text + urlPnotifyHistoryJs _ = Right "//cdn.css.net/libs/pnotify/2.1.0/pnotify.history.min.js" + urlPnotifyHistoryCss :: a -> Either (Route a) Text + urlPnotifyHistoryCss _ = Right "//cdn.css.net/libs/pnotify/2.1.0/pnotify.history.min.css" + urlPnotifyMobileJs :: a -> Either (Route a) Text + urlPnotifyMobileJs _ = Right "//cdn.css.net/libs/pnotify/2.1.0/pnotify.mobile.min.js" + urlPnotifyNonblockJs :: a -> Either (Route a) Text + urlPnotifyNonblockJs _ = Right "//cdn.css.net/libs/pnotify/2.1.0/pnotify.nonblock.min.js" + urlPnotifyPiconCss :: a -> Either (Route a) Text + urlPnotifyPiconCss _ = Right "//cdn.css.net/libs/pnotify/2.1.0/pnotify.picon.min.css" + urlPnotifyReferenceJs :: a -> Either (Route a) Text + urlPnotifyReferenceJs _ = Right "//cdn.css.net/libs/pnotify/2.1.0/pnotify.reference.min.js" + urlPnotifyTooltipJs :: a -> Either (Route a) Text + urlPnotifyTooltipJs _ = Right "//cdn.css.net/libs/pnotify/2.1.0/pnotify.tooltip.min.js" urlBootstrap3Js :: a -> Either (Route a) Text urlBootstrap3Js _ = Right "//netdna.bootstrapcdn.com/bootstrap/3.3.5/js/bootstrap.min.js" @@ -157,8 +280,9 @@ optionalLoadJsCss :: (MonadWidget m, YesodJqueryPnotify (HandlerSite m)) => HandlerSite m -> [PNotify] -> m() -optionalLoadJsCss y = sequence_ . map trans . nub . map sty +optionalLoadJsCss y = mapM_ trans . uniqueAsDefault BrightTheme where + uniqueAsDefault def = nub . map (maybe def id . _styling) trans s = case s of JqueryUI -> addStylesheetEither $ urlJqueryUiCss y @@ -178,8 +302,22 @@ Nothing -> return () Just ps -> do addScriptEither $ urlJqueryJs y - addScriptEither $ urlPnotifyJs y - addStylesheetEither $ urlPnotifyCss y + addScriptEither $ urlPnotifyCoreJs y + addStylesheetEither $ urlPnotifyCoreCss y + + addStylesheetEither $ urlPnotifyBrightthemeCss y + addScriptEither $ urlPnotifyButtonsJs y + addStylesheetEither $ urlPnotifyButtonsCss y + addScriptEither $ urlPnotifyCallbacksJs y + addScriptEither $ urlPnotifyConfirmJs y + addScriptEither $ urlPnotifyDesktopJs y + addScriptEither $ urlPnotifyHistoryJs y + addStylesheetEither $ urlPnotifyHistoryCss y + addScriptEither $ urlPnotifyMobileJs y + addScriptEither $ urlPnotifyNonblockJs y + addStylesheetEither $ urlPnotifyPiconCss y + addScriptEither $ urlPnotifyReferenceJs y + addScriptEither $ urlPnotifyTooltipJs y optionalLoadJsCss y ps diff --git a/sample.hs b/sample.hs --- a/sample.hs +++ b/sample.hs @@ -1,22 +1,27 @@ -import Yesod -import Yesod.Form.Jquery -import Data.Text (Text) import Control.Applicative ((<$>),(<*>)) +import Control.Monad (forM_) +import Data.Text (Text) +import qualified Data.Text as T +import Yesod +import Yesod.Form.Jquery hiding (urlJqueryJs) +import Yesod.Form.Bootstrap3 import Yesod.Goodies.PNotify -data Devel = Devel +data Demo = Demo -mkYesod "Devel" [parseRoutes| -/ PersonR GET POST +mkYesod "Demo" [parseRoutes| +/ LoginR GET POST +/home/#Text HomeR GET |] - - -instance Yesod Devel where +instance Yesod Demo where defaultLayout widget = do y <- getYesod pc <- widgetToPageContent $ do + addScriptEither $ urlJqueryJs y + addScriptEither $ urlBootstrap3Js y + addStylesheetEither $ urlBootstrap3Css y widget pnotify y withUrlRenderer [hamlet| @@ -27,66 +32,74 @@ ^{pageHead pc} -
- ^{pageBody pc} +
+
+ ^{pageBody pc} |] -instance YesodJquery Devel -instance YesodJqueryPnotify Devel where +instance YesodJquery Demo +instance YesodJqueryPnotify Demo +instance RenderMessage Demo FormMessage where + renderMessage _ _ = defaultFormMessage -instance RenderMessage Devel FormMessage where - renderMessage _ _ = defaultFormMessage -data Person = Person { name :: Text - , age :: Int - } - deriving (Show) -personForm :: Html -> MForm Handler (FormResult Person, Widget) -personForm = renderDivs $ Person - <$> areq textField "Name" Nothing - <*> areq intField "Age" Nothing - -getPersonR :: Handler Html -getPersonR = do - (widget, enctype) <- generateFormPost personForm - defaultLayout [whamlet| -
- ^{widget} - -|] - -postPersonR :: Handler Html -postPersonR = do - ((result, _), _) <- runFormPost personForm - case result of - FormSuccess _ -> do +data Account = Account { ident :: Text, passwd :: Text } deriving Show +accountForm :: AForm Handler Account +accountForm = Account + <$> areq textField (bfs ("Id" :: Text)) Nothing + <*> areq passwordField (bfs ("Pass" :: Text)) Nothing + <* bootstrapSubmit ("Sign in" :: BootstrapSubmit Text) - setPNotify $ PNotify JqueryUI Success "Updated" "Update User profile." - setPNotify $ PNotify JqueryUI Notice "Notice" "More notice." - setPNotify $ PNotify JqueryUI Info "Information" "And more information." - setPNotify $ PNotify JqueryUI Error "Error" "Fail to update user profile" - - setPNotify $ PNotify Bootstrap3 Success "Updated" "Update User profile." - setPNotify $ PNotify Bootstrap3 Notice "Notice" "More notice." - setPNotify $ PNotify Bootstrap3 Info "Information" "And more information." - setPNotify $ PNotify Bootstrap3 Error "Error" "Fail to update user profile" - - setPNotify $ PNotify BrightTheme Success "Updated" "Update User profile." - setPNotify $ PNotify BrightTheme Notice "Notice" "More notice." - setPNotify $ PNotify BrightTheme Info "Information" "And more information." - setPNotify $ PNotify BrightTheme Error "Error" "Fail to update user profile" +hGrid = BootstrapHorizontalForm (ColSm 0) (ColSm 4) (ColSm 0) (ColSm 6) - setPNotify $ PNotify FontAwesome Success "Updated" "Update User profile." - setPNotify $ PNotify FontAwesome Notice "Notice" "More notice." - setPNotify $ PNotify FontAwesome Info "Information" "And more information." - setPNotify $ PNotify FontAwesome Error "Error" "Fail to update user profile" +getLoginR :: Handler Html +getLoginR = do + (w, e) <- generateFormPost $ renderBootstrap3 hGrid accountForm + defaultLayout $ do + setTitle "Login" + [whamlet| + +
+
+

Sign in + ^{w} + |] - redirect PersonR +postLoginR :: Handler Html +postLoginR = do + ((r, w), e) <- runFormPost $ renderBootstrap3 hGrid accountForm + case r of + FormSuccess acc -> + if ident acc == passwd acc + then do + setPNotify $ defaultPNotify { _type = Just Success + , _styling = Just Bootstrap3 + , _title = Just $ Right "Hello" + , _text = Just $ Right $ "Welcome, " `T.append` ident acc + } + redirect (HomeR $ ident acc) + else do + setPNotify $ defaultPNotify { _type = Just Error + , _styling = Just Bootstrap3 + , _title = Just $ Right "Try again" + , _text = Just $ Right "Please match the Id and the Pass." + } + redirect LoginR _ -> do - setPNotify $ PNotify JqueryUI Error "Error" "Fail to update user profile" - setPNotify $ PNotify Bootstrap3 Error "Error" "Fail to update user profile" - setPNotify $ PNotify BrightTheme Error "Error" "Fail to update user profile" - redirect PersonR + setPNotify $ defaultPNotify { _type = Just Error + , _styling = Just Bootstrap3 + , _title = Just $ Right "Fail" + , _text = Just $ Right "What happen?" + } + redirect LoginR +getHomeR :: Text -> Handler Html +getHomeR name = defaultLayout $ do + setTitle "Home" + [whamlet| +

`#{name}' Logged in. + Sign out + |] + main :: IO () -main = warp 3000 Devel +main = warp 3000 Demo diff --git a/yesod-pnotify.cabal b/yesod-pnotify.cabal --- a/yesod-pnotify.cabal +++ b/yesod-pnotify.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: yesod-pnotify -version: 1.0.2 +version: 1.1.0 synopsis: Yet another getMessage/setMessage using pnotify jquery plugins description: Yet another getMessage/setMessage using pnotify jquery plugins homepage: https://github.com/cutsea110/yesod-pnotify @@ -28,6 +28,8 @@ , FlexibleContexts , FlexibleInstances , DeriveGeneric + , NamedFieldPuns + , ViewPatterns build-depends: base >= 4.6 && < 4.9 , yesod >= 1.2 && < 1.5 @@ -48,6 +50,8 @@ , FlexibleContexts , FlexibleInstances , DeriveGeneric + , NamedFieldPuns + , ViewPatterns build-depends: base >= 4.6 && < 4.9 , yesod >= 1.2 && < 1.5