module Snap.Elm where
import Control.Monad
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import Data.Monoid
import qualified Data.Text as T
import Snap.Core
import Snap.Util.FileServe
import qualified Language.Elm as Elm
import GHC.IO.Handle
import System.Directory
import System.Exit
import System.FilePath
import System.Process
data ElmOptions = ElmOptions
{ elmIsVerbose :: Bool
, elmRuntimeURI :: ByteString
, elmRuntimePath :: FilePath
, elmSourcePath :: FilePath
, elmBuildPath :: FilePath
, elmCachePath :: FilePath
}
defaultElmOptions :: MonadIO m => m ElmOptions
defaultElmOptions = do
let v = False
let uri = "/static/js/elm-runtime.js"
rt <- liftIO Elm.runtime
let s = "."
let b = "elm-build"
let c = "elm-cache"
return $ ElmOptions v uri rt s b c
setElmVerbose :: Bool -> ElmOptions -> ElmOptions
setElmVerbose v opts = opts { elmIsVerbose = v }
setElmRuntimeURI :: ByteString -> ElmOptions -> ElmOptions
setElmRuntimeURI uri opts = opts { elmRuntimeURI = uri }
setElmRuntimePath :: FilePath -> ElmOptions -> ElmOptions
setElmRuntimePath rt opts = opts { elmRuntimePath = rt }
setElmSourcePath :: FilePath -> ElmOptions -> ElmOptions
setElmSourcePath src opts = opts { elmSourcePath = src }
setElmBuildPath :: FilePath -> ElmOptions -> ElmOptions
setElmBuildPath bld opts = opts { elmBuildPath = bld }
setElmCachePath :: FilePath -> ElmOptions -> ElmOptions
setElmCachePath cch opts = opts { elmCachePath = cch }
serveElm :: MonadSnap m => ElmOptions -> FilePath -> m ()
serveElm opts fp = when (takeExtension fp == ".elm") $ do
cd <- liftIO getCurrentDirectory
let runtimeURI = C8.unpack (elmRuntimeURI opts)
let sourcePath = makeAbsolutePath (elmSourcePath opts) cd
let buildPath = makeAbsolutePath (elmBuildPath opts) cd
let cachePath = makeAbsolutePath (elmCachePath opts) cd
let args = [ "--make"
, "--runtime=" ++ runtimeURI
, "--build-dir=" ++ buildPath
, "--cache-dir=" ++ cachePath
, fp
]
ifVerbose $ liftIO $ do
putStrLn "Elm:"
putStrLn $ " $ cd " ++ elmSourcePath opts
putStrLn $ unwords $ " $ elm" : args
(_,hOut,hErr,pid) <- liftIO $ runInteractiveProcess "elm" args
(Just sourcePath)
Nothing
out <- liftIO $ hGetContents hOut
err <- liftIO $ hGetContents hErr
ec <- liftIO $ waitForProcess pid
ifVerbose $ liftIO $ putStrLn $ indent out
case ec of
ExitFailure _ -> writeText $ T.unlines
[ "Failed to build Elm file (" <> T.pack fp <> "):"
, " " <> T.pack err
]
ExitSuccess -> serveFile $ buildPath </> replaceExtension fp "html"
where
ifVerbose = when $ elmIsVerbose opts
indent = unlines . map (" " ++) . lines
makeAbsolutePath :: FilePath -> FilePath -> FilePath
makeAbsolutePath p cd = case p of
"" -> cd
"." -> cd
'/':_ -> p
_ -> cd </> p
serveElmDirectory :: MonadSnap m
=> ElmOptions
-> ByteString
-> m ()
serveElmDirectory opts pm = do
mf <- getParam pm
whenJust mf (serveElm opts . C8.unpack)
where
whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust m f = maybe (return ()) f m
serveElmDirectory' :: MonadSnap m
=> ElmOptions
-> ByteString
-> (ByteString, m ())
serveElmDirectory' opts d = (uri,handler)
where
param = "file"
uri
| C8.null d = "/:" <> param
| C8.last d == '/' = d <> ":" <> param
| otherwise = d <> "/:" <> param
handler = do
mf <- getParam param
whenJust mf (serveElm opts . C8.unpack)
whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust m f = maybe (return ()) f m
serveElmRuntime :: MonadSnap m => ElmOptions -> (ByteString, m ())
serveElmRuntime opts =
( elmRuntimeURI opts
, serveFile $ elmRuntimePath opts
)