{-# 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 'elmSiteDev',
  in the appropriate place in your code.

  See the function documnetation for more details.

-}
module System.Elm.Middleware
  ( requireElm
  , elmSiteDebug
  , elmSiteDev
  , elmSiteOptimize
  , PathInfo
  )
where

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
  ( ConfigFlags(configVerbosity), fromFlagOrDefault
  )
import Distribution.Verbosity (normal)
import Language.Haskell.TH (Code(examineCode), Q, TExp)
import Network.HTTP.Types (methodNotAllowed405, ok200)
import Network.Wai
  ( Request(pathInfo, requestMethod), Application, Middleware, responseLBS
  )
import Prelude
  ( Applicative(pure), Bool(True), Eq((==)), Foldable(length), Functor(fmap)
  , Maybe(Just, Nothing), Traversable(mapM), ($), (++), (=<<), FilePath, String
  , reverse, take
  )
import Safe (lastMay)
import System.Elm.Compile
  ( ElmOutputFormat(Html, JavaScript), Mode(Debug, Dev, Optimize), compileElm
  )
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:

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

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

  Neither the @--optimize@ nor the @--debug@ flags are passed to the
  elm compiler.

-}
elmSiteDev  :: Map PathInfo FilePath -> Q (TExp Middleware)
elmSiteDev :: Map [Text] [Char] -> Q (TExp Middleware)
elmSiteDev = Mode -> Map [Text] [Char] -> Q (TExp Middleware)
elmSite2 Mode
Dev


{- | Like 'elmSiteDev', but serve the debug elm runtime. -}
elmSiteDebug :: Map PathInfo FilePath -> Q (TExp Middleware)
elmSiteDebug :: Map [Text] [Char] -> Q (TExp Middleware)
elmSiteDebug = Mode -> Map [Text] [Char] -> Q (TExp Middleware)
elmSite2 Mode
Debug


{- | Like 'elmSiteDev', but pass @--optimize@ to the elm compiler. -}
elmSiteOptimize :: Map PathInfo FilePath -> Q (TExp Middleware)
elmSiteOptimize :: Map [Text] [Char] -> Q (TExp Middleware)
elmSiteOptimize = Mode -> Map [Text] [Char] -> Q (TExp Middleware)
elmSite2 Mode
Optimize


elmSite2 :: Mode -> Map PathInfo FilePath -> Q (TExp Middleware)
elmSite2 :: Mode -> Map [Text] [Char] -> Q (TExp Middleware)
elmSite2 Mode
mode 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
=<< (([Text], [Char]) -> Q ([[Char]], ([Char], [Char])))
-> [([Text], [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 ([Text], [Char]) -> Q ([[Char]], ([Char], [Char]))
compileResource (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]
contentTypeHeader [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]
contentTypeHeader, [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]
contentTypeHeader [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]
contentTypeHeader)]
                    ([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
        ||]

    compileResource
      :: (PathInfo, FilePath)
      -> Q ([String], (String, String))
    compileResource :: ([Text], [Char]) -> Q ([[Char]], ([Char], [Char]))
compileResource ([Text]
uriPathText, [Char]
elmFile) = do
      let
        uriPath :: [String]
        uriPath :: [[Char]]
uriPath = (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 [Text]
uriPathText

        format :: ElmOutputFormat
        format :: ElmOutputFormat
format = [[Char]] -> ElmOutputFormat
outputFormat [[Char]]
uriPath
      [Char]
content <- Mode -> ElmOutputFormat -> [Char] -> Q [Char]
compileElm Mode
mode ElmOutputFormat
format [Char]
elmFile
      ([[Char]], ([Char], [Char])) -> Q ([[Char]], ([Char], [Char]))
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]]
uriPath, (ElmOutputFormat -> [Char]
contentType ElmOutputFormat
format, [Char]
content))

    outputFormat :: [String] -> ElmOutputFormat
    outputFormat :: [[Char]] -> ElmOutputFormat
outputFormat [[Char]]
uriPath =
      case [[Char]] -> Maybe [Char]
forall a. [a] -> Maybe a
lastMay [[Char]]
uriPath of
        Just ([Char] -> [Char] -> Bool
endsWith [Char]
".js" -> Bool
True) -> ElmOutputFormat
JavaScript
        Maybe [Char]
_ -> ElmOutputFormat
Html

    contentType :: ElmOutputFormat -> String
    contentType :: ElmOutputFormat -> [Char]
contentType = \case
      ElmOutputFormat
JavaScript -> [Char]
"text/javascript"
      ElmOutputFormat
Html -> [Char]
"text/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]