fn-extra 0.2.0.1 → 0.3.0.0
raw patch · 5 files changed
+160/−30 lines, 5 filesdep +digestive-functorsdep +directorydep +resourcet
Dependencies added: digestive-functors, directory, resourcet, wai-extra
Files
- CHANGELOG.md +15/−1
- README.md +1/−1
- fn-extra.cabal +7/−2
- src/Web/Fn/Extra/Digestive.hs +74/−0
- src/Web/Fn/Extra/Heist.hs +63/−26
CHANGELOG.md view
@@ -1,4 +1,18 @@-* 0.2.0.1 Daniel Patterson <dbp@dbpmail.net> 2015-1-20+* 0.3.0.0 Daniel Patterson <dbp@dbpmail.net> 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 <dbp@dbpmail.net> 2016-1-20 - Fix for GHC 7.8.4, which cabal file said would work, but didn't.
README.md view
@@ -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
fn-extra.cabal view
@@ -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 <dbp@dbpmail.net> maintainer: Daniel Patterson <dbp@dbpmail.net>-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
+ src/Web/Fn/Extra/Digestive.hs view
@@ -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
src/Web/Fn/Extra/Heist.hs view
@@ -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