{-# 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 (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 :: [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
    {- | A description of the elm program.  -}
    elmProg :: Program
    elmProg :: Program
elmProg = String -> Program
simpleProgram String
"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 PathInfo String -> Q (TExp Middleware)
elmSite = Bool -> Map PathInfo String -> Q (TExp Middleware)
elmSite2 Bool
False


{- | Like 'elmSite', but serve the debug elm runtime. -}
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
    {- | Construct the middleware from a set of compiled elm resources. -}
    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
            ]
          {- | Build the application that serves a single elm resource. -}
          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
        {- |
          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 :: a
buildDir = a
".om-elm-build-dir"

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


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