summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLibbyHoracek <>2017-09-13 00:26:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-09-13 00:26:00 (GMT)
commit138f1440dab558084a0f0febd3db29a23bde7b9f (patch)
tree2fb58e22aebf1ec39dced711f6853fbeea560829
parent86fdff751cf9006871328367a80c8c4beffc6b5b (diff)
version 0.3.0.2HEAD0.3.0.2master
-rw-r--r--CHANGELOG.md5
-rw-r--r--fn-extra.cabal5
-rw-r--r--src/Web/Fn/Extra/Digestive.hs52
-rw-r--r--src/Web/Fn/Extra/Heist.hs19
4 files changed, 41 insertions, 40 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 2ecac35..5b33c2c 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,8 @@
+* 0.3.0.2 Libby Horacek <libby@positiondev.com> 2017-7-17
+
+ - Don't send empty files to Digestive Functors.
+ - Add support for Heist 1.0 and above.
+
* 0.3.0.1 Daniel Patterson <dbp@dbpmail.net> 2016-3-11
- Change repository location, copyright.
diff --git a/fn-extra.cabal b/fn-extra.cabal
index 0674b43..22dc39e 100644
--- a/fn-extra.cabal
+++ b/fn-extra.cabal
@@ -1,5 +1,5 @@
name: fn-extra
-version: 0.3.0.1
+version: 0.3.0.2
synopsis: Extras for Fn, a functional web framework.
description: Please see README.
homepage: http://github.com/positiondev/fn#readme
@@ -18,7 +18,7 @@ library
hs-source-dirs: src
exposed-modules: Web.Fn.Extra.Heist
, Web.Fn.Extra.Digestive
- build-depends: base >= 4.7 && < 5
+ build-depends: base >= 4.7 && < 6
, heist
, xmlhtml
, http-types
@@ -35,6 +35,7 @@ library
, either
, digestive-functors
, fn
+ , map-syntax
default-language: Haskell2010
ghc-options: -Wall
diff --git a/src/Web/Fn/Extra/Digestive.hs b/src/Web/Fn/Extra/Digestive.hs
index f289674..4594e5a 100644
--- a/src/Web/Fn/Extra/Digestive.hs
+++ b/src/Web/Fn/Extra/Digestive.hs
@@ -10,24 +10,21 @@ import Control.Monad.Trans.Resource
import Data.ByteString (ByteString)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
-import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Types.Method
import Network.Wai (Request (..))
-import Network.Wai.Parse (BackEnd, File, FileInfo (..),
- fileContent, parseRequestBody,
- tempFileBackEndOpts)
-import System.Directory (getTemporaryDirectory)
-import Text.Digestive
-import Text.Digestive.Types
-import Text.Digestive.View
-import Web.Fn hiding (File, fileContent)
+import Network.Wai.Parse (File, FileInfo (..), fileContent,
+ parseRequestBody)
+import Text.Digestive (Form, View, FormInput(..), Env, fromPath, postForm, getForm)
+import Web.Fn hiding (File)
queryFormEnv :: [(ByteString, Maybe ByteString)] -> [File FilePath] -> Env IO
queryFormEnv qs fs = \pth ->
- let qs' = map TextInput $ map (T.decodeUtf8 . fromMaybe "" . snd) $ filter ((==) (fromPath pth) . T.decodeUtf8 . fst) qs
- fs' = map FileInput $ map (fileContent . snd) $ filter ((==) (fromPath pth) . T.decodeUtf8 . fst) fs
+ let qs' = map (TextInput . T.decodeUtf8 . fromMaybe "" . snd) $ filter (forSubForm pth) qs
+ fs' = map (FileInput . fileContent . snd) $ filter (forSubForm pth) $ filter fileNameNotEmpty fs
in return $ qs' ++ fs'
+ where fileNameNotEmpty (_formName, fileInfo) = Network.Wai.Parse.fileName fileInfo /= "\"\""
+ forSubForm pth = (==) (fromPath pth) . T.decodeUtf8 . fst
requestFormEnv :: FnRequest -> ResourceT IO (Env IO)
requestFormEnv req = do
@@ -39,36 +36,25 @@ requestFormEnv req = do
case v of
Nothing -> liftIO $ parseRequestBody (tempFileBackEnd' st)
(fst req)
- Just (q,_) -> return (q,[])
- return $ queryFormEnv ((map (second Just) query) ++ queryString (fst req)) files
-
-tempFileBackEnd' :: InternalState -> ignored1 -> FileInfo () -> IO ByteString -> IO FilePath
-tempFileBackEnd' is x fi@(FileInfo nm _ _) = tempFileBackEndOpts getTemporaryDirectory (T.unpack $ T.decodeUtf8 nm) is x fi
+ Just (q,_) -> return q
+ return $ queryFormEnv (map (second Just) query ++ queryString (fst req)) files
-- | This function runs a form and passes the function in it's last
-- argument the result, which is a 'View' and an optional result. If
-- the request is a get, or if the form failed to validate, the result
-- will be 'Nothing' and you should render the form (with the errors
-- from the 'View').
---
--- WARNING: If you have already parsed the request body with '!=>'
--- (even if the route didn't end up matching), this will _only_ get
--- post parameters, it will not see any files that were posted. This
--- is a current implementation limitation that will (hopefully) be
--- resolved eventually, but for now, it is safest to just never use
--- '!=>' if you are using digestive functors (as the expectation is
--- that it will be handling all your POST needs!).
runForm :: RequestContext ctxt =>
- ctxt
- -> Text
- -> Form v IO a
- -> ((View v, Maybe a) -> IO a1)
- -> IO a1
+ ctxt
+ -> Text
+ -> Form v IO a
+ -> ((View v, Maybe a) -> IO a1)
+ -> IO a1
runForm ctxt nm frm k =
runResourceT $ let r = fst (getRequest ctxt) in
if requestMethod r == methodPost
then do env <- requestFormEnv (getRequest ctxt)
- r <- liftIO $ postForm nm frm (const (return env))
- liftIO $ k r
- else do r <- (,Nothing) <$> liftIO (getForm nm frm)
- liftIO $ k r
+ r' <- liftIO $ postForm nm frm (const (return env))
+ liftIO $ k r'
+ else do r' <- (,Nothing) <$> liftIO (getForm nm frm)
+ liftIO $ k r'
diff --git a/src/Web/Fn/Extra/Heist.hs b/src/Web/Fn/Extra/Heist.hs
index 38d34e0..4cd2d7e 100644
--- a/src/Web/Fn/Extra/Heist.hs
+++ b/src/Web/Fn/Extra/Heist.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
{-|
@@ -44,6 +45,9 @@ import Control.Arrow (first)
import Control.Lens
import Control.Monad.State
import Control.Monad.Trans.Either
+#if MIN_VERSION_heist(1,0,0)
+import Data.Map.Syntax ((##))
+#endif
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
@@ -89,11 +93,16 @@ heistInit :: HeistContext ctxt =>
IO (Either [String] (FnHeistState ctxt))
heistInit templateLocations isplices csplices =
do let ts = map (loadTemplates . T.unpack) templateLocations
- runEitherT $ initHeist (emptyHeistConfig & hcTemplateLocations .~ ts
- & hcInterpretedSplices .~ isplices
- & hcLoadTimeSplices .~ defaultLoadTimeSplices
- & hcCompiledSplices .~ csplices
- & hcNamespace .~ "")
+ let config = emptyHeistConfig & hcTemplateLocations .~ ts
+ & hcInterpretedSplices .~ isplices
+ & hcLoadTimeSplices .~ defaultLoadTimeSplices
+ & hcCompiledSplices .~ csplices
+ & hcNamespace .~ ""
+#if MIN_VERSION_heist(1,0,0)
+ initHeist config
+#else
+ runEitherT $ initHeist config
+#endif
-- | Render interpreted templates according to the request path. Note
-- that if you have matched some parts of the path, those will not be