updated to ghc 8.4.2 and a few minor additions

snap-extras.cabal

@@ -1,5 +1,5 @@
 Name:                snap-extras
-Version:             0.12.2.0
+Version:             0.12.2.1
 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
@@ -48,34 +48,34 @@ Library
 
   hs-source-dirs: src
   Build-depends:
-      aeson                    >= 0.6   && < 1.3
-    , base                     >= 4     && < 5
-    , blaze-builder            >= 0.3   && < 0.5
-    , blaze-html               >= 0.6   && < 0.10
-    , bytestring               >= 0.9.1 && < 0.11
-    , case-insensitive         >= 1.0   && < 1.3
-    , configurator             >= 0.2   && < 0.4
-    , containers               >= 0.3   && < 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.8
-    , directory-tree           >= 0.10  && < 0.13
-    , filepath                 >= 1.1   && < 1.5
-    , heist                    >= 0.14  && < 1.1
-    , jmacro                   >= 0.6   && < 0.7
+      aeson                    >= 0.6   
+    , base                     >= 4     
+    , blaze-builder            >= 0.3   
+    , blaze-html               >= 0.6   
+    , bytestring               >= 0.9.1 
+    , case-insensitive         >= 1.0   
+    , configurator             >= 0.2   
+    , containers               >= 0.3   
+    , data-default             >= 0.5   
+    , digestive-functors       >= 0.3   
+    , digestive-functors-heist >= 0.8   
+    , digestive-functors-snap  >= 0.3   
+    , directory-tree           >= 0.10  
+    , filepath                 >= 1.1   
+    , heist                    >= 0.14  
+    , jmacro                   >= 0.6   
     , 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.9  && < 1.1
-    , snap-core                >= 0.9   && < 1.1
-    , text                     >= 0.11  && < 1.3
-    , time                     >= 1.4   && < 1.9
-    , transformers             >= 0.2   && < 0.6
-    , wl-pprint-text           >= 1.1   && < 1.2
-    , xmlhtml                  >= 0.1.6 && < 0.3
+    , mtl                      >= 2.0   
+    , pcre-light               >= 0.4   
+    , readable                 >= 0.1   
+    , safe                     >= 0.3   
+    , snap                     >= 0.9   
+    , snap-core                >= 0.9   
+    , text                     >= 0.11  
+    , time                     >= 1.4   
+    , transformers             >= 0.2   
+    , wl-pprint-text           >= 1.1   
+    , xmlhtml                  >= 0.1.6 
     , map-syntax
 
   ghc-options: -Wall -fwarn-tabs

src/Snap/Extras/Ajax.hs

@@ -17,53 +17,65 @@
 module Snap.Extras.Ajax
     ( replaceWith
     , replaceWithTemplate
+    , replaceWithTemplateWithSplices
+    , jmacroToByteString
     , ResponseType (..)
     , respond
     , responds
     , htmlOrAjax
+    , respondAjax
     ) where
 
 -------------------------------------------------------------------------------
 import           Blaze.ByteString.Builder
-import           Control.Applicative        as A
-import           Data.ByteString.Char8      (ByteString)
-import qualified Data.ByteString.Char8      as B
-import           Data.Text                  (Text)
-import qualified Data.Text                  as T
+import           Control.Monad
+import           Control.Applicative          as A
+import           Data.ByteString.Char8        (ByteString)
+import qualified Data.ByteString.Char8        as B
+import qualified Data.ByteString.Lazy as BL
+import           Data.Text                    (Text)
+import qualified Data.Text                    as T
+import qualified Data.Text.Encoding           as T
 import           Heist.Compiled
+import qualified Heist.Interpreted as I
+import           Heist.Splices
+import           Heist
 import           Language.Javascript.JMacro
 import           Safe
 import           Snap.Core
 import           Snap.Extras.CoreUtils
 import           Snap.Snaplet
 import           Snap.Snaplet.Heist
+import qualified Text.PrettyPrint.Leijen.Text as PP
+import qualified Text.XmlHtml as H
 -------------------------------------------------------------------------------
 
 
--- | Replace innerHTML of given selector with given conntent.
+-- | Replace innerHTML of given selector with given content.
 replaceWith
     :: MonadSnap m
     => Text
     -- ^ jquery selector
     -> ByteString
     -- ^ content blob
     -> m ()
-replaceWith selector bs = do
-    let bs' = B.unpack bs
-        sel = T.unpack selector
+replaceWith sel bs = do
     jsResponse
-    writeBS $ B.pack $ show . renderJs $ replaceWithJs bs' sel
+    writeBS $ jmacroToByteString $ replaceWithJs bs sel
 
 
 -- | Produce JS statement to replace a target's inner with given
 -- contents.
-replaceWithJs :: String -> String -> JStat
+replaceWithJs :: ByteString -> Text -> JStat
 replaceWithJs bs sel = [jmacro|
-    var contents = `(bs)`;
+    var contents = `(T.decodeUtf8 bs)`;
     var replaceJs = function() { $(`(sel)`).html(contents); };
     replaceJs();
 |]
 
+-- | Converts JMacro-generated Javascript code to a @ByteString@.
+jmacroToByteString :: JStat -> ByteString
+jmacroToByteString = T.encodeUtf8 . PP.displayTStrict . PP.renderCompact . renderJs
 
 -------------------------------------------------------------------------------
 -- | Replace the inner HTML element of a given selector with the
@@ -84,7 +96,24 @@ replaceWithTemplate nm sel = do
     bld' <- withTop' id bld
     replaceWith sel (toByteString bld')
 
-
+-- | Same as @replaceWithTemplate@, but takes additional splices to render the template.
+replaceWithTemplateWithSplices
+    :: HasHeist b
+    => Splices (I.Splice (Handler b b))
+    -- ^ bound splices
+    -> ByteString
+    -- ^ Heist template name
+    -> Text
+    -- ^ jQuery selector for target element on page
+    -> Handler b v ()
+replaceWithTemplateWithSplices splices nm sel = do
+    doc <- withHeistState $ \ hs -> do
+        mb <- I.renderTemplateToDoc (I.bindSplices splices hs) nm
+        case mb of
+          Nothing -> badReq "Could not render a response." 
+          Just doc -> return doc
+    bs' <- liftM (BL.toStrict . toLazyByteString . H.renderHtmlFragment H.UTF8 . H.docContent) $ withTop' id doc
+    replaceWith sel bs'
 
 -------------------------------------------------------------------------------
 -- | Possible reponse types we support at the moment. Can be expanded
@@ -124,4 +153,6 @@ htmlOrAjax f g = respond $ \ ty -> case ty of
     Html -> f
     Ajax -> g
 
-
+-- | Responding only to AJAX requests.
+respondAjax :: MonadSnap m => m () -> m ()
+respondAjax = htmlOrAjax pass

src/Snap/Extras/JSON.hs

@@ -4,8 +4,8 @@
 module Snap.Extras.JSON
     (
     -- * Parsing JSON from Request Body
-      getBoundedJSON
-    , getJSON
+      getBoundedJSON,getBoundedJSON'
+    , getJSON,getJSON'
     , reqBoundedJSON
     , reqJSON
     , getJSONField
@@ -55,6 +55,11 @@ reqBoundedJSON n = do
 getJSON :: (MonadSnap m, A.FromJSON a) => m (Either String a)
 getJSON = getBoundedJSON 50000
 
+-------------------------------------------------------------------------------
+-- | Try to parse request body as a generic JSON @Object@ with a default max size of
+-- 50000.
+getJSON' :: (MonadSnap m) => m (Either String Object)
+getJSON' = getBoundedJSON' 50000
 
 -------------------------------------------------------------------------------
 -- | Parse request body into JSON or return an error string.
@@ -71,6 +76,19 @@ getBoundedJSON n = do
                 A.Error e -> Left e
                 A.Success a -> Right a
 
+-------------------------------------------------------------------------------
+-- | Parse request body into a generic JSON @Object@ or return an error string.
+getBoundedJSON'
+    :: (MonadSnap m)
+    => Int64
+    -- ^ Maximum size in bytes
+    -> m (Either String Object)
+getBoundedJSON' n = do
+  bodyVal <- A.decode `fmap` readRequestBody (fromIntegral n)
+  return $ case bodyVal of
+    Nothing -> Left $ "Can't find JSON data in POST body"
+    Just v -> Right v
+
 
 -------------------------------------------------------------------------------
 -- | Get JSON data from the given Param field

src/Snap/Extras/SpliceUtils/Interpreted.hs

@@ -14,6 +14,7 @@ module Snap.Extras.SpliceUtils.Interpreted
 -------------------------------------------------------------------------------
 import           Control.Monad
 import           Control.Monad.Trans
+import           Control.Monad.Fail
 import qualified Data.Configurator              as C
 import qualified Data.Map.Syntax                as MS
 import           Data.Text                      (Text)
@@ -63,7 +64,7 @@ paramSplice = do
 -- by putting the name of a splice as the value of a textarea tag.
 --
 -- > heistLocal runTextAreas $ render "joo/index"
-runTextAreas :: Monad m => HeistState m -> HeistState m
+runTextAreas :: (MonadFail m) => HeistState m -> HeistState m
 runTextAreas = bindSplices ("textarea" MS.## ta)
  where
    ta = do