{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
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.String (IsString, fromString)
import Data.Text (Text)
import Distribution.Simple (UserHooks, hookedPrograms, preConf,
simpleUserHooks)
import Distribution.Simple.Program (Program, configureAllKnownPrograms,
defaultProgramDb, requireProgram, simpleProgram)
import Distribution.Simple.Setup (configVerbosity, fromFlagOrDefault)
import Distribution.Verbosity (normal)
import Language.Haskell.TH (Q, TExp, runIO)
import Language.Haskell.TH.Syntax (addDependentFile)
import Network.HTTP.Types (methodNotAllowed405, ok200)
import Network.Wai (Application, Middleware, pathInfo, requestMethod,
responseLBS)
import Safe (lastMay)
import System.Directory (createDirectory, removeDirectoryRecursive)
import System.Exit (ExitCode(ExitSuccess))
import System.Posix (ProcessStatus(Exited), executeFile, forkProcess,
getProcessStatus)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Map as Map
import qualified Data.Text as T
requireElm :: UserHooks -> UserHooks
requireElm :: UserHooks -> UserHooks
requireElm UserHooks
hooks =
UserHooks
hooks {
hookedPrograms :: [Program]
hookedPrograms = UserHooks -> [Program]
hookedPrograms UserHooks
hooks [Program] -> [Program] -> [Program]
forall a. [a] -> [a] -> [a]
++ [Program
elmProg],
preConf :: Args -> ConfigFlags -> IO HookedBuildInfo
preConf = \Args
args ConfigFlags
flags -> do
let verbosity :: Verbosity
verbosity = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
flags)
ProgramDb
db <- Verbosity -> ProgramDb -> IO ProgramDb
configureAllKnownPrograms Verbosity
verbosity ProgramDb
defaultProgramDb
(ConfiguredProgram, ProgramDb)
_ <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
elmProg ProgramDb
db
UserHooks -> Args -> ConfigFlags -> IO HookedBuildInfo
preConf UserHooks
simpleUserHooks Args
args ConfigFlags
flags
}
where
elmProg :: Program
elmProg :: Program
elmProg = String -> Program
simpleProgram String
"elm"
elmSite :: Map PathInfo FilePath -> Q (TExp Middleware)
elmSite :: Map PathInfo String -> Q (TExp Middleware)
elmSite = Bool -> Map PathInfo String -> Q (TExp Middleware)
elmSite2 Bool
False
elmSiteDebug :: Map PathInfo FilePath -> Q (TExp Middleware)
elmSiteDebug :: Map PathInfo String -> Q (TExp Middleware)
elmSiteDebug = Bool -> Map PathInfo String -> Q (TExp Middleware)
elmSite2 Bool
True
elmSite2 :: Bool -> Map PathInfo FilePath -> Q (TExp Middleware)
elmSite2 :: Bool -> Map PathInfo String -> Q (TExp Middleware)
elmSite2 Bool
debug Map PathInfo String
spec =
[(Args, (String, String))] -> Q (TExp Middleware)
buildMiddleware ([(Args, (String, String))] -> Q (TExp Middleware))
-> Q [(Args, (String, String))] -> Q (TExp Middleware)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
((Args, Q (String, String)) -> Q (Args, (String, String)))
-> [(Args, Q (String, String))] -> Q [(Args, (String, String))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Args
u, Q (String, String)
c) -> (Args
u,) ((String, String) -> (Args, (String, String)))
-> Q (String, String) -> Q (Args, (String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q (String, String)
c) [
(Args
uriPath, Args -> String -> Q (String, String)
compileElm Args
uriPath String
elmFile)
| ((Text -> String) -> PathInfo -> Args
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
T.unpack -> Args
uriPath, String
elmFile) <- Map PathInfo String -> [(PathInfo, String)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PathInfo String
spec
]
where
buildMiddleware :: [([String], (String, String))] -> Q (TExp Middleware)
buildMiddleware :: [(Args, (String, String))] -> Q (TExp Middleware)
buildMiddleware [(Args, (String, String))]
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 :: Args -> String -> Q (String, String)
compileElm Args
uriPath String
elmFile = do
String -> Q ()
addDependentFile String
elmFile
IO (String, String) -> Q (String, String)
forall a. IO a -> Q a
runIO (IO (String, String) -> Q (String, String))
-> IO (String, String) -> Q (String, String)
forall a b. (a -> b) -> a -> b
$ do
IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> (IO () -> IO (Either SomeException ())) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAny (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryRecursive String
forall a. IsString a => a
buildDir
String -> IO ()
createDirectory String
forall a. IsString a => a
buildDir
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Compiling elm file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
elmFile
IO () -> IO ProcessID
forkProcess (String -> Bool -> Args -> Maybe [(String, String)] -> IO ()
forall a.
String -> Bool -> Args -> Maybe [(String, String)] -> IO a
executeFile String
"elm" Bool
True ([
String
"make",
String
elmFile,
String
"--output=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
buildFile
] Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ Args -> Args -> Bool -> Args
forall a. a -> a -> Bool -> a
bool [] [String
"--debug"] Bool
debug) Maybe [(String, String)]
forall a. Maybe a
Nothing) IO ProcessID
-> (ProcessID -> IO (Maybe ProcessStatus))
-> IO (Maybe ProcessStatus)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
getProcessStatus Bool
True Bool
True IO (Maybe ProcessStatus)
-> (Maybe ProcessStatus -> IO (String, String))
-> IO (String, String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe ProcessStatus
Nothing -> String -> IO (String, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"elm should have ended."
Just (Exited ExitCode
ExitSuccess) ->
(String
contentType,)
(String -> (String, String))
-> (ByteString -> String) -> ByteString -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS8.unpack
(ByteString -> (String, String))
-> IO ByteString -> IO (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
buildFile
Maybe ProcessStatus
e -> String -> IO (String, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (String, String)) -> String -> IO (String, String)
forall a b. (a -> b) -> a -> b
$ String
"elm failed with: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe ProcessStatus -> String
forall a. Show a => a -> String
show Maybe ProcessStatus
e
where
buildDir :: (IsString a) => a
buildDir :: a
buildDir = a
".om-elm-build-dir"
contentType :: String
contentType :: String
contentType = case Args -> Maybe String
forall a. [a] -> Maybe a
lastMay Args
uriPath of
Just (String -> String -> Bool
endsWith String
".js" -> Bool
True) -> String
"text/javascript"
Maybe String
_ -> String
"text/html"
buildFile :: FilePath
buildFile :: String
buildFile = String
forall a. IsString a => a
buildDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> case Args -> Maybe String
forall a. [a] -> Maybe a
lastMay Args
uriPath of
Just (String -> String -> Bool
endsWith String
".js" -> Bool
True) -> String
"/elm.js"
Maybe String
_ -> String
"/elm.html"
endsWith :: String -> String -> Bool
endsWith :: String -> String -> Bool
endsWith String
ending String
str =
Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ending) (String -> String
forall a. [a] -> [a]
reverse String
str) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String
forall a. [a] -> [a]
reverse String
ending
type PathInfo = [Text]