diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +* 0.3.0.2 Libby Horacek 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 2016-3-11 - Change repository location, copyright. diff --git a/fn-extra.cabal b/fn-extra.cabal --- 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 @@ 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 @@ , 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 --- a/src/Web/Fn/Extra/Digestive.hs +++ b/src/Web/Fn/Extra/Digestive.hs @@ -10,24 +10,21 @@ 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 @@ 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 --- 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.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 @@ 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