wai-flash-messages (empty) → 1.0.0
raw patch · 3 files changed
+181/−0 lines, 3 filesdep +basedep +bytestringdep +cereal
Dependencies added: base, bytestring, cereal, cereal-text, text, vault, wai, wai-session
Files
- LICENSE +21/−0
- Network/Wai/Middleware/FlashMessages.hs +131/−0
- wai-flash-messages.cabal +29/−0
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2020 digitally induced GmbH++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Network/Wai/Middleware/FlashMessages.hs view
@@ -0,0 +1,131 @@+module Network.Wai.Middleware.FlashMessages+( setSuccessMessage+, setErrorMessage+, getSuccessMessage+, clearSuccessMessage+, consumeFlashMessagesMiddleware+, FlashMessage (..)+, requestFlashMessages+)+where++import Prelude+import Network.Wai+import Data.ByteString+import qualified Data.Serialize as Serialize+import Data.Serialize.Text ()+import qualified Data.Vault.Lazy as Vault+import qualified Network.Wai.Session as Session+import qualified Data.Maybe as Maybe+import Data.Text (Text)++data FlashMessage+ = SuccessFlashMessage !Text+ | ErrorFlashMessage !Text++type SessionVaultKey = Vault.Key (Session.Session IO ByteString ByteString)+type FlashVaultKey = Vault.Key [FlashMessage]++-- | Sets a flash messages. This is shown to the user when the next view is rendered.+--+-- Will be rendered in a bootstrap alert, with the @alert-success@ styling.+-- Take a look at https://getbootstrap.com/docs/4.5/components/alerts/ for how this will look like.+--+-- This requires 'IHP.ViewSupport.renderFlashMessages' to be placed somewhere in the layout or page of the next view.+-- For example:+--+-- > myLayout view = [hsx|+-- > {renderFlashMessages}+-- > <main>{view}</main>+-- > |]+setSuccessMessage :: SessionVaultKey -> Request -> Text -> IO ()+setSuccessMessage vaultKey request message =+ sessionInsertText vaultKey request successMessageKey message++-- | Sets a flash messages. This is shown to the user when the next view is rendered.+--+-- Will be rendered in a bootstrap alert, with the @alert-danger@ styling.+-- Take a look at https://getbootstrap.com/docs/4.5/components/alerts/ for how this will look like.+--+-- This requires 'IHP.ViewSupport.renderFlashMessages' to be placed somewhere in the layout or page of the next view.+-- For example:+--+-- > myLayout view = [hsx|+-- > {renderFlashMessages}+-- > <main>{view}</main>+-- > |]+setErrorMessage :: SessionVaultKey -> Request -> Text -> IO ()+setErrorMessage vaultKey request message =+ sessionInsertText vaultKey request errorMessageKey message++-- | Returns the flash message currently set+getSuccessMessage :: SessionVaultKey -> Request -> IO (Maybe Text)+getSuccessMessage vaultKey request =+ sessionLookupText vaultKey request successMessageKey++-- | Removes the current flash message+clearSuccessMessage :: SessionVaultKey -> Request -> IO ()+clearSuccessMessage vaultKey request =+ setSuccessMessage vaultKey request ""++successMessageKey :: ByteString+successMessageKey = "flashSuccessMessage"++errorMessageKey :: ByteString+errorMessageKey = "flashErrorMessage"++{-# INLINE consumeFlashMessagesMiddleware #-}+consumeFlashMessagesMiddleware :: SessionVaultKey -> FlashVaultKey -> Middleware+consumeFlashMessagesMiddleware sessionVaultKey flashVaultKey next request respond =+ case Vault.lookup sessionVaultKey request.vault of+ Just (lookup, insert) -> do+ rawSuccess <- lookup successMessageKey+ rawError <- lookup errorMessageKey++ case (rawSuccess, rawError) of+ (Nothing, Nothing) ->+ -- No flash messages set, skip decoding/clearing/vault-insert+ next request respond+ _ -> do+ let decodeAndClear name rawValue = do+ case rawValue of+ Just value -> do+ insert name "" -- Clear the flash message+ pure case Serialize.decode value of+ Left _ -> Nothing+ Right text -> Just text+ Nothing -> pure Nothing++ successMessage <- decodeAndClear successMessageKey rawSuccess+ errorMessage <- decodeAndClear errorMessageKey rawError++ let+ allFlashMessages = Maybe.catMaybes ((fmap SuccessFlashMessage successMessage):(fmap ErrorFlashMessage errorMessage):[])+ request' = request { vault = Vault.insert flashVaultKey allFlashMessages request.vault }++ next request' respond+ Nothing -> next request respond++requestFlashMessages :: FlashVaultKey -> Request -> Maybe [FlashMessage]+requestFlashMessages flashVaultKey request =+ Vault.lookup flashVaultKey request.vault++sessionInsertText :: SessionVaultKey -> Request -> ByteString -> Text -> IO ()+sessionInsertText vaultKey request name value =+ let insert = snd (requestSessionVault vaultKey request)+ in insert name (Serialize.encode value)++sessionLookupText :: SessionVaultKey -> Request -> ByteString -> IO (Maybe Text)+sessionLookupText vaultKey request name = do+ value <- fst (requestSessionVault vaultKey request) $ name+ pure case value of+ Just value -> case Serialize.decode value of+ Left error -> Nothing+ Right value -> Just value+ Nothing -> Nothing++requestSessionVault :: SessionVaultKey -> Request -> (ByteString -> IO (Maybe ByteString), ByteString -> ByteString -> IO ())+requestSessionVault vaultKey request =+ case Vault.lookup vaultKey request.vault of+ Just session -> session+ Nothing -> error "requestSessionVault: The session vault is missing in the request"
+ wai-flash-messages.cabal view
@@ -0,0 +1,29 @@+cabal-version: 2.2+name: wai-flash-messages+version: 1.0.0+synopsis: Flash messages for wai apps+description: Flash messages middleware for WAI+license: MIT+license-file: LICENSE+author: digitally induced GmbH+maintainer: support@digitallyinduced.com+bug-reports: https://github.com/digitallyinduced/ihp/issues+category: Web+build-type: Simple++source-repository head+ type: git+ location: https://github.com/digitallyinduced/ihp.git++library+ default-language: GHC2021+ default-extensions:+ OverloadedRecordDot+ DuplicateRecordFields+ DisambiguateRecordFields+ BlockArguments+ OverloadedStrings+ ghc-options: -Werror=incomplete-patterns -Werror=unused-imports -Werror=missing-fields+ build-depends: base >= 4.17.0 && < 4.22, text, wai, vault, cereal, cereal-text, bytestring, wai-session+ hs-source-dirs: .+ exposed-modules: Network.Wai.Middleware.FlashMessages