module Network.Wai.MakeAssets (serveAssets) where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.List (intercalate)
import Data.Monoid
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
serveAssets :: IO Application
serveAssets = do
startupChecks
let fileApp = staticApp $ defaultFileServerSettings "assets/"
mvar <- newMVar ()
return $ \ request respond -> do
(Exit exitCode, Stderr errs) <- synchronize mvar $
cmd (Cwd "client") "make"
case exitCode of
ExitSuccess -> fileApp request respond
ExitFailure _ -> respond $ responseLBS internalServerError500 [] $
cs "make error:\n" <> errs
synchronize :: MVar () -> IO a -> IO a
synchronize mvar action = modifyMVar mvar $ \ () -> ((), ) <$> action
startupChecks :: IO ()
startupChecks = do
checkExists Dir "client/" $
"You should put sources for assets in there."
checkExists File "client/Makefile" $ unwords $
"Which will be invoked to build the assets." :
"It should put compiled assets into 'assets/'." :
[]
checkExists Dir "assets/" $
"All files in 'assets/' will be served."
data FileType
= File
| Dir
checkExists :: FileType -> FilePath -> String -> IO ()
checkExists typ path hint = do
exists <- (isFile doesFileExist doesDirectoryExist) path
when (not exists) $ do
throwIO $ ErrorCall $ intercalate "\n" $
("missing " ++ isFile "file" "directory" ++ ": '" ++ path ++ "'") :
("Please create '" ++ path ++ "'.") :
("(" ++ hint ++ ")") :
[]
where
isFile :: a -> a -> a
isFile a b = case typ of
File -> a
Dir -> b