module Yesod.Fay
(
YesodFay (..)
, YesodFaySettings (..)
, yesodFaySettings
, fayFileProd
, fayFileReload
, 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.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)
import qualified Data.Text 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 Filesystem (createTree, isFile, readTextFile)
import Filesystem.Path.CurrentOS (directory, encodeString, decodeString)
import Fay (compileFileWithState, CompileState(..), getRuntime)
import Fay.Convert (showToFay)
import Fay.Types (CompileConfig(..),
configDirectoryIncludes,
configTypecheck,
configExportRuntime,
configNaked, CompileError)
import Language.Fay.Yesod (Returns (Returns))
import Language.Haskell.TH.Syntax (Exp (LitE), Lit (StringL),
Q,
qAddDependentFile, qRunIO)
import System.Environment (getEnvironment)
import System.Directory
import Text.Julius (Javascript (Javascript), julius)
import Yesod.Core
import Yesod.Form.Jquery (YesodJquery (..))
import Yesod.Static
import Yesod.Fay.Data
jsMainCall :: Bool -> String -> Builder
jsMainCall False _ = mempty
jsMainCall True mn' =
"Fay$$_(" <> mn <> "$main);"
where
mn = fromText $ T.pack mn'
class YesodJquery master => YesodFay master where
yesodFayCommand :: CommandHandler master
fayRoute :: Route FaySite -> Route master
type CommandHandler master
= forall s.
(forall a. Show 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
}
yesodFaySettings :: String -> YesodFaySettings
yesodFaySettings moduleName = YesodFaySettings moduleName Nothing return Nothing True
updateRuntime :: FilePath -> IO ()
updateRuntime fp = getRuntime >>= \js -> createTree (directory $ decodeString fp) >> copyFile js fp
instance YesodFay master => YesodSubDispatch FaySite (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesFaySite)
getFaySite :: a -> FaySite
getFaySite _ = FaySite
postFayCommandR :: 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 = jsonToRepJson . showToFay
langYesodFay :: String
langYesodFay = $(qRunIO $ fmap (LitE . StringL . unpack) $ readTextFile "Language/Fay/Yesod.hs")
writeYesodFay :: IO ()
writeYesodFay = do
let fp = "fay/Language/Fay/Yesod.hs"
content = "-- NOTE: This file is auto-generated.\n" ++ langYesodFay
exists <- isFile fp
mcurrent <-
if exists
then fmap (Just . unpack) $ readTextFile fp
else return Nothing
unless (mcurrent == Just content) $ do
createTree $ directory fp
writeFile (encodeString 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
-> 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
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)
fayFileProd :: YesodFaySettings -> Q Exp
fayFileProd settings = do
let needJQuery = yfsRequireJQuery settings
qAddDependentFile fp
qRunIO writeYesodFay
eres <- qRunIO $ compileFayFile fp config
{ configExportRuntime = exportRuntime
, configNaked = not exportRuntime
}
case eres of
Left e -> error $ "Unable to compile Fay module \"" ++ name ++ "\": " ++ show e
Right s -> do
s' <- qRunIO $ yfsPostProcess settings s
let contents = fromText (pack s') <> jsMainCall (not exportRuntime) name
external <-
case yfsExternal settings of
Nothing -> return [|Nothing|]
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') |]
[| do
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'] []
|]
where
name = yfsModuleName settings
exportRuntime = isNothing (yfsSeparateRuntime settings)
fp = mkfp name
config :: CompileConfig
config = def {
configDirectoryIncludes
= (Nothing, "fay")
: (Nothing, "fay-shared")
: configDirectoryIncludes def
}
fayFileReload :: YesodFaySettings -> Q Exp
fayFileReload settings = do
let needJQuery = yfsRequireJQuery settings
qRunIO writeYesodFay
[|
liftIO (compileFayFile (mkfp name) config
{ configTypecheck = False
, configExportRuntime = exportRuntime
, configNaked = not exportRuntime
})
>>= \eres -> do
(case eres of
Left e -> error $ "Unable to compile Fay module \"" ++ name ++ "\": " ++ show e
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)