diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,18 @@ -* 0.2.0.1 Daniel Patterson 2015-1-20 +* 0.3.0.0 Daniel Patterson 2016-3-2 + + - Switch Heist to use StateT rather than ReaderT, so splices can + update context. + - Add support for compiled heist. + - Add support for digestive functors. Note: current (significant) + limitation is that if you have _already_ parsed the request body + with `!=>` then we can only use post params and not files. This is + because `Fn` parses them to lazy bytestrings, but digestive + functors wants them in temporary files, and for now, we're not + converting (it could be done). But, the expectation is that if you + are using digestive functors, you won't ever be parsing post + bodies with `!=>`. + +* 0.2.0.1 Daniel Patterson 2016-1-20 - Fix for GHC 7.8.4, which cabal file said would work, but didn't. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ ## About This repository has some helpers that have heavier dependencies than -core [fn](http://hackage.haskell.org). In general, things get added +core [fn](http://hackage.haskell.org/package/fn). In general, things get added here whenever using libraries on their own conflicts with the design goals of `Fn`. This could mean that there is a lot of boilerplate to get them set up, or they are heavily monadic (in which case the code 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.2.0.1 +version: 0.3.0.0 synopsis: Extras for Fn, a functional web framework. description: Please see README. homepage: http://github.com/dbp/fn#readme @@ -7,7 +7,7 @@ license-file: LICENSE author: Daniel Patterson maintainer: Daniel Patterson -copyright: 2015 Daniel Patterson +copyright: 2016 Daniel Patterson category: Web build-type: Simple extra-source-files: CHANGELOG.md @@ -17,18 +17,23 @@ library hs-source-dirs: src exposed-modules: Web.Fn.Extra.Heist + , Web.Fn.Extra.Digestive build-depends: base >= 4.7 && < 5 , heist , xmlhtml , http-types , wai , wai-util + , wai-extra + , resourcet , mtl , text , blaze-builder , bytestring , lens + , directory , either + , digestive-functors , fn default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Web/Fn/Extra/Digestive.hs b/src/Web/Fn/Extra/Digestive.hs new file mode 100644 --- /dev/null +++ b/src/Web/Fn/Extra/Digestive.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +module Web.Fn.Extra.Digestive (runForm) where + +import Control.Applicative ((<$>)) +import Control.Arrow (second) +import Control.Concurrent.MVar (readMVar) +import Control.Monad.Trans (liftIO) +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) + +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 + in return $ qs' ++ fs' + +requestFormEnv :: FnRequest -> ResourceT IO (Env IO) +requestFormEnv req = do + st <- getInternalState + v <- case snd req of + Nothing -> return Nothing + Just mv -> liftIO (readMVar mv) + (query, files) <- + 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 + +-- | 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 +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 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 @@ -6,8 +6,8 @@ `Fn`'s stance against monad transformers and for regular functions. In particular, it instantiates the Monad for HeistState to be a -ReaderT that contains our context, so that in the splices we can get -the context out. +StateT that contains our context, so that in the splices we can get +the context out (and modify it if needed). Further, we add splice builders that work similar to our url routing - splices are declared to have certain attributes of specific @@ -20,12 +20,15 @@ HeistContext(..) , FnHeistState , FnSplice + , FnCSplice -- * Initializer , heistInit -- * Rendering templates , heistServe , render , renderWithSplices + , cHeistServe + , cRender -- * Building splices , tag , tag' @@ -36,10 +39,10 @@ ) where import Blaze.ByteString.Builder -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first) import Control.Lens -import Control.Monad.Reader +import Control.Monad.State import Control.Monad.Trans.Either import Data.Monoid import Data.Text (Text) @@ -47,47 +50,56 @@ import qualified Data.Text.Encoding as T import Data.Text.Read (decimal, double) import Heist -import Heist.Interpreted +import qualified Heist.Compiled as C +import qualified Heist.Interpreted as I import Network.HTTP.Types import Network.Wai import qualified Network.Wai.Util as W import qualified Text.XmlHtml as X import Web.Fn --- | The type of our state. We need a ReaderT to be able to pass the +-- | The type of our state. We need a StateT to be able to pass the -- runtime context (which includes the current request) into the -- splices. -type FnHeistState ctxt = HeistState (ReaderT ctxt IO) +type FnHeistState ctxt = HeistState (StateT ctxt IO) --- | The type of our splice. We need a ReaderT to be able to pass the --- runtime context (which includes the current request) into the --- splice. -type FnSplice ctxt = Splice (ReaderT ctxt IO) +-- | The type of our splice (interpreted version). We need a StateT to +-- be able to pass the runtime context (which includes the current +-- request) into the splice (and sometimes modify it). +type FnSplice ctxt = I.Splice (StateT ctxt IO) +-- | The type of our splice (compiled version). We need a StateT to +-- be able to pass the runtime context (which includes the current +-- request) into the splice (and sometimes modify it). +type FnCSplice ctxt = C.Splice (StateT ctxt IO) + + -- | In order to have render be able to get the 'FnHeistState' out of -- our context, we need this helper class. class HeistContext ctxt where getHeist :: ctxt -> FnHeistState ctxt -- | Initialize heist. This takes a list of paths to template --- directories and a set of interpreted splices. Currently, we don't --- have support for compiled splices yet (so you can drop down to just --- plain Heist if you want them). +-- directories, a set of interpreted splices, and a set of compiled +-- splices (you can pass @mempty@ as either) heistInit :: HeistContext ctxt => [Text] -> - Splices (Splice (ReaderT ctxt IO)) -> + Splices (FnSplice ctxt) -> + Splices (FnCSplice ctxt) -> IO (Either [String] (FnHeistState ctxt)) -heistInit templateLocations splices = +heistInit templateLocations isplices csplices = do let ts = map (loadTemplates . T.unpack) templateLocations runEitherT $ initHeist (emptyHeistConfig & hcTemplateLocations .~ ts - & hcInterpretedSplices .~ splices + & hcInterpretedSplices .~ isplices & hcLoadTimeSplices .~ defaultLoadTimeSplices + & hcCompiledSplices .~ csplices & hcNamespace .~ "") --- | Render templates according to the request path. Note that if you --- have matched some parts of the path, those will not be included in --- the path used to find the templates. For example, if you have --- @foo\/bar.tpl@ in the directory where you loaded templates from, +-- | Render interpreted templates according to the request path. Note +-- that if you have matched some parts of the path, those will not be +-- included in the path used to find the templates. For example, if +-- you have @foo\/bar.tpl@ in the directory where you loaded templates +-- from, -- -- > path "foo" ==> heistServe -- @@ -95,15 +107,20 @@ -- -- > anything ==> heistServe -- +-- This will also try the path followed by "index" if the first +-- doesn't match, so if you have @foo\/index.tpl@, the path @foo@ will +-- be matched to it. +-- -- If no template is found, this will continue routing. heistServe :: (RequestContext ctxt, HeistContext ctxt) => ctxt -> IO (Maybe Response) heistServe ctxt = let p = pathInfo . fst $ getRequest ctxt in - render ctxt (T.intercalate "/" p) + mplus <$> render ctxt (T.intercalate "/" p) + <*> render ctxt (T.intercalate "/" (p ++ ["index"])) --- | Render a single template by name. +-- | Render a single interpreted heist template by name. render :: HeistContext ctxt => ctxt -> Text -> @@ -118,12 +135,32 @@ Splices (FnSplice ctxt) -> IO (Maybe Response) renderWithSplices ctxt name splices = - do r <- runReaderT (renderTemplate (bindSplices splices (getHeist ctxt)) (T.encodeUtf8 name)) ctxt + do (r,_) <- runStateT (I.renderTemplate (I.bindSplices splices (getHeist ctxt)) (T.encodeUtf8 name)) ctxt case first toLazyByteString <$> r of Nothing -> return Nothing Just (h,m) -> Just <$> W.bytestring status200 [(hContentType, m)] h +-- | Render a single compiled heist template by name. +cRender :: HeistContext ctxt => ctxt -> Text -> IO (Maybe Response) +cRender ctxt tmpl = + let mr = C.renderTemplate (getHeist ctxt) (T.encodeUtf8 tmpl) in + case mr of + Nothing -> return Nothing + Just (rc, ct) -> + do (builder, _) <- runStateT rc ctxt + return $ Just $ responseBuilder status200 [(hContentType, ct)] builder + +-- | Like 'heistServe', but for compiled templates. +cHeistServe :: (RequestContext ctxt, HeistContext ctxt) => + ctxt -> + IO (Maybe Response) +cHeistServe ctxt = + do let p = pathInfo . fst $ getRequest ctxt + mplus <$> cRender ctxt (T.intercalate "/" p) + <*> cRender ctxt (T.intercalate "/" (p ++ ["index"])) + + -- | In order to make splice definitions more functional, we declare -- them and the attributes they need, along with deserialization (if -- needed). The deserialization is facilitated be this class. @@ -166,7 +203,7 @@ (ctxt -> X.Node -> k) -> Splices (FnSplice ctxt) tag name match handle = - name ## do ctxt <- lift ask + name ## do ctxt <- lift get node <- getParamNode case match node (handle ctxt node) of Nothing -> do tellSpliceError $ @@ -180,7 +217,7 @@ (ctxt -> X.Node -> FnSplice ctxt) -> Splices (FnSplice ctxt) tag' name handle = - name ## do ctxt <- lift ask + name ## do ctxt <- lift get node <- getParamNode handle ctxt node