{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Network.Wai.MakeAssets (
serveAssets,
Options(..),
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 :: 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
"/")