{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
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.Char8 as LC
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, isInfixOf)
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 (readConfigRuntime, defaultConfig, 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 (lookupEnv)
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 -> HandlerFor master s)
-> Value
-> HandlerFor master 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
}
getRuntime :: IO L.ByteString
getRuntime = readConfigRuntime config >>= return . LC.pack
updateRuntime :: FilePath -> IO ()
updateRuntime fp = getRuntime >>= \js ->
createDirectoryIfMissing True (takeDirectory fp) >> L.writeFile fp js
instance YesodFay master => YesodSubDispatch FaySite master where
yesodSubDispatch = $(mkYesodSubDispatch resourcesFaySite)
getFaySite :: a -> FaySite
getFaySite _ = FaySite
postFayCommandR :: forall master. YesodFay master => SubHandlerFor FaySite master Value
postFayCommandR =
liftHandler $ runCommandHandler yesodFayCommand
where
runCommandHandler :: YesodFay master
=> CommandHandler master
-> HandlerFor master 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 -> WidgetFor master ()
maybeRequireJQuery needJQuery = when needJQuery requireJQuery
requireJQuery :: YesodFay master => WidgetFor master ()
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 >>= return . base64md5
[| 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
sandboxPackageConf <- lookupEnv "HASKELL_PACKAGE_SANDBOX"
let packageConf = case sandboxPackageConf of
Nothing -> Nothing
Just sandbox -> if isInfixOf ".stack" sandbox
then Nothing
else sandboxPackageConf
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
-- | Throw a fay error.
throwFayError :: String -> CompileError -> error
throwFayError name e =
error $ "Unable to compile Fay module \"" ++ name ++ "\":\n\n" ++ showCompileError e
-- Fay cross-version compatible functions
#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