snap-utils (empty) → 0.1.0
raw patch · 8 files changed
+336/−0 lines, 8 filesdep +MonadCatchIO-transformersdep +basedep +bytestringsetup-changed
Dependencies added: MonadCatchIO-transformers, base, bytestring, heist, http-types, mtl, snap, snap-core, text, xmlhtml
Files
- Setup.hs +2/−0
- resources/alerts.tpl +6/−0
- snap-utils.cabal +44/−0
- src/Snap/Utils.hs +11/−0
- src/Snap/Utils/Alert.hs +115/−0
- src/Snap/Utils/Environment.hs +49/−0
- src/Snap/Utils/ErrorLogger.hs +46/−0
- src/Snap/Utils/TargetPage.hs +63/−0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ resources/alerts.tpl view
@@ -0,0 +1,6 @@+<div class="alerts">+ <div class="fade in alert alert-${alert-type} alert-dismissable">+ <button type="button" class="close" data-dismiss="alert">×</button>+ <strong><alert-text/></strong>+ </div>+</div>
+ snap-utils.cabal view
@@ -0,0 +1,44 @@+name: snap-utils+version: 0.1.0+synopsis: Snap Framework utility funtions.+description: Utilities for Snap Framework apps.+license: BSD3+author: Luke Hoersten+maintainer: Luke Hoersten <luke@hoersten.org>+build-type: Simple+cabal-version: >= 1.6+homepage: https://github.com/LukeHoersten/snap-utils+category: Web, Snap++data-files:+ resources/alerts.tpl++source-repository head+ type: git+ location: https://github.com/LukeHoersten/snap-utils++Library+ hs-source-dirs: src++ exposed-modules:+ Snap.Utils+ Snap.Utils.Alert+ Snap.Utils.Environment+ Snap.Utils.ErrorLogger+ Snap.Utils.TargetPage++ build-depends:+ base >= 4.4 && < 5,+ bytestring >= 0.9.1 && < 0.11,+ MonadCatchIO-transformers >= 0.2.1 && < 0.4,+ mtl >= 2 && < 3,+ xmlhtml >= 0.1 && < 0.3,+ snap >= 0.13 && < 0.14,+ snap-core >= 0.9 && < 0.11,+ heist >= 0.13 && < 0.14,+ http-types >= 0.6 && < 0.9,+ text >= 0.11 && < 0.12+++ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields+ -fno-warn-orphans -fno-warn-unused-do-bind
+ src/Snap/Utils.hs view
@@ -0,0 +1,11 @@+module Snap.Utils+ ( module Snap.Utils.Alert+ , module Snap.Utils.Environment+ , module Snap.Utils.ErrorLogger+ , module Snap.Utils.TargetPage+ ) where++import Snap.Utils.Alert+import Snap.Utils.Environment+import Snap.Utils.ErrorLogger+import Snap.Utils.TargetPage
+ src/Snap/Utils/Alert.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Utils.Alert+ ( addAlertSplices+ , alertRedirect+ , alertRedirect'+ , alertSuccess+ , alertInfo+ , alertWarning+ , alertDanger+ , alertUrl+ , AlertType(..)+ ) where+++import Control.Applicative ((<$>), (<*>))+import Control.Arrow ((***))+import Control.Monad (liftM2)+import Control.Monad.Trans (lift)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.Monoid (mempty)+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import Heist (HeistConfig (..), RuntimeSplice,+ Splices, mapS, noSplices)+import Heist.Compiled (Splice, callTemplate, codeGen,+ pureSplice, textSplice,+ withLocalSplices, yieldRuntime)+import Heist.Interpreted (callTemplateWithText)+import Heist.SpliceAPI (( #! ), ($$))+import Snap.Core (MonadSnap, getParam, redirect)+import Snap.Snaplet (Initializer, Snaplet)+import Snap.Snaplet.Heist (HasHeist, Heist, SnapletCSplice,+ SnapletISplice, addConfig)+import Snap.Utils.Types (URL)+++data AlertType = Success | Info | Warning | Danger deriving Show+++addAlertSplices :: HasHeist b => Snaplet (Heist b) -> Initializer b v ()+addAlertSplices h = addConfig h $ mempty+ { hcCompiledSplices = ("alerts" #! alertCSplice)+ , hcInterpretedSplices = ("alerts" #! alertISplice)+ }+++alertRedirect :: MonadSnap m => AlertType -> Text -> URL -> m a+alertRedirect typ msg url = alertRedirect' typ msg url []+++alertRedirect' :: MonadSnap m => AlertType -> Text -> URL -> [(ByteString, ByteString)] -> m a+alertRedirect' typ msg url params = redirect $ alertUrl typ msg url params+++alertSuccess :: MonadSnap m => Text -> URL -> m a+alertSuccess = alertRedirect Success+++alertInfo :: MonadSnap m => Text -> URL -> m a+alertInfo = alertRedirect Info+++alertWarning :: MonadSnap m => Text -> URL -> m a+alertWarning = alertRedirect Warning+++alertDanger :: MonadSnap m => Text -> URL -> m a+alertDanger = alertRedirect Danger+++alertISplice :: SnapletISplice b+alertISplice = do+ mAlert <- liftM2 (,) <$> getParam "alert-type" <*> getParam "alert-text"+ case mAlert of+ Just (aType, aText) ->+ callTemplateWithText "/snippet/alerts" $ do+ "alert-text" #! T.decodeUtf8 aText+ "alert-type" #! T.decodeUtf8 aType+ Nothing -> return []+++alertCSplice :: SnapletCSplice b+alertCSplice = do+ children <- withLocalSplices (alertSplices $$ ss) noSplices (callTemplate "/snippet/alerts")+ return . yieldRuntime $ do+ mAlert <- lift $ liftM2 (,) <$> getParam "alert-type" <*> getParam "alert-text"+ maybe mempty (const $ codeGen children) mAlert+ where ss = do+ mAlert <- lift $ liftM2 (,) <$> getParam "alert-type" <*> getParam "alert-text"+ return $ maybe mempty (T.decodeUtf8 *** T.decodeUtf8) mAlert+++alertSplices :: Monad m => Splices (RuntimeSplice m (Text, Text) -> Splice m)+alertSplices = mapS (pureSplice . textSplice) $ do+ "alert-type" #! fst+ "alert-text" #! snd+++alertUrl :: AlertType -> Text -> URL -> [(ByteString, ByteString)] -> URL+alertUrl typ msg url params = B.append url . uriQueryString $+ [("alert-text", T.encodeUtf8 msg), ("alert-type", cssType typ)] ++ params+++cssType :: AlertType -> ByteString+cssType Success = "success"+cssType Info = "info"+cssType Warning = "warning"+cssType Danger = "danger"+++uriQueryString :: [(ByteString, ByteString)] -> URL+uriQueryString = B.append "?" . B.intercalate "&" . map (showPairWith "=")+ where showPairWith sep (k, v) = B.concat [k, sep, v]
+ src/Snap/Utils/Environment.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Utils.Environment where++import Control.Applicative ((<$>))+import Data.Maybe (fromMaybe)+import Data.Monoid (mempty)+import Data.Text (Text)+import qualified Data.Text as T+import Heist (HeistConfig (..), getParamNode)+import Heist.Compiled (codeGen, runChildren, yieldRuntime)+import Heist.SpliceAPI (( #! ))+import Snap.Snaplet (Initializer, Snaplet, getEnvironment)+import Snap.Snaplet.Heist (HasHeist, Heist, SnapletCSplice,+ SnapletISplice, addConfig)+import Text.XmlHtml (Node (..), childNodes)+++addEnvironmentSplices :: HasHeist b => Snaplet (Heist b) -> Initializer b v ()+addEnvironmentSplices h = do+ env <- T.pack <$> getEnvironment+ addConfig h $ mempty+ { hcCompiledSplices = "ifEnvironment" #! envCSplice env+ , hcInterpretedSplices = "ifEnvironment" #! envISplice env+ }+++envISplice :: Text -> SnapletISplice b+envISplice env = do+ node <- getParamNode+ let env' = getAttribute node "name"+ return $ if env' == env then childNodes node else []+++envCSplice :: Text -> SnapletCSplice b+envCSplice env = do+ node <- getParamNode+ let env' = getAttribute node "name"+ children <- runChildren+ return . yieldRuntime $ if env' == env then codeGen children else mempty+++getAttribute :: Node -> Text -> Text+getAttribute node attr =+ case node of+ Element _ as _ ->+ fromMaybe (error $ show node ++ ": missing " ++ T.unpack attr) $+ lookup attr as+ _ -> error "Wrong type of node!"
+ src/Snap/Utils/ErrorLogger.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Utils.ErrorLogger where++import Control.Exception (SomeException)+import Control.Monad.CatchIO (catch)+import Data.Maybe (fromJust)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Snap.Core (MonadSnap, getRequest, logError)+import Snap.Snaplet (Handler, SnapletLens, with)+import Snap.Snaplet.Auth (AuthManager, AuthUser, currentUser,+ unUid, userId, userLogin)+import Snap.Utils.Alert (alertDanger)+import Snap.Utils.Types (URL)+++newtype SysMsg = SysMsg { unSysMsg :: Text } deriving (Show, Eq)+newtype UsrMsg = UsrMsg { unUsrMsg :: Text } deriving (Show, Eq)+++topExceptionHandler :: SnapletLens v (AuthManager b) -> Handler b v () -> Handler b v ()+topExceptionHandler auth = flip catch (logException auth)+++logException :: SnapletLens v (AuthManager b) -> SomeException -> Handler b v ()+logException auth e = do+ rq <- getRequest+ logErrorRedirect (sysMsg rq) usrMsg url =<< (with auth currentUser)+ where sysMsg rq = SysMsg $ T.concat ["Uncaught exception: '" , T.pack $ show e, "'\n", T.pack $ show rq]+ usrMsg = UsrMsg "You hit an application problem."+ url = "/"++-- Log a system error and redirect the user with a nice message.+-- TODO log JSON+logErrorRedirect :: MonadSnap m => SysMsg -> UsrMsg -> URL -> Maybe AuthUser -> m a+logErrorRedirect sysMsg usrMsg url user = do+ logError . T.encodeUtf8 $ T.concat ["[User: ", maybe "UNKNOWN" tShowUser user, "] ", unSysMsg sysMsg]+ alertDanger usrMsg' url+ where tShowUser u = T.concat [unUid . fromJust $ userId u, " ", userLogin u]+ usrMsg' = T.concat [unUsrMsg usrMsg, " We've been notified of the problem and are working on it."]+++logErrorRedirect' :: MonadSnap m => Text -> URL -> AuthUser -> m a+logErrorRedirect' msg url user = logErrorRedirect (SysMsg msg) (UsrMsg msg) url (Just user)
+ src/Snap/Utils/TargetPage.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Snap.Utils.TargetPage where++import Control.Applicative ((<$>))+import Control.Monad.Trans (lift)+import Data.Monoid (mempty)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Heist (HeistConfig (..))+import Heist.Compiled (yieldRuntimeText)+import Heist.Interpreted (textSplice)+import Heist.SpliceAPI (( #! ))+import Network.HTTP.Types (urlDecode, urlEncode)+import Snap.Core (MonadSnap, getParam, getRequest, redirect,+ rqURI)+import Snap.Snaplet (Initializer, Snaplet)+import Snap.Snaplet.Heist (HasHeist, Heist, SnapletCSplice,+ SnapletISplice, addConfig)+import Snap.Utils.Alert (AlertType (..), alertRedirect')+import Snap.Utils.Types (URL)+++-- |Defer the target-page+deferFromTargetPage :: MonadSnap m => Text -> URL -> m a+deferFromTargetPage msg interimUrl =+ deferFromTargetPage' msg interimUrl =<< rqURI <$> getRequest+++-- |If redirecting from a POST action, the POST action wasn't the+-- target. The referrer was. Just pass the target-url in directly+-- instead of grabbing it from the request.+deferFromTargetPage' :: MonadSnap m => Text -> URL -> URL -> m a+deferFromTargetPage' msg interimUrl targetUrl =+ alertRedirect' Warning msg interimUrl . (:[]) . ("target-page",) $+ urlEncode True targetUrl+++continueToTargetPage :: MonadSnap m => m a -> m a+continueToTargetPage noTargetPage =+ getParam "target-page" >>= maybe noTargetPage hasTargetPage+ where hasTargetPage = redirect . urlDecode True+++addTargetPageSplice :: HasHeist b => Snaplet (Heist b) -> Initializer b v ()+addTargetPageSplice h = addConfig h $ mempty+ { hcCompiledSplices = ("target-page" #! targetPageCSplice)+ , hcInterpretedSplices = ("target-page" #! targetPageISplice)+ }+++targetPageISplice :: SnapletISplice b+targetPageISplice = do+ targetPage <- getParam "target-page"+ textSplice $ maybe "" (T.append "target-page=" . T.decodeUtf8) targetPage+++targetPageCSplice :: SnapletCSplice b+targetPageCSplice = return . yieldRuntimeText . lift $ do+ targetPage <- getParam "target-page"+ return $ maybe "" (T.append "target-page=" . T.decodeUtf8) targetPage