diff --git a/Yesod/Fay.hs b/Yesod/Fay.hs --- a/Yesod/Fay.hs +++ b/Yesod/Fay.hs @@ -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) diff --git a/Yesod/Fay/Data.hs b/Yesod/Fay/Data.hs new file mode 100644 --- /dev/null +++ b/Yesod/Fay/Data.hs @@ -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 +|] diff --git a/yesod-fay.cabal b/yesod-fay.cabal --- a/yesod-fay.cabal +++ b/yesod-fay.cabal @@ -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 . 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