yesod-fay 0.3.0 → 0.4.0
raw patch · 3 files changed
+128/−71 lines, 3 filesdep +monad-loopsdep +pureMD5dep +utf8-stringdep −yesod-jsondep ~yesod-coredep ~yesod-formdep ~yesod-static
Dependencies added: monad-loops, pureMD5, utf8-string
Dependencies removed: yesod-json
Dependency ranges changed: yesod-core, yesod-form, yesod-static
Files
- Yesod/Fay.hs +109/−66
- Yesod/Fay/Data.hs +11/−0
- yesod-fay.cabal +8/−5
Yesod/Fay.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Utility functions for using Fay from a Yesod application. -- -- This module is intended to be used from your Yesod application, not from@@ -69,18 +70,20 @@ -- * Subsite , FaySite , getFaySite+ , Route (..) -- * Reexports , YesodJquery (..) ) where -import Control.Applicative ((<$>)) import Control.Monad (unless, when)-import Control.Monad.IO.Class (liftIO)-import Data.Aeson (decode, toJSON, Value)-import Data.Aeson.Encode (fromValue)+import Control.Monad.Loops (anyM)+import Control.Applicative+import Data.Aeson (decode) import qualified Data.ByteString.Lazy as L-import Data.Data (Data)+import qualified Data.ByteString.Lazy.UTF8 as BSU import Data.Default (def)+import Data.Digest.Pure.MD5 (md5)+import Data.List (isPrefixOf) import Data.Maybe (isNothing) import Data.Monoid ((<>), mempty) import Data.Text (pack, unpack)@@ -90,33 +93,25 @@ import qualified Data.Text.Lazy.Encoding as TLE import Data.Text.Lazy.Builder (fromText, toLazyText, Builder) import Filesystem (createTree, isFile, readTextFile)-import Filesystem.Path.CurrentOS (directory, encodeString, (</>), decodeString)-import Fay (compileFile, getRuntime)-import Fay.Convert (readFromFay, showToFay)-import Fay.Types (CompileConfig,+import Filesystem.Path.CurrentOS (directory, encodeString, decodeString)+import Fay (compileFileWithState, CompileState(..), getRuntime)+import Fay.Convert (showToFay)+import Fay.Types (CompileConfig(..), configDirectoryIncludes, configTypecheck, configExportRuntime,- configNaked)+ configNaked, CompileError) import Language.Fay.Yesod (Returns (Returns)) import Language.Haskell.TH.Syntax (Exp (LitE), Lit (StringL),- Pred (ClassP), Q, Type (VarT),- mkName, qAddDependentFile, qRunIO)-import System.Directory (copyFile)-import System.Exit (ExitCode (ExitSuccess))-import System.Process (rawSystem)+ Q,+ qAddDependentFile, qRunIO)+import System.Environment (getEnvironment)+import System.Directory import Text.Julius (Javascript (Javascript), julius)-import Yesod.Core (GHandler, GWidget,- RenderRoute (..), RepJson, Yesod,- YesodDispatch (..), addScript,- addScriptEither, getUrlRender,- getYesod, lift, lookupPostParam,- mkYesodSub, parseRoutes,- toMasterHandler, toWidget, toWidgetHead)+import Yesod.Core import Yesod.Form.Jquery (YesodJquery (..))-import Yesod.Handler (invalidArgs)-import Yesod.Json (jsonToRepJson) import Yesod.Static+import Yesod.Fay.Data jsMainCall :: Bool -> String -> Builder jsMainCall False _ = mempty@@ -138,7 +133,7 @@ -- > yesodFayCommand render command = -- > case command of -- > GetFib index r = render r $ fibs !! index- yesodFayCommand :: CommandHandler master master+ yesodFayCommand :: CommandHandler master -- | Where in the routing tree our Fay subsite is located. This is -- generally named @FaySiteR@, e.g.:@@ -163,11 +158,11 @@ -- The first argument to your function is the \"respond\" function: it takes -- the extra @Returns@ parameter as well as the actual value to be returned, -- and produces the expected result.-type CommandHandler sub master+type CommandHandler master = forall s.- (forall a. Show a => Returns a -> a -> GHandler sub master s)+ (forall a. Show a => Returns a -> a -> HandlerT master IO s) -> Value- -> GHandler sub master s+ -> HandlerT master IO s -- | A setttings data type for indicating whether the generated Javascript -- should contain a copy of the Fay runtime or not.@@ -176,40 +171,33 @@ , yfsSeparateRuntime :: Maybe (FilePath, Exp) , yfsPostProcess :: String -> IO String , yfsExternal :: Maybe (FilePath, Exp)+ , yfsRequireJQuery :: Bool+ -- ^ Note that the server call functions provided for your Fay code require+ -- jQuery to be present. If you disable this option and still use the+ -- provided server call functions, your code will break. } yesodFaySettings :: String -> YesodFaySettings-yesodFaySettings moduleName = YesodFaySettings moduleName Nothing return Nothing+yesodFaySettings moduleName = YesodFaySettings moduleName Nothing return Nothing True updateRuntime :: FilePath -> IO () updateRuntime fp = getRuntime >>= \js -> createTree (directory $ decodeString fp) >> copyFile js fp --- | The Fay subsite.-data FaySite = FaySite--mkYesodSub "FaySite"- [ ClassP ''YesodFay [VarT $ mkName "master"]- ] [parseRoutes|-/ FayCommandR POST-|]+instance YesodFay master => YesodSubDispatch FaySite (HandlerT master IO) where+ yesodSubDispatch = $(mkYesodSubDispatch resourcesFaySite) -- | To be used from your routing declarations. getFaySite :: a -> FaySite getFaySite _ = FaySite -postFayCommandR :: YesodFay master => GHandler FaySite master RepJson+postFayCommandR :: YesodFay master => HandlerT FaySite (HandlerT master IO) Value postFayCommandR =- toSub $ runCommandHandler yesodFayCommand+ lift $ runCommandHandler yesodFayCommand where- toSub :: YesodFay master => GHandler master master a -> GHandler FaySite master a- toSub mhandler = do- m <- getYesod- toMasterHandler id (const m) (fayRoute FayCommandR) mhandler- -- | Run a command handler. This provides server-side responses to Fay queries. runCommandHandler :: YesodFay master- => CommandHandler sub master- -> GHandler sub master RepJson+ => CommandHandler master+ -> HandlerT master IO Value runCommandHandler f = do mtxt <- lookupPostParam "json" case mtxt of@@ -237,11 +225,14 @@ createTree $ directory fp writeFile (encodeString fp) content -requireJQuery :: YesodFay master => GWidget sub master ()+maybeRequireJQuery :: YesodFay master => Bool -> WidgetT master IO ()+maybeRequireJQuery needJQuery = when needJQuery requireJQuery++requireJQuery :: YesodFay master => WidgetT master IO () requireJQuery = do- master <- lift getYesod+ master <- getYesod addScriptEither $ urlJqueryJs master- render <- lift getUrlRender+ render <- getUrlRender -- FIXME get rid of toLazyText call below toWidgetHead [julius|window.yesodFayCommandPath = #{toJSON $ render $ fayRoute FayCommandR};|] @@ -255,25 +246,74 @@ (yfsSeparateRuntime settings) case yfsSeparateRuntime settings of Nothing -> [| return () |]- Just (_,exp) -> do+ Just (_, exp') -> do hash <- qRunIO $ getRuntime >>= fmap base64md5 . L.readFile- [| addScript ($(return exp) (StaticRoute ["fay-runtime.js"] [(T.pack hash, "")])) |]+ [| addScript ($(return exp') (StaticRoute ["fay-runtime.js"] [(T.pack hash, "")])) |] -- | A function that takes a String giving the Fay module name, and returns an -- TH splice that generates a @Widget@. type FayFile = String -> Q Exp +compileFayFile :: FilePath+ -> CompileConfig+ -> IO (Either CompileError String)+compileFayFile fp conf = do+ result <- getFileCache fp+ case result of+ Right cache -> return (Right cache)+ Left refreshTo -> do+ packageConf <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+ result <- compileFileWithState conf {+ configPackageConf = packageConf+ } fp+ case result of+ Left e -> return (Left e)+ Right (source,state) -> do+ let files = stateImported state+ (fp_hi,fp_o) = refreshTo+ writeFile fp_hi (unlines (filter ours (map snd files)))+ writeFile fp_o source+ return (Right source)++ where ours x = isPrefixOf "fay/" x || isPrefixOf "fay-shared/" x++-- | Return the cached output file of the given source file, if:+--+-- 1. The source file hasn't changed.+-- 2. Any of the source file's dependencies haven't changed.+--+-- Otherwise, return filepaths needed to store meta data and the new cache.+--+getFileCache :: FilePath -> IO (Either (FilePath,FilePath) String)+getFileCache fp = do+ let dir = "dist/yesod-fay-cache/"+ guid = show (md5 (BSU.fromString fp))+ fp_hi = dir ++ guid ++ ".hi"+ fp_o = dir ++ guid ++ ".o"+ refresh = return $ Left (fp_hi,fp_o)+ createDirectoryIfMissing True dir+ exists <- doesFileExist fp_hi+ if not exists+ then refresh+ else do thisModTime <- getModificationTime fp_o+ modules <- fmap ((fp :) . lines) (readFile fp_hi)+ changed <- anyM (fmap (> thisModTime) . getModificationTime) modules+ if changed+ then refresh+ else fmap Right (readFile fp_o)+ -- | Does a full compile of the Fay code via GHC for type checking, and then -- embeds the Fay-generated Javascript as a static string. File changes during -- runtime will not be reflected. fayFileProd :: YesodFaySettings -> Q Exp fayFileProd settings = do+ let needJQuery = yfsRequireJQuery settings qAddDependentFile fp qRunIO writeYesodFay- eres <- qRunIO $ compileFile config+ eres <- qRunIO $ compileFayFile fp config { configExportRuntime = exportRuntime , configNaked = not exportRuntime- } fp+ } case eres of Left e -> error $ "Unable to compile Fay module \"" ++ name ++ "\": " ++ show e Right s -> do@@ -282,20 +322,20 @@ external <- case yfsExternal settings of Nothing -> return [|Nothing|]- Just (fp, exp) -> do- let name = concat ["faygen-", hash, ".js"]+ Just (fp', exp') -> do+ let name' = concat ["faygen-", hash, ".js"] hash = base64md5 contents' contents' = TLE.encodeUtf8 $ toLazyText contents- qRunIO $ L.writeFile (concat [fp, "/", name]) contents'- return [| Just ($(return exp), name) |]+ qRunIO $ L.writeFile (concat [fp', "/", name']) contents'+ return [| Just ($(return exp'), name') |] [| do- requireJQuery+ maybeRequireJQuery needJQuery $(requireFayRuntime settings) case $external of Nothing -> toWidget $ const $ Javascript $ fromText $ pack $(return $ LitE $ StringL $ TL.unpack $ toLazyText contents)- Just (constructor, name) -> addScript $ constructor $ StaticRoute [name] []+ Just (constructor, name') -> addScript $ constructor $ StaticRoute [name'] [] |] where name = yfsModuleName settings@@ -303,8 +343,8 @@ fp = mkfp name config :: CompileConfig-config = def- { configDirectoryIncludes+config = def {+ configDirectoryIncludes = (Nothing, "fay") : (Nothing, "fay-shared") : configDirectoryIncludes def@@ -314,18 +354,21 @@ -- requested, the Fay code will be compiled from scratch to Javascript. fayFileReload :: YesodFaySettings -> Q Exp fayFileReload settings = do+ let needJQuery = yfsRequireJQuery settings qRunIO writeYesodFay [|- liftIO (compileFile config+ liftIO (compileFayFile (mkfp name) config { configTypecheck = False , configExportRuntime = exportRuntime , configNaked = not exportRuntime- }- $ mkfp name) >>= \eres -> do+ })+ >>= \eres -> do (case eres of Left e -> error $ "Unable to compile Fay module \"" ++ name ++ "\": " ++ show e- Right s -> requireJQuery >> $(requireFayRuntime settings)- >> toWidget (const $ Javascript $ fromText (pack s) <> jsMainCall (not exportRuntime) name))|]+ Right s -> do+ maybeRequireJQuery needJQuery+ $(requireFayRuntime settings)+ toWidget (const $ Javascript $ fromText (pack s) <> jsMainCall (not exportRuntime) name))|] where name = yfsModuleName settings exportRuntime = isNothing (yfsSeparateRuntime settings)
+ Yesod/Fay/Data.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}+module Yesod.Fay.Data where++import Yesod.Core++-- | The Fay subsite.+data FaySite = FaySite++mkYesodSubData "FaySite" [parseRoutes|+/ FayCommandR POST+|]
yesod-fay.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: yesod-fay-version: 0.3.0+version: 0.4.0 synopsis: Utilities for using the Fay Haskell-to-JS compiler with Yesod. description: For initial discussion, see <http://www.yesodweb.com/blog/2012/10/yesod-fay-js>. This is a work-in-progress. homepage: https://github.com/snoyberg/yesod-fay@@ -17,6 +17,7 @@ library exposed-modules: Yesod.Fay Language.Fay.Yesod+ other-modules: Yesod.Fay.Data build-depends: base >= 4 && < 5 , fay >= 0.14 , transformers >= 0.2@@ -30,7 +31,9 @@ , template-haskell , process , shakespeare-js >= 1.0.2- , yesod-core >= 1.1- , yesod-form >= 1.1- , yesod-json >= 1.1- , yesod-static >= 1.1.1.2+ , yesod-core >= 1.2+ , yesod-form >= 1.2+ , yesod-static >= 1.2+ , pureMD5 >= 2.1.2.1+ , utf8-string >= 0.3.7+ , monad-loops >= 0.3.3.0