{-# 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 (Code(examineCode), 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 = hookedPrograms hooks ++ [elmProg],
preConf = \[[Char]]
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 -> [[Char]] -> ConfigFlags -> IO HookedBuildInfo
preConf UserHooks
simpleUserHooks [[Char]]
args ConfigFlags
flags
}
where
elmProg :: Program
elmProg :: Program
elmProg = [Char] -> Program
simpleProgram [Char]
"elm"
elmSite :: Map PathInfo FilePath -> Q (TExp Middleware)
elmSite :: Map [Text] [Char] -> Q (TExp Middleware)
elmSite = Bool -> Map [Text] [Char] -> Q (TExp Middleware)
elmSite2 Bool
False
elmSiteDebug :: Map PathInfo FilePath -> Q (TExp Middleware)
elmSiteDebug :: Map [Text] [Char] -> Q (TExp Middleware)
elmSiteDebug = Bool -> Map [Text] [Char] -> Q (TExp Middleware)
elmSite2 Bool
True
elmSite2 :: Bool -> Map PathInfo FilePath -> Q (TExp Middleware)
elmSite2 :: Bool -> Map [Text] [Char] -> Q (TExp Middleware)
elmSite2 Bool
debug Map [Text] [Char]
spec =
[([[Char]], ([Char], [Char]))] -> Q (TExp Middleware)
buildMiddleware ([([[Char]], ([Char], [Char]))] -> Q (TExp Middleware))
-> Q [([[Char]], ([Char], [Char]))] -> Q (TExp Middleware)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(([[Char]], Q ([Char], [Char])) -> Q ([[Char]], ([Char], [Char])))
-> [([[Char]], Q ([Char], [Char]))]
-> Q [([[Char]], ([Char], [Char]))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\([[Char]]
u, Q ([Char], [Char])
c) -> ([[Char]]
u,) (([Char], [Char]) -> ([[Char]], ([Char], [Char])))
-> Q ([Char], [Char]) -> Q ([[Char]], ([Char], [Char]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q ([Char], [Char])
c) [
([[Char]]
uriPath, [[Char]] -> [Char] -> Q ([Char], [Char])
compileElm [[Char]]
uriPath [Char]
elmFile)
| ((Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Char]
T.unpack -> [[Char]]
uriPath, [Char]
elmFile) <- Map [Text] [Char] -> [([Text], [Char])]
forall k a. Map k a -> [(k, a)]
Map.toList Map [Text] [Char]
spec
]
where
buildMiddleware :: [([String], (String, String))] -> Q (TExp Middleware)
buildMiddleware :: [([[Char]], ([Char], [Char]))] -> Q (TExp Middleware)
buildMiddleware [([[Char]], ([Char], [Char]))]
resources =
Code Q Middleware -> Q (TExp Middleware)
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode
[||
let
apps :: Map k a
apps = [(k, a)] -> Map k a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList[
(f b
uriPath, [Char] -> [Char] -> Application
buildApp [Char]
contentType [Char]
content)
| ((a -> b) -> f a -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Text
T.pack -> f b
uriPath, ([Char]
contentType, [Char]
content)) <- [([[Char]], ([Char], [Char]))]
resources
]
buildApp :: String -> String -> Application
buildApp :: [Char] -> [Char] -> Application
buildApp [Char]
contentType [Char]
content Request
req Response -> IO ResponseReceived
respond = Response -> IO ResponseReceived
respond (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$
case Request -> Method
requestMethod Request
req of
Method
"GET" ->
Status -> ResponseHeaders -> ByteString -> Response
responseLBS
Status
ok200
[(a
"Content-Type", [Char] -> a
forall a. IsString a => [Char] -> a
fromString [Char]
contentType)]
([Char] -> a
forall a. IsString a => [Char] -> a
fromString [Char]
content)
Method
_ -> Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
methodNotAllowed405 [(a
"Allow", a
"GET")] a
""
in
\p
downstream p
req p
respond ->
case k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Request -> [Text]
pathInfo p
req) Map [Text] Application
apps of
Maybe a
Nothing -> p
downstream p
req p
respond
Just a
app -> a
app p
req p
respond
||]
compileElm :: [String] -> FilePath -> Q (String, String)
compileElm :: [[Char]] -> [Char] -> Q ([Char], [Char])
compileElm [[Char]]
uriPath [Char]
elmFile = do
[Char] -> Q ()
addDependentFile [Char]
elmFile
IO ([Char], [Char]) -> Q ([Char], [Char])
forall a. IO a -> Q a
runIO (IO ([Char], [Char]) -> Q ([Char], [Char]))
-> IO ([Char], [Char]) -> Q ([Char], [Char])
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.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
tryAny (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
removeDirectoryRecursive [Char]
forall a. IsString a => a
buildDir
[Char] -> IO ()
createDirectory [Char]
forall a. IsString a => a
buildDir
[Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Compiling elm file: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
elmFile
IO () -> IO ProcessID
forkProcess
(
[Char] -> Bool -> [[Char]] -> Maybe [([Char], [Char])] -> IO ()
forall a.
[Char] -> Bool -> [[Char]] -> Maybe [([Char], [Char])] -> IO a
executeFile [Char]
"elm" Bool
True ([
[Char]
"make",
[Char]
elmFile,
[Char]
"--output=" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
buildFile
] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [[Char]] -> Bool -> [[Char]]
forall a. a -> a -> Bool -> a
bool [] [[Char]
"--debug"] Bool
debug) Maybe [([Char], [Char])]
forall a. Maybe a
Nothing
) IO ProcessID
-> (ProcessID -> IO (Maybe ProcessStatus))
-> IO (Maybe ProcessStatus)
forall a b. IO a -> (a -> IO b) -> IO b
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 ([Char], [Char]))
-> IO ([Char], [Char])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe ProcessStatus
Nothing -> [Char] -> IO ([Char], [Char])
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"elm should have ended."
Just (Exited ExitCode
ExitSuccess) ->
([Char]
contentType,)
([Char] -> ([Char], [Char]))
-> (Method -> [Char]) -> Method -> ([Char], [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> [Char]
BS8.unpack
(Method -> ([Char], [Char])) -> IO Method -> IO ([Char], [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Method
BS.readFile [Char]
buildFile
Maybe ProcessStatus
e -> [Char] -> IO ([Char], [Char])
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ([Char], [Char])) -> [Char] -> IO ([Char], [Char])
forall a b. (a -> b) -> a -> b
$ [Char]
"elm failed with: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe ProcessStatus -> [Char]
forall a. Show a => a -> [Char]
show Maybe ProcessStatus
e
where
buildDir :: (IsString a) => a
buildDir :: forall a. IsString a => a
buildDir = a
".om-elm-build-dir"
contentType :: String
contentType :: [Char]
contentType = case [[Char]] -> Maybe [Char]
forall a. [a] -> Maybe a
lastMay [[Char]]
uriPath of
Just ([Char] -> [Char] -> Bool
endsWith [Char]
".js" -> Bool
True) -> [Char]
"text/javascript"
Maybe [Char]
_ -> [Char]
"text/html"
buildFile :: FilePath
buildFile :: [Char]
buildFile = [Char]
forall a. IsString a => a
buildDir [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> case [[Char]] -> Maybe [Char]
forall a. [a] -> Maybe a
lastMay [[Char]]
uriPath of
Just ([Char] -> [Char] -> Bool
endsWith [Char]
".js" -> Bool
True) -> [Char]
"/elm.js"
Maybe [Char]
_ -> [Char]
"/elm.html"
endsWith :: String -> String -> Bool
endsWith :: [Char] -> [Char] -> Bool
endsWith [Char]
ending [Char]
str =
Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
ending) ([Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
str) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
ending
type PathInfo = [Text]