Multiple threads for communicating with processes

This commit is contained in:
Michael Snoyman 2014-03-26 22:05:06 +02:00
parent bdcb174830
commit 7f1b06ecb3
2 changed files with 26 additions and 11 deletions

View File

@ -30,13 +30,12 @@ module Yesod.EmbeddedStatic.Generators (
-- $example -- $example
) where ) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>), (<*>))
import Control.Exception (try, SomeException) import Control.Exception (try, SomeException)
import Control.Monad (forM, when) import Control.Monad (forM, when)
import Control.Monad.Trans.Resource (runResourceT) import Control.Monad.Trans.Resource (runResourceT)
import Data.Char (isDigit, isLower) import Data.Char (isDigit, isLower)
import Data.Conduit (($$), (=$)) import Data.Conduit (($$))
import Data.Conduit.Process (proc, conduitProcess)
import Data.Default (def) import Data.Default (def)
import Data.Maybe (isNothing) import Data.Maybe (isNothing)
import Language.Haskell.TH import Language.Haskell.TH
@ -46,7 +45,12 @@ import System.FilePath ((</>))
import Text.Jasmine (minifym) import Text.Jasmine (minifym)
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import Data.Conduit.Binary (sourceHandle)
import qualified Data.Text as T import qualified Data.Text as T
import qualified System.Process as Proc
import System.Exit (ExitCode (ExitSuccess))
import Control.Concurrent.Async (Concurrently (..))
import System.IO (hClose)
import Yesod.EmbeddedStatic.Types import Yesod.EmbeddedStatic.Types
@ -197,12 +201,20 @@ compressTool f opts ct = do
mpath <- findExecutable f mpath <- findExecutable f
when (isNothing mpath) $ when (isNothing mpath) $
fail $ "Unable to find " ++ f fail $ "Unable to find " ++ f
let src = C.sourceList $ BL.toChunks ct let p = (Proc.proc f opts)
p = proc f opts { Proc.std_in = Proc.CreatePipe
sink = C.consume , Proc.std_out = Proc.CreatePipe
compressed <- runResourceT (src $$ conduitProcess p =$ sink) }
putStrLn $ "Compressed successfully with " ++ f (Just hin, Just hout, _, ph) <- Proc.createProcess p
return $ BL.fromChunks compressed (compressed, (), code) <- runConcurrently $ (,,)
<$> Concurrently (sourceHandle hout $$ C.consume)
<*> Concurrently (BL.hPut hin ct >> hClose hin)
<*> Concurrently (Proc.waitForProcess ph)
if code == ExitSuccess
then do
putStrLn $ "Compressed successfully with " ++ f
return $ BL.fromChunks compressed
else error $ "compressTool: compression failed with " ++ f
-- | Try a list of processing functions (like the compressions above) one by one until -- | Try a list of processing functions (like the compressions above) one by one until

View File

@ -49,10 +49,11 @@ library
, shakespeare-css >= 1.0.3 , shakespeare-css >= 1.0.3
, mime-types >= 0.1 , mime-types >= 0.1
, hjsmin , hjsmin
, process-conduit >= 1.0 && < 1.1
, filepath >= 1.3 , filepath >= 1.3
, resourcet >= 0.4 , resourcet >= 0.4
, unordered-containers >= 0.2 , unordered-containers >= 0.2
, process
, async
exposed-modules: Yesod.Static exposed-modules: Yesod.Static
Yesod.EmbeddedStatic Yesod.EmbeddedStatic
@ -104,8 +105,10 @@ test-suite tests
, filepath , filepath
, resourcet , resourcet
, unordered-containers , unordered-containers
, async
, process
ghc-options: -Wall ghc-options: -Wall -threaded
extensions: TemplateHaskell extensions: TemplateHaskell
source-repository head source-repository head