module Yesod.Fay
(
YesodFay (..)
, YesodFaySettings (..)
, yesodFaySettings
, fayFileProd
, fayFileReload
, fayFileProdWithConfig
, fayFileReloadWithConfig
, FayFile
, CommandHandler
, Returns
, FaySite
, getFaySite
, Route (..)
, YesodJquery (..)
) where
import Control.Monad (unless, when)
import Control.Monad.Loops (anyM)
import Control.Applicative
import Data.Aeson (decode)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.UTF8 as BSU
import Data.Data (Data)
#if !MIN_VERSION_fay(0,20,0)
import Data.Default (def)
#endif
import Data.Digest.Pure.MD5 (md5)
import Data.List (isPrefixOf)
import Data.Maybe (isNothing)
import Data.Monoid ((<>), mempty)
import Data.Text (pack, unpack)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Text.Lazy.Builder (fromText, toLazyText, Builder)
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath (takeDirectory)
import Fay (getRuntime, showCompileError)
import Fay.Convert (showToFay)
#if MIN_VERSION_fay(0,20,0)
import Fay (Config(..),
addConfigDirectoryIncludePaths,
addConfigPackages,
compileFileWithResult,
configDirectoryIncludes,
configTypecheck,
configExportRuntime,
configPrettyPrint,
defaultConfig,
CompileError,
CompileResult (..))
#else
import Fay (CompileState(..), compileFileWithState)
import Fay.Compiler.Config (addConfigDirectoryIncludePaths,
addConfigPackages)
import Fay.Types (CompileConfig(..),
configDirectoryIncludes,
configTypecheck,
configExportRuntime,
configPrettyPrint,
CompileError)
#endif
import Fay.Yesod (Returns (Returns))
import Language.Haskell.TH.Syntax (Exp (LitE, AppE, VarE), Lit (StringL, StringPrimL, IntegerL), Name,
Q,
qAddDependentFile, qRunIO)
import Data.Text.Encoding (decodeUtf8)
import Data.ByteString.Unsafe (unsafePackAddressLen)
import Control.Exception (IOException,catch)
import Prelude hiding (catch)
import System.Directory
import System.Environment (getEnvironment)
import Text.Julius (Javascript (Javascript), julius)
import Yesod.Core
import Yesod.Fay.Data
import Yesod.Form.Jquery (YesodJquery (..))
import Yesod.Static
class YesodJquery master => YesodFay master where
yesodFayCommand :: CommandHandler master
fayRoute :: Route FaySite -> Route master
fayEncode :: (Data a) => master -> a -> Maybe Value
fayEncode = const showToFay
type CommandHandler master
= forall s.
(forall a. (Data a) => Returns a -> a -> HandlerT master IO s)
-> Value
-> HandlerT master IO s
data YesodFaySettings = YesodFaySettings
{ yfsModuleName :: String
, yfsSeparateRuntime :: Maybe (FilePath, Exp)
, yfsPostProcess :: String -> IO String
, yfsExternal :: Maybe (FilePath, Exp)
, yfsRequireJQuery :: Bool
, yfsPackages :: [String]
, yfsTypecheckDevel :: Bool
}
yesodFaySettings :: String -> YesodFaySettings
yesodFaySettings moduleName = YesodFaySettings
{ yfsModuleName = moduleName
, yfsSeparateRuntime = Nothing
, yfsPostProcess = return
, yfsExternal = Nothing
, yfsRequireJQuery = True
, yfsPackages = ["fay-base"]
, yfsTypecheckDevel = False
}
updateRuntime :: FilePath -> IO ()
updateRuntime fp = getRuntime >>= \js -> createDirectoryIfMissing True (takeDirectory fp) >> copyFile js fp
instance YesodFay master => YesodSubDispatch FaySite (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesFaySite)
getFaySite :: a -> FaySite
getFaySite _ = FaySite
postFayCommandR :: forall master. YesodFay master => HandlerT FaySite (HandlerT master IO) Value
postFayCommandR =
lift $ runCommandHandler yesodFayCommand
where
runCommandHandler :: YesodFay master
=> CommandHandler master
-> HandlerT master IO Value
runCommandHandler f = do
mtxt <- lookupPostParam "json"
case mtxt of
Nothing -> invalidArgs ["No JSON provided"]
Just txt ->
case decode (L.fromChunks [encodeUtf8 txt]) of
Nothing -> error $ "Unable to parse input: " ++ show txt
Just cmd -> f go cmd
where
go Returns value = do
master <- getYesod
returnJson $ fayEncode master value
langYesodFay :: String
langYesodFay = $(qRunIO $ fmap (LitE . StringL . unpack) $ T.readFile "Fay/Yesod.hs")
writeYesodFay :: IO ()
writeYesodFay = do
let fp = "fay/Fay/Yesod.hs"
content = "-- NOTE: This file is auto-generated.\n" ++ langYesodFay
exists <- doesFileExist fp
mcurrent <-
if exists
then fmap (Just . unpack) $ T.readFile fp
else return Nothing
unless (mcurrent == Just content) $ do
createDirectoryIfMissing True $ takeDirectory fp
writeFile fp content
maybeRequireJQuery :: YesodFay master => Bool -> WidgetT master IO ()
maybeRequireJQuery needJQuery = when needJQuery requireJQuery
requireJQuery :: YesodFay master => WidgetT master IO ()
requireJQuery = do
master <- getYesod
addScriptEither $ urlJqueryJs master
render <- getUrlRender
toWidgetHead [julius|window.yesodFayCommandPath = #{toJSON $ render $ fayRoute FayCommandR};|]
mkfp :: String -> FilePath
mkfp name = "fay/" ++ name ++ ".hs"
requireFayRuntime :: YesodFaySettings -> Q Exp
requireFayRuntime settings = do
maybe (return ())
(\(path,_) -> qRunIO $ updateRuntime (path ++ "/fay-runtime.js"))
(yfsSeparateRuntime settings)
case yfsSeparateRuntime settings of
Nothing -> [| return () |]
Just (_, exp') -> do
hash <- qRunIO $ getRuntime >>= fmap base64md5 . L.readFile
[| addScript ($(return exp') (StaticRoute ["fay-runtime.js"] [(T.pack hash, "")])) |]
type FayFile = String -> Q Exp
compileFayFile :: FilePath
-> Config
-> IO (Either CompileError ([FilePath],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 <- compile conf {configPackageConf = packageConf}
fp
case result of
Left e -> return (Left e)
Right (sourceAndFiles -> (source',files)) -> do
let fps = filter ours files
source | configExportRuntime conf = "\n(function(){\n" ++ source' ++ "\n})();\n"
| otherwise = source'
(fp_hi,fp_o) = refreshTo
writeFile fp_hi (unlines fps)
writeFile fp_o source
return (Right (fps,source))
where ours x = isPrefixOf "fay/" x || isPrefixOf "fay-shared/" x
getFileCache :: FilePath -> IO (Either (FilePath,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
catch (do thisModTime <- getModificationTime fp_o
modules <- fmap ((fp :) . lines . T.unpack) (T.readFile fp_hi)
changed <- anyM (fmap (> thisModTime) . getModificationTime) modules
if changed
then refresh
else fmap (Right . (modules,) . T.unpack) (T.readFile fp_o))
(\(_ :: IOException) -> refresh)
fayFileProd :: YesodFaySettings -> Q Exp
fayFileProd = fayFileProdWithConfig id
fayFileProdWithConfig :: (Config -> Config) -> YesodFaySettings -> Q Exp
fayFileProdWithConfig modifier settings = do
let needJQuery = yfsRequireJQuery settings
qAddDependentFile fp
qRunIO writeYesodFay
eres <- qRunIO $ compileFayFile fp
$ modifier
$ addConfigPackages packages
$ config { configExportRuntime = exportRuntime }
case eres of
Left e -> throwFayError name e
Right (modules,s) -> do
mapM_ qAddDependentFile modules
s' <- qRunIO $ yfsPostProcess settings s
let contents = fromText (pack s')
case yfsExternal settings of
Nothing ->
[| do
maybeRequireJQuery needJQuery
$(requireFayRuntime settings)
toWidget $ const $ Javascript $ s'
|]
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'
[| do
maybeRequireJQuery needJQuery
$(requireFayRuntime settings)
addScript $ $(return exp') $ StaticRoute [pack name'] []
|]
where
name = yfsModuleName settings
exportRuntime = isNothing (yfsSeparateRuntime settings)
packages = yfsPackages settings
fp = mkfp name
stringPrimL :: TL.Text -> Lit
#if __GLASGOW_HASKELL__ <= 704
stringPrimL = StringPrimL . TL.unpack
#else
stringPrimL = StringPrimL . L.unpack . TLE.encodeUtf8
#endif
config :: Config
config = addConfigDirectoryIncludePaths ["fay", "fay-shared"]
#if MIN_VERSION_fay(0,20,0)
defaultConfig
#else
def
#endif
fayFileReload :: YesodFaySettings -> Q Exp
fayFileReload = fayFileReloadWithConfig 'id
fayFileReloadWithConfig :: Name -> YesodFaySettings -> Q Exp
fayFileReloadWithConfig modifier settings = do
let needJQuery = yfsRequireJQuery settings
qRunIO writeYesodFay
[|
liftIO (compileFayFile (mkfp name)
$ $(return $ VarE modifier)
$ addConfigPackages packages
$ config
{ configTypecheck = typecheckDevel
, configExportRuntime = exportRuntime
#if MIN_VERSION_fay(0, 19, 0)
, configSourceMap = True
#endif
, configPrettyPrint = True
})
>>= \eres -> do
(case eres of
Left e -> throwFayError name e
Right (_,s) -> do
maybeRequireJQuery needJQuery
$(requireFayRuntime settings)
toWidget (const $ Javascript $ fromText (pack s)))|]
where
name = yfsModuleName settings
exportRuntime = isNothing (yfsSeparateRuntime settings)
packages = yfsPackages settings
typecheckDevel = yfsTypecheckDevel settings
throwFayError :: String -> CompileError -> error
throwFayError name e =
error $ "Unable to compile Fay module \"" ++ name ++ "\":\n\n" ++ showCompileError e
#if !MIN_VERSION_fay(0,20,0)
type Config = CompileConfig
#endif
#if MIN_VERSION_fay(0,20,0)
compile = compileFileWithResult
#else
compile = compileFileWithState
#endif
#if MIN_VERSION_fay(0,20,0)
sourceAndFiles res = (resOutput res,map snd (resImported res))
#else
#if MIN_VERSION_fay(0,18,0)
sourceAndFiles (source,_,state) = (source,map snd (stateImported state))
#else
sourceAndFiles (source,state) = (source,map snd (stateImported state))
#endif
#endif