diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,16 @@ + +# Snap-Extras [![Build Status](https://travis-ci.org/ozataman/snap-extras.svg?branch=master)](https://travis-ci.org/ozataman/snap-extras) + +A collection of useful helpers and utilities for Snap web +applications. + +This package contains a collection of helper functions that come in +handy in most practical, real-world applications. Check individual +modules to understand what's here. You can simply import Snap.Extras +and use the initializer in there to get them all at once. + + +# Contributors + +- Ozgun Ataman +- Doug Beardsley diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,2 @@ +0.12.0.0 +* Support snap 1.0. This drops support for some older versions of snap. diff --git a/poll-example/PollExample.hs b/poll-example/PollExample.hs --- a/poll-example/PollExample.hs +++ b/poll-example/PollExample.hs @@ -15,6 +15,7 @@ import Data.Aeson import Data.IORef import qualified Data.Map as M +import qualified Data.Map.Syntax as MS import Data.Monoid import Data.Readable import qualified Data.Text as T @@ -97,13 +98,14 @@ ] appInit = makeSnaplet "app" "blah" Nothing $ do - h <- nestSnaplet "" heist $ heistInit' "" $ mempty - { hcLoadTimeSplices = defaultLoadTimeSplices - , hcCompiledSplices = splices - } + h <- nestSnaplet "" heist $ heistInit' "" hc addRoutes routes ref <- liftIO $ newIORef emptyJobRepo return $ App h ref + where + hc = emptyHeistConfig + & hcLoadTimeSplices .~ defaultLoadTimeSplices + & hcCompiledSplices .~ splices main :: IO () main = do @@ -121,8 +123,8 @@ -- type of job you need status for. splices = do -- You need one of these status splices per status job type - "jobStatus" ## statusSplice statusSplices getUrl getMyJobStatus - statusFinished + "jobStatus" MS.## statusSplice statusSplices getUrl getMyJobStatus + statusFinished where getUrl = do jobId <- getParam "jobId" @@ -150,5 +152,3 @@ return $ do jobId <- fromBS =<< mjidbs M.lookup jobId (repoJobs repo) - - diff --git a/snap-extras.cabal b/snap-extras.cabal --- a/snap-extras.cabal +++ b/snap-extras.cabal @@ -1,5 +1,5 @@ Name: snap-extras -Version: 0.11.0.2 +Version: 0.12.0.0 Synopsis: A collection of useful helpers and utilities for Snap web applications. Description: This package contains a collection of helper functions that come in handy in most practical, real-world @@ -13,7 +13,9 @@ Category: Web, Snap Build-type: Simple Cabal-version: >= 1.10 - +Extra-source-files: + README.md + changelog.md data-files: resources/templates/*.tpl @@ -46,7 +48,7 @@ hs-source-dirs: src Build-depends: - aeson >= 0.6 && < 0.11 + aeson >= 0.6 && < 1.2 , base >= 4 && < 5 , blaze-builder >= 0.3 && < 0.5 , blaze-html >= 0.6 && < 0.9 @@ -54,26 +56,27 @@ , case-insensitive >= 1.0 && < 1.3 , configurator >= 0.2 && < 0.4 , containers >= 0.3 && < 0.6 - , data-default >= 0.5 && < 0.6 + , data-default >= 0.5 && < 0.8 , digestive-functors >= 0.3 && < 0.9 , digestive-functors-heist >= 0.8 && < 0.9 - , digestive-functors-snap >= 0.3 && < 0.7 + , digestive-functors-snap >= 0.3 && < 0.8 , directory-tree >= 0.10 && < 0.13 , filepath >= 1.1 && < 1.5 - , heist >= 0.14 && < 0.15 + , heist >= 0.14 && < 1.1 , jmacro >= 0.6 && < 0.7 , lens < 5 , mtl >= 2.0 && < 2.3 , pcre-light >= 0.4 && < 0.5 , readable >= 0.1 && < 0.4 , safe >= 0.3 && < 0.4 - , snap >= 0.13 && < 0.15 - , snap-core >= 0.7 && < 0.10 + , snap >= 0.9 && < 1.1 + , snap-core >= 0.9 && < 1.1 , text >= 0.11 && < 1.3 - , time >= 1.4 && < 1.6 - , transformers >= 0.2 && < 0.5 + , time >= 1.4 && < 1.7 + , transformers >= 0.2 && < 0.6 , wl-pprint-text >= 1.1 && < 1.2 , xmlhtml >= 0.1.6 && < 0.3 + , map-syntax ghc-options: -Wall -fwarn-tabs default-language: Haskell2010 @@ -101,6 +104,7 @@ , text , time , transformers + , map-syntax Default-Language: Haskell2010 diff --git a/src/Snap/Extras/Ajax.hs b/src/Snap/Extras/Ajax.hs --- a/src/Snap/Extras/Ajax.hs +++ b/src/Snap/Extras/Ajax.hs @@ -25,10 +25,10 @@ ------------------------------------------------------------------------------- import Blaze.ByteString.Builder -import Control.Applicative +import Control.Applicative as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as T import Heist.Compiled import Language.Javascript.JMacro @@ -100,7 +100,7 @@ respond :: MonadSnap m => (ResponseType -> m b) -> m b respond f = do hs <- maybeBadReq "Accept header required for this handler" $ - getHeader "accept" <$> getRequest + getHeader "accept" A.<$> getRequest if B.isInfixOf "application/javascript" hs then f Ajax else f Html diff --git a/src/Snap/Extras/FlashNotice.hs b/src/Snap/Extras/FlashNotice.hs --- a/src/Snap/Extras/FlashNotice.hs +++ b/src/Snap/Extras/FlashNotice.hs @@ -15,6 +15,7 @@ import Control.Lens import Control.Monad import Control.Monad.Trans +import qualified Data.Map.Syntax as MS import Data.Maybe import Data.Monoid import Data.Text (Text) @@ -37,8 +38,8 @@ :: HasHeist b => Snaplet (Heist b) -> SnapletLens b SessionManager -> Initializer b v () initFlashNotice h session = do - let splices = ("flash" ## flashSplice session) - csplices = ("flash" ## flashCSplice session) + let splices = ("flash" MS.## flashSplice session) + csplices = ("flash" MS.## flashCSplice session) addConfig h $ mempty & scCompiledSplices .~ csplices & scInterpretedSplices .~ splices @@ -82,8 +83,8 @@ Just msg' -> do lift $ withTop session $ deleteFromSession k >> commitSession callTemplateWithText "_flash" $ do - "type" ## typ' - "message" ## msg' + "type" MS.## typ' + "message" MS.## msg' ------------------------------------------------------------------------------- @@ -98,8 +99,8 @@ k = T.concat ["_", typ] getVal = lift $ withTop session $ getFromSession k ss = do - "type" ## return $ C.yieldPureText typ - "message" ## return $ C.yieldRuntimeText + "type" MS.## return $ C.yieldPureText typ + "message" MS.## return $ C.yieldRuntimeText $ liftM (fromMaybe "Flash notice cookie error") getVal flashTemplate <- C.withLocalSplices ss mempty (C.callTemplate "_flash") diff --git a/src/Snap/Extras/FormUtils.hs b/src/Snap/Extras/FormUtils.hs --- a/src/Snap/Extras/FormUtils.hs +++ b/src/Snap/Extras/FormUtils.hs @@ -24,17 +24,17 @@ ------------------------------------------------------------------------------- import Control.Monad.Trans.Maybe -import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Char8 as B import Data.Maybe import Data.String -import Data.Text (Text) -import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Text as T import Data.Text.Encoding -import Heist hiding (Error) +import Heist import Safe import Snap.Core -import Text.Digestive -import qualified Text.XmlHtml as X +import Text.Digestive as DF +import qualified Text.XmlHtml as X ------------------------------------------------------------------------------- @@ -50,7 +50,7 @@ => a -> Result v (Maybe a) maybeTrans x = f x where f "" = Success Nothing - f a = Success $ Just a + f a = Success $ Just a ------------------------------------------------------------------------------- @@ -66,7 +66,7 @@ readTrans :: (Read a, IsString v) => Text -> Result v a -readTrans a = maybe (Error "Unrecognized input") Success $ readMay . T.unpack $ a +readTrans a = maybe (DF.Error "Unrecognized input") Success $ readMay . T.unpack $ a diff --git a/src/Snap/Extras/JSON.hs b/src/Snap/Extras/JSON.hs --- a/src/Snap/Extras/JSON.hs +++ b/src/Snap/Extras/JSON.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} module Snap.Extras.JSON - ( + ( -- * Parsing JSON from Request Body getBoundedJSON , getJSON @@ -13,8 +13,8 @@ -- * Sending JSON Data , writeJSON ) where - + ------------------------------------------------------------------------------- import Data.Aeson as A import qualified Data.ByteString.Char8 as B @@ -37,7 +37,7 @@ -- | Demand the presence of JSON in the body with a size up to N -- bytes. If parsing fails for any reson, request is terminated early -- and a server error is returned. -reqBoundedJSON +reqBoundedJSON :: (MonadSnap m, FromJSON a) => Int64 -- ^ Maximum size in bytes @@ -58,13 +58,13 @@ ------------------------------------------------------------------------------- -- | Parse request body into JSON or return an error string. -getBoundedJSON - :: (MonadSnap m, FromJSON a) - => Int64 +getBoundedJSON + :: (MonadSnap m, FromJSON a) + => Int64 -- ^ Maximum size in bytes -> m (Either String a) getBoundedJSON n = do - bodyVal <- A.decode `fmap` readRequestBody n + bodyVal <- A.decode `fmap` readRequestBody (fromIntegral n) return $ case bodyVal of Nothing -> Left "Can't find JSON data in POST body" Just v -> case A.fromJSON v of @@ -74,7 +74,7 @@ ------------------------------------------------------------------------------- -- | Get JSON data from the given Param field -getJSONField +getJSONField :: (MonadSnap m, FromJSON a) => B.ByteString -> m (Either String a) @@ -85,7 +85,7 @@ Just val' -> case A.decode (LB.fromChunks . return $ val') of Nothing -> Left $ "Can't decode JSON data in field " ++ B.unpack fld - Just v -> + Just v -> case A.fromJSON v of A.Error e -> Left e A.Success a -> Right a @@ -93,7 +93,7 @@ ------------------------------------------------------------------------------- -- | Force the JSON value from field. Similar to 'getJSONField' -reqJSONField +reqJSONField :: (MonadSnap m, FromJSON a) => B.ByteString -> m a diff --git a/src/Snap/Extras/MethodOverride.hs b/src/Snap/Extras/MethodOverride.hs --- a/src/Snap/Extras/MethodOverride.hs +++ b/src/Snap/Extras/MethodOverride.hs @@ -6,7 +6,7 @@ ) where ------------------------------------------------------------------------------- -import Control.Applicative +import Control.Applicative as A import Data.ByteString (ByteString) import Data.CaseInsensitive (mk, original) import Data.Maybe (fromMaybe) @@ -47,7 +47,7 @@ | otherwise = r where overridden = fromMaybe POST $ do - meth <- mk <$> (headMay =<< rqParam param r) + meth <- mk A.<$> (headMay =<< rqParam param r) case meth of "HEAD" -> Just HEAD "POST" -> Just POST diff --git a/src/Snap/Extras/NavTrails.hs b/src/Snap/Extras/NavTrails.hs --- a/src/Snap/Extras/NavTrails.hs +++ b/src/Snap/Extras/NavTrails.hs @@ -8,6 +8,7 @@ import Control.Lens hiding (lens) import Control.Monad.State.Strict import Data.ByteString (ByteString) +import qualified Data.Map.Syntax as MS import Data.Maybe import Data.Monoid import Data.Text (Text) @@ -131,8 +132,8 @@ & scInterpretedSplices .~ interpretedSplices lens where compiledSplices lens = do - "linkToFocus" ## focusCSplice lens - "linkToBack" ## backCSplice + "linkToFocus" MS.## focusCSplice lens + "linkToBack" MS.## backCSplice interpretedSplices lens = do - "linkToFocus" ## focusSplice lens - "linkToBack" ## backSplice + "linkToFocus" MS.## focusSplice lens + "linkToBack" MS.## backSplice diff --git a/src/Snap/Extras/PollStatus.hs b/src/Snap/Extras/PollStatus.hs --- a/src/Snap/Extras/PollStatus.hs +++ b/src/Snap/Extras/PollStatus.hs @@ -65,7 +65,7 @@ > splices = do > ... -> "myJobStatus" ## statusSplice splices getUrl getMyJobStatus isFinished +> "myJobStatus" MS.## statusSplice splices getUrl getMyJobStatus isFinished You need to bind this splice once for each type of action that you are polling, each with its own splice name and function for getting the job @@ -96,6 +96,7 @@ import Control.Monad.Trans import Control.Monad.Trans.Maybe import Data.ByteString (ByteString) +import qualified Data.Map.Syntax as MS import Data.Maybe import Data.Monoid import Data.Readable @@ -171,8 +172,8 @@ return (js, s) where allSplices = do - "updateJs" ## pureSplice internalUpdate - mapV (. liftM snd) splices + "updateJs" MS.## pureSplice internalUpdate + MS.mapV (. liftM snd) splices internalUpdate (js,s) = if not $ isFinished s then BB.fromText js @@ -214,7 +215,7 @@ jobFinished :: JobState -> Bool jobFinished FinishedSuccess = True jobFinished FinishedFailure = True -jobFinished _ = False +jobFinished _ = False ------------------------------------------------------------------------------ @@ -253,22 +254,22 @@ :: Monad n => Splices (RuntimeSplice n Status -> Splice n) statusSplices = do - "ifPending" ## ifCSplice ((==Pending) . statusJobState) - "ifRunning" ## ifCSplice ((==Running) . statusJobState) - "ifNotFinished" ## ifCSplice (not . statusFinished) - "ifFinished" ## ifCSplice (statusFinished) - "ifFinishedSuccess" ## ifCSplice ((==FinishedSuccess) . statusJobState) - "ifFinishedFailure" ## ifCSplice ((==FinishedFailure) . statusJobState) - "messages" ## manyWithSplices runChildren - ("msgText" ## pureSplice (textSplice id)) . + "ifPending" MS.## ifCSplice ((==Pending) . statusJobState) + "ifRunning" MS.## ifCSplice ((==Running) . statusJobState) + "ifNotFinished" MS.## ifCSplice (not . statusFinished) + "ifFinished" MS.## ifCSplice (statusFinished) + "ifFinishedSuccess" MS.## ifCSplice ((==FinishedSuccess) . statusJobState) + "ifFinishedFailure" MS.## ifCSplice ((==FinishedFailure) . statusJobState) + "messages" MS.## manyWithSplices runChildren + ("msgText" MS.## pureSplice (textSplice id)) . (liftM $ statusMessages) - mapV pureSplice $ do - "startTime" ## textSplice (tshow . statusStartTime) - "endTime" ## textSplice (tshow . statusTimestamp) - "jobState" ## textSplice (tshow . statusJobState ) - "percentCompleted" ## textSplice (tshow . statusPercentCompleted) - "amountCompleted" ## textSplice (tshow . statusAmountCompleted) - "amountTotal" ## textSplice (tshow . statusAmountTotal) + MS.mapV pureSplice $ do + "startTime" MS.## textSplice (tshow . statusStartTime) + "endTime" MS.## textSplice (tshow . statusTimestamp) + "jobState" MS.## textSplice (tshow . statusJobState ) + "percentCompleted" MS.## textSplice (tshow . statusPercentCompleted) + "amountCompleted" MS.## textSplice (tshow . statusAmountCompleted) + "amountTotal" MS.## textSplice (tshow . statusAmountTotal) ------------------------------------------------------------------------------ diff --git a/src/Snap/Extras/SpliceUtils/Common.hs b/src/Snap/Extras/SpliceUtils/Common.hs --- a/src/Snap/Extras/SpliceUtils/Common.hs +++ b/src/Snap/Extras/SpliceUtils/Common.hs @@ -4,7 +4,6 @@ import Control.Monad.Trans import qualified Data.Foldable as F import Data.List -import Snap import System.Directory.Tree import System.FilePath ------------------------------------------------------------------------------- diff --git a/src/Snap/Extras/SpliceUtils/Compiled.hs b/src/Snap/Extras/SpliceUtils/Compiled.hs --- a/src/Snap/Extras/SpliceUtils/Compiled.hs +++ b/src/Snap/Extras/SpliceUtils/Compiled.hs @@ -12,14 +12,15 @@ import Blaze.ByteString.Builder.ByteString import Control.Monad import Control.Monad.Trans +import qualified Data.Map.Syntax as MS import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Snap.Core -import qualified Snap.Extras.SpliceUtils.Interpreted as I +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Heist import Heist.Compiled import Heist.Compiled.LowLevel +import Snap.Core +import qualified Snap.Extras.SpliceUtils.Interpreted as I import Text.XmlHtml import Text.XmlHtml.Cursor ------------------------------------------------------------------------------- @@ -27,8 +28,8 @@ utilSplices :: MonadSnap m => Splices (Splice m) utilSplices = do - "rqparam" ## paramSplice - "refererLink" ## refererCSplice + "rqparam" MS.## paramSplice + "refererLink" MS.## refererCSplice refererCSplice :: MonadSnap m => Splice m @@ -98,10 +99,10 @@ p <- newEmptyPromise let splices' = do - mapV ($ getPromise p) splices - "prelude" ## return mempty - "interlude" ## return mempty - "postlude" ## return mempty + MS.mapV ($ getPromise p) splices + "prelude" MS.## return mempty + "interlude" MS.## return mempty + "postlude" MS.## return mempty preChunks <- findNamedChild n "prelude" interChunks <- findNamedChild n "interlude" diff --git a/src/Snap/Extras/SpliceUtils/Interpreted.hs b/src/Snap/Extras/SpliceUtils/Interpreted.hs --- a/src/Snap/Extras/SpliceUtils/Interpreted.hs +++ b/src/Snap/Extras/SpliceUtils/Interpreted.hs @@ -14,8 +14,8 @@ ------------------------------------------------------------------------------- import Control.Monad import Control.Monad.Trans -import Control.Monad.Trans.Class import qualified Data.Configurator as C +import qualified Data.Map.Syntax as MS import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -33,8 +33,8 @@ -- | A list of splices offered in this module utilSplices :: Splices (SnapletISplice b) utilSplices = do - "rqparam" ## paramSplice - "refererLink" ## refererSplice + "rqparam" MS.## paramSplice + "refererLink" MS.## refererSplice refererSplice :: MonadSnap m => Splice m @@ -51,7 +51,7 @@ at <- liftM (getAttribute "name") getParamNode val <- case at of Just at' -> lift . getParam $ T.encodeUtf8 at' - Nothing -> return Nothing + Nothing -> return Nothing return $ maybe [] ((:[]) . TextNode . T.decodeUtf8) val @@ -64,7 +64,7 @@ -- -- > heistLocal runTextAreas $ render "joo/index" runTextAreas :: Monad m => HeistState m -> HeistState m -runTextAreas = bindSplices ("textarea" ## ta) +runTextAreas = bindSplices ("textarea" MS.## ta) where ta = do hs <- getHS @@ -92,16 +92,16 @@ -> Splice m selectSplice nm fid xs defv = callTemplate "_select" $ do - "options" ## opts - "name" ## textSplice nm - "id" ## textSplice fid + "options" MS.## opts + "name" MS.## textSplice nm + "id" MS.## textSplice fid where opts = mapSplices gen xs gen (val,txt) = runChildrenWith $ do - "val" ## textSplice val - "text" ## textSplice txt - "ifSelected" ## ifISplice $ maybe False (== val) defv - "ifNotSelected" ## ifISplice $ maybe True (/= val) defv + "val" MS.## textSplice val + "text" MS.## textSplice txt + "ifSelected" MS.## ifISplice $ maybe False (== val) defv + "ifNotSelected" MS.## ifISplice $ maybe True (/= val) defv ------------------------------------------------------------------------------ diff --git a/src/Snap/Extras/Tabs.hs b/src/Snap/Extras/Tabs.hs --- a/src/Snap/Extras/Tabs.hs +++ b/src/Snap/Extras/Tabs.hs @@ -25,8 +25,8 @@ import Control.Lens import Control.Monad import Control.Monad.Trans +import qualified Data.Map.Syntax as MS import Data.Maybe -import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -46,8 +46,8 @@ ------------------------------------------------------------------------------- initTabs :: HasHeist b => Snaplet (Heist b) -> Initializer b v () initTabs h = do - let splices = ("tabs" ## tabsSplice) - csplices = ("tabs" ## tabsCSplice) + let splices = ("tabs" MS.## tabsSplice) + csplices = ("tabs" MS.## tabsCSplice) addConfig h $ mempty & scCompiledSplices .~ csplices & scInterpretedSplices .~ splices @@ -63,7 +63,7 @@ tabsCSplice = do n <- getParamNode let getCtx = lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest - splices = ("tab" ## tabCSplice getCtx) + splices = ("tab" MS.## tabCSplice getCtx) case n of Element _ attrs ch -> C.withLocalSplices splices mempty $ C.runNode $ X.Element "ul" attrs ch @@ -138,7 +138,7 @@ tabsSplice :: MonadSnap m => Splice m tabsSplice = do context <- lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest - let bind = bindSplices ("tab" ## tabSplice context) + let bind = bindSplices ("tab" MS.## tabSplice context) n <- getParamNode case n of Element _ attrs ch -> localHS bind $ runNodeList [X.Element "ul" attrs ch] @@ -218,15 +218,15 @@ tab url text attr md context = X.Element "li" attr' [tlink url text] where cur = case md of - TAMExactMatch -> url == context + TAMExactMatch -> url == context TAMPrefixMatch -> url `T.isPrefixOf` context - TAMInfixMatch -> url `T.isInfixOf` context - TAMDontMatch -> False + TAMInfixMatch -> url `T.isInfixOf` context + TAMDontMatch -> False attr' = if cur then ("class", klass) : attr else attr klass = case lookup "class" attr of - Just k -> T.concat [k, " ", "active"] + Just k -> T.concat [k, " ", "active"] Nothing -> "active"