{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

{- |
  This module contains utilities for compiling and bundling Elm programs
  directly into your Haskell executable binary. It is useful for the
  case where you want to bundle a front-end Elm web app along with the
  backing services that support it, and especially for when the two
  components are part of the same codebase. It produces WAI Middleware,
  and is thus compatible with a wide range server-side frameworks.

  Usage is designed to be as simple as possible. There are 3 steps:

  1) Change your .cabal file to use a \"Custom\" build type, and add
  the appropriate custom build dependencies.

  > build-type: Custom
  > ...
  > custom-setup
  >   setup-depends:
  >     Cabal,
  >     base,
  >     om-elm

  2) Modify your @Setup.hs@ file, using 'requireElm'.

  3) Include a 'Middleware' template-haskell splice, using 'elmSite',
  in the appropriate place in your code.

  See the function documnetation for more details.

-}
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


{- |
  Add the elm program requirements to a set of build hooks. This is
  expected to be used in your Setup.hs file thusly:

  > import Distribution.Simple (defaultMainWithHooks, simpleUserHooks)
  > import System.Elm.Middleware (requireElm)
  > 
  > main = defaultMainWithHooks (requireElm simpleUserHooks)

-}
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
    {- | A description of the elm program.  -}
    elmProg :: Program
    elmProg :: Program
elmProg = [Char] -> Program
simpleProgram [Char]
"elm"


{- |
  Template Haskell method to create a 'Middleware' that serves a set of
  elm programs. The elm programs are compiled into HTML at compile time,
  and that HTML is included directly in your executable.

  The parameter is a map of 'pathInfo's to elm program module file. The
  elm program located at the file is served whenever the pathInfo matches
  that of the request. Any non-matching request is forwarded to the
  downstream 'Application'.

  The typed template-haskell splice:

  > $$(elmSite $ Map.fromList [
  >     (["app.js"], "elm/Your/Elm/Module/App.elm")
  >   ])

  will construct a WAI 'Middleware' which serves the compiled elm program on
  @/app.js@.

-}
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


{- | Like 'elmSite', but serve the debug elm runtime. -}
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
    {- | Construct the middleware from a set of compiled elm resources. -}
    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
              ]
            {- | Build the application that serves a single elm resource. -}
            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
        {- |
          The name of the build directory. We have to have a build
          directory because elm won't output compile results to
          stdout. It will only output them to files.
        -}
        buildDir :: (IsString a) => a
        buildDir :: forall a. IsString a => a
buildDir = a
".om-elm-build-dir"

        {- | Figure out if we are compiling to javascript or html. -}
        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


{- | A WAI uri path, as per the meaning of 'pathInfo'. -}
type PathInfo = [Text]