yesod-pnotify 1.0.2 → 1.1.0
raw patch · 3 files changed
+305/−150 lines, 3 files
Files
- Yesod/Goodies/PNotify.hs +225/−87
- sample.hs +75/−62
- yesod-pnotify.cabal +5/−1
Yesod/Goodies/PNotify.hs view
@@ -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
sample.hs view
@@ -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 @@ <meta charset=utf-8> ^{pageHead pc} <body>- <article>- ^{pageBody pc}+ <div .container>+ <div .row>+ ^{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|-<form method=post action=@{PersonR} enctype=#{enctype}>- ^{widget}- <input type=submit>-|]--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|+ <form .form-horizontal role=form method=post action=@{LoginR} enctype=#{e}>+ <div .form-group>+ <div .col-sm-4>+ <h1 .col-sm-6>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|+ <p>`#{name}' Logged in.+ <a href=@{LoginR} .btn .btn-primary>Sign out+ |]+ main :: IO ()-main = warp 3000 Devel+main = warp 3000 Demo
yesod-pnotify.cabal view
@@ -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