module System.Elm.Middleware (
requireElm,
elmSite,
elmSiteDebug,
PathInfo,
) where
import Control.Exception.Safe (tryAny)
import Control.Monad (void)
import Data.Bool (bool)
import Data.Map (Map)
import Data.Monoid ((<>))
import Data.String (IsString, fromString)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Distribution.Simple (hookedPrograms, simpleUserHooks, preConf,
UserHooks)
import Distribution.Simple.Program (simpleProgram, Program,
configureAllKnownPrograms, requireProgram, defaultProgramDb)
import Distribution.Simple.Setup (fromFlagOrDefault, configVerbosity)
import Distribution.Verbosity (normal)
import Language.Haskell.TH (Q, TExp, runIO)
import Language.Haskell.TH.Syntax (addDependentFile)
import Network.HTTP.Types (ok200, methodNotAllowed405)
import Network.Wai (Middleware, Application, pathInfo, requestMethod,
responseLBS)
import Safe (lastMay)
import System.Directory (removeDirectoryRecursive, createDirectory)
import System.Exit (ExitCode(ExitSuccess))
import System.Posix (ProcessStatus(Exited), forkProcess, executeFile,
getProcessStatus)
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.Text as T
requireElm :: UserHooks -> UserHooks
requireElm hooks =
hooks {
hookedPrograms = hookedPrograms hooks ++ [elmProg],
preConf = \args flags -> do
let verbosity = fromFlagOrDefault normal (configVerbosity flags)
db <- configureAllKnownPrograms verbosity defaultProgramDb
_ <- requireProgram verbosity elmProg db
preConf simpleUserHooks args flags
}
where
elmProg :: Program
elmProg = simpleProgram "elm-make"
elmSite :: Map PathInfo FilePath -> Q (TExp Middleware)
elmSite = elmSite2 False
elmSiteDebug :: Map PathInfo FilePath -> Q (TExp Middleware)
elmSiteDebug = elmSite2 True
elmSite2 :: Bool -> Map PathInfo FilePath -> Q (TExp Middleware)
elmSite2 debug spec =
buildMiddleware =<< (
mapM (\(u, c) -> (u,) <$> c) [
(uriPath, compileElm uriPath elmFile)
| (fmap T.unpack -> uriPath, elmFile) <- Map.toList spec
]
)
where
buildMiddleware :: [([String], (String, String))] -> Q (TExp Middleware)
buildMiddleware resources = [||
let
apps = Map.fromList[
(uriPath, buildApp contentType content)
| (fmap T.pack -> uriPath, (contentType, content)) <- resources
]
buildApp :: String -> String -> Application
buildApp contentType content req respond = respond $
case requestMethod req of
"GET" ->
responseLBS
ok200
[("Content-Type", fromString contentType)]
(fromString content)
_ -> responseLBS methodNotAllowed405 [("Allow", "GET")] ""
in
\downstream req respond ->
case Map.lookup (pathInfo req) apps of
Nothing -> downstream req respond
Just app -> app req respond
||]
compileElm :: [String] -> FilePath -> Q (String, String)
compileElm uriPath elmFile = do
addDependentFile elmFile
runIO $ do
void . tryAny $ removeDirectoryRecursive buildDir
createDirectory buildDir
putStrLn $ "Compiling elm file: " ++ elmFile
forkProcess (executeFile "elm-make" True ([
elmFile,
"--yes",
"--output=" <> buildFile
] ++ bool [] ["--debug"] debug) Nothing) >>= getProcessStatus True True >>= \case
Nothing -> fail "elm-make should have ended."
Just (Exited ExitSuccess) ->
(contentType,)
. T.unpack
. decodeUtf8
<$> BS.readFile buildFile
e -> fail $ "elm-make failed with: " ++ show e
where
buildDir :: (IsString a) => a
buildDir = ".om-elm-build-dir"
contentType :: String
contentType = case lastMay uriPath of
Just (endsWith ".js" -> True) -> "text/javascript"
_ -> "text/html"
buildFile :: FilePath
buildFile = buildDir <> case lastMay uriPath of
Just (endsWith ".js" -> True) -> "/elm.js"
_ -> "/elm.html"
endsWith :: String -> String -> Bool
endsWith ending str =
take (length ending) (reverse str) == reverse ending
type PathInfo = [Text]