module Snap.Snaplet.GHCJS (
GHCJS,
snapletArgs,
initialize,
ghcjsServe,
) where
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State.Class as State
import Control.Lens (makeLenses)
import Data.List
import Data.String.Conversions
import Snap.Core
import Snap.Snaplet
import Snap.Util.FileServe
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.Process
import Text.Printf
data GHCJS = GHCJS { _ghcjsc :: FilePath
, _snapletArgs :: [String]
}
makeLenses ''GHCJS
initialize :: [String] -> SnapletInit app GHCJS
initialize args = makeSnaplet "ghcjs" description Nothing $ do
cabalPackageDBs <- liftIO parseCabalPackageDBs
let packageArgs = cabalPackageDBs >>= (\a -> ["-package-db", a])
liftIO $ mapM_ putStrLn packageArgs
return $ GHCJS "ghcjs" (packageArgs ++ args)
where
description = "handler for delivering javascript files compiled with ghcjs"
parseCabalPackageDBs :: IO [String]
parseCabalPackageDBs = do
let isPath s = take 2 s /= (" "::String) && take 1 s == ("/" :: String)
dir <- getCurrentDirectory
writeFile "cabal.snaplet-ghcjs.config" $
unlines [ "-- Automatically generated by snaplet-ghcjs to help determine location of package db, working around https://github.com/haskell/cabal/pull/2859"
, "compiler: ghcjs"
, "-- Thankyou."
, ""]
(_stdin, Just stdoutH, Just stderrH, processHandle) <-
createProcess (proc "cabal" ["--config-file=cabal.snaplet-ghcjs.config", "exec", "ghcjs-pkg", "list"]){
cwd = Just dir,
std_out = CreatePipe,
std_err = CreatePipe
}
exitCode <- waitForProcess processHandle
stdout <- hGetContents stdoutH
stderr <- hGetContents stderrH
case exitCode of
ExitSuccess -> return $ map init $ filter isPath $ lines stdout
ExitFailure _ -> do
putStrLn "snaplet-ghcjs WARNING: dirty hack failed. Please set -package-db yourself."
return []
ghcjsServe :: Handler app GHCJS ()
ghcjsServe = do
jsPath <- cs <$> rqPathInfo <$> getRequest
ghcjsDir <- getSnapletFilePath
if takeExtension jsPath /= ".js" then
mzero
else
deliverJS (dropExtension (ghcjsDir </> jsPath))
deliverJS :: FilePath -> Handler app GHCJS ()
deliverJS basename = do
hsExists <- liftIO $ doesFileExist (basename <.> "hs")
unless hsExists mzero
let jsFile = jsFileName basename
snapletDir <- getSnapletFilePath
jsNewer <- liftIO $ isJSNewer jsFile snapletDir
if jsNewer then
serveFile jsFile
else
compile basename
isJSNewer :: FilePath -> FilePath -> IO Bool
isJSNewer jsFile dir = do
exists <- liftIO $ doesFileExist jsFile
if not exists then
return False
else do
hsFiles <- collectAllHsFiles dir
hsTimeStamps <- mapM getModificationTime hsFiles
jsTimeStamp <- getModificationTime jsFile
return (jsTimeStamp > maximum hsTimeStamps)
where
collectAllHsFiles :: FilePath -> IO [FilePath]
collectAllHsFiles dir = do
paths <- fmap (dir </>) <$>
filter (not . ("." `isPrefixOf`)) <$>
getDirectoryContents dir
(files, dirs) <- partitionM doesFileExist paths
let hsFiles = filter (\ f -> takeExtension f == ".hs") files
subHsFiles <- concat <$> mapM collectAllHsFiles dirs
return (hsFiles ++ subHsFiles)
partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM pred (a : r) = do
is <- pred a
(yes, no) <- partitionM pred r
return $ if is then (a : yes, no) else (yes, a : no)
partitionM pred [] = return ([], [])
compile :: FilePath -> Handler app GHCJS ()
compile name = do
GHCJS
ghcjsc
snapletArgs <- State.get
let args = snapletArgs ++ [name <.> "hs"]
outfile = jsFileName name
dir <- getSnapletFilePath
(exitCode, message) <- liftIO $ do
(_stdin, Just stdoutH, Just stderrH, processHandle) <-
createProcess (proc ghcjsc args){
cwd = Just dir,
std_out = CreatePipe,
std_err = CreatePipe
}
exitCode <- waitForProcess processHandle
stdout <- hGetContents stdoutH
stderr <- hGetContents stderrH
return (exitCode, "\nGHCJS error:\n============\n" ++ stdout ++ stderr)
case exitCode of
ExitFailure _ ->
writeBS $ cs (printf ("/*\n\n%s\n\n*/\n\nthrow %s;") message (show message) :: String)
ExitSuccess -> serveFile outfile
jsFileName :: String -> FilePath
jsFileName name = name <.> "jsexe" </> "all.js"