{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

module Network.Wai.MakeAssets (
  serveAssets,
  Options(..),

  -- * re-exports
  Default(..),
) where

import           Control.Concurrent
import           Control.Exception
import           Control.Monad
import           Data.Default
import           Data.List (intercalate)
import           Data.String.Conversions
import           Development.Shake (cmd, Exit(..), Stderr(..), CmdOption(..))
import           Network.HTTP.Types.Status
import           Network.Wai
import           Network.Wai.Application.Static
import           System.Directory
import           System.Exit
import           System.FilePath

data Options
  = Options {
    Options -> FilePath
clientDir :: FilePath
  }

instance Default Options where
  def :: Options
def = Options :: FilePath -> Options
Options {
    clientDir :: FilePath
clientDir = FilePath
"client"
  }

-- | 'serveAssets' will create a wai 'Application' that serves files from the
-- "assets" directory.
--
-- The workflow that 'serveAssets' allows is similar to working on files (for
-- web-sites) that don't need compilation or generation, e.g. html, css, php or
-- javascript. You edit the file in an editor, save it, switch to a browser and
-- hit reload. 'serveAssets' makes sure your browser will be sent up-to-date
-- files.
--
-- To accomplish this, 'serveAssets' assumes that there's a "Makefile" in the
-- directory pointed to by 'clientDir' (default: "client"). This "Makefile" is
-- supposed to put compilation results into the "assets" directory. On __every__
-- request, 'serveAssets' will execute that "Makefile" and only start serving
-- files once the "Makefile" is done. ('serveAssets' makes sure not to run your
-- "Makefile" concurrently.)
serveAssets :: Options -> IO Application
serveAssets :: Options -> IO Application
serveAssets Options
options = do
  Options -> IO ()
startupChecks Options
options
  let fileApp :: Application
fileApp = StaticSettings -> Application
staticApp (StaticSettings -> Application) -> StaticSettings -> Application
forall a b. (a -> b) -> a -> b
$ FilePath -> StaticSettings
defaultFileServerSettings FilePath
"assets/"
  MVar ()
mvar <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
  Application -> IO Application
forall (m :: * -> *) a. Monad m => a -> m a
return (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ \ Request
request Response -> IO ResponseReceived
respond -> do
    (Exit ExitCode
exitCode, Stderr ByteString
errs) <- MVar ()
-> IO (Exit, Stderr ByteString) -> IO (Exit, Stderr ByteString)
forall a. MVar () -> IO a -> IO a
synchronize MVar ()
mvar (IO (Exit, Stderr ByteString) -> IO (Exit, Stderr ByteString))
-> IO (Exit, Stderr ByteString) -> IO (Exit, Stderr ByteString)
forall a b. (a -> b) -> a -> b
$
      (CmdOption -> FilePath -> IO (Exit, Stderr ByteString))
:-> Action Any
forall args r. (Partial, CmdArguments args) => args
cmd (FilePath -> CmdOption
Cwd (Options -> FilePath
clientDir Options
options)) FilePath
"make"
    case ExitCode
exitCode of
      ExitCode
ExitSuccess -> Application
fileApp Request
request Response -> IO ResponseReceived
respond
      ExitFailure Int
_ -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
internalServerError500 [] (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$
        FilePath -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs FilePath
"make error:\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
errs

synchronize :: MVar () -> IO a -> IO a
synchronize :: MVar () -> IO a -> IO a
synchronize MVar ()
mvar IO a
action = MVar () -> (() -> IO ((), a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar ()
mvar ((() -> IO ((), a)) -> IO a) -> (() -> IO ((), a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \ () -> ((), ) (a -> ((), a)) -> IO a -> IO ((), a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
action

startupChecks :: Options -> IO ()
startupChecks :: Options -> IO ()
startupChecks Options
options = do
  FileType -> FilePath -> FilePath -> IO ()
checkExists FileType
Dir (Options -> FilePath
clientDir Options
options) (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
    FilePath
"You should put sources for assets in there."
  FileType -> FilePath -> FilePath -> IO ()
checkExists FileType
File (Options -> FilePath
clientDir Options
options FilePath -> FilePath -> FilePath
</> FilePath
"Makefile") (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
    FilePath
"Which will be invoked to build the assets." FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:
    FilePath
"It should put compiled assets into 'assets/'." FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:
    []
  FileType -> FilePath -> FilePath -> IO ()
checkExists FileType
Dir FilePath
"assets" (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
    FilePath
"All files in 'assets/' will be served."

data FileType
  = File
  | Dir

checkExists :: FileType -> FilePath -> String -> IO ()
checkExists :: FileType -> FilePath -> FilePath -> IO ()
checkExists FileType
typ FilePath
path FilePath
hint = do
  Bool
exists <- ((FilePath -> IO Bool)
-> (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a. a -> a -> a
isFile FilePath -> IO Bool
doesFileExist FilePath -> IO Bool
doesDirectoryExist) FilePath
path
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
exists) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ErrorCall -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO ()) -> ErrorCall -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n" ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
      (FilePath
"missing " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath -> FilePath
forall a. a -> a -> a
isFile FilePath
"file" FilePath
"directory" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
showPath FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'") FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:
      (FilePath
"Please create '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
showPath FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'.") FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:
      (FilePath
"(" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
hint FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")") FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:
      []
  where
    isFile :: a -> a -> a
    isFile :: a -> a -> a
isFile a
a a
b = case FileType
typ of
      FileType
File -> a
a
      FileType
Dir -> a
b

    showPath :: FilePath -> String
    showPath :: FilePath -> FilePath
showPath = case FileType
typ of
      FileType
File -> FilePath -> FilePath
forall a. a -> a
id
      FileType
Dir -> (FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/")