diff --git a/Build.hs b/Build.hs --- a/Build.hs +++ b/Build.hs @@ -7,22 +7,27 @@ , touch , recompDeps , isNewerThan + , safeReadFile ) where -- FIXME there's a bug when getFileStatus applies to a file -- temporary deleted (e.g., Vim saving a file) import Control.Applicative ((<|>), many, (<$>)) -import qualified Data.Attoparsec.Text.Lazy as A +import qualified Data.Attoparsec.Text as A import Data.Char (isSpace, isUpper) -import qualified Data.Text.Lazy.IO as TIO +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S -import Control.Exception (SomeException, try) +import Control.Exception (SomeException, try, IOException) import Control.Exception.Lifted (handle) import Control.Monad (when, filterM, forM, forM_, (>=>)) import Control.Monad.Trans.State (StateT, get, put, execStateT) import Control.Monad.Trans.Writer (WriterT, tell, execWriterT) -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Class (lift) import Data.Monoid (Monoid (mappend, mempty)) @@ -40,6 +45,9 @@ import Text.Cassius (cassiusUsedIdentifiers) import Text.Lucius (luciusUsedIdentifiers) +safeReadFile :: MonadIO m => FilePath -> m (Either IOException ByteString) +safeReadFile = liftIO . try . S.readFile + touch :: IO () touch = do m <- handle (\(_ :: SomeException) -> return Map.empty) $ readFile touchCache >>= readIO @@ -86,8 +94,11 @@ AlwaysOutdated -> return True CompareUsedIdentifiers getDerefs -> do derefMap <- get - s <- liftIO $ readFile x - let newDerefs = Set.fromList $ getDerefs s + ebs <- safeReadFile x + let newDerefs = + case ebs of + Left _ -> Set.empty + Right bs -> Set.fromList $ getDerefs $ T.unpack $ decodeUtf8With lenientDecode bs put $ Map.insert x newDerefs derefMap case Map.lookup x derefMap of Just oldDerefs | oldDerefs == newDerefs -> return False @@ -176,11 +187,15 @@ determineDeps :: FilePath -> IO [(ComparisonType, FilePath)] determineDeps x = do - y <- TIO.readFile x -- FIXME catch IO exceptions - let z = A.parse (many $ (parser <|> (A.anyChar >> return Nothing))) y - case z of - A.Fail{} -> return [] - A.Done _ r -> mapM go r >>= filterM (doesFileExist . snd) . concat + y <- safeReadFile x + case y of + Left _ -> return [] + Right bs -> do + let z = A.parseOnly (many $ (parser <|> (A.anyChar >> return Nothing))) + $ decodeUtf8With lenientDecode bs + case z of + Left _ -> return [] + Right r -> mapM go r >>= filterM (doesFileExist . snd) . concat where go (Just (StaticFiles fp, _)) = map ((,) AlwaysOutdated) <$> getFolderContents fp go (Just (Hamlet, f)) = return [(AlwaysOutdated, f)] diff --git a/Devel.hs b/Devel.hs --- a/Devel.hs +++ b/Devel.hs @@ -33,12 +33,16 @@ when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.State (evalStateT, get) +import qualified Data.IORef as I import Data.Char (isNumber, isUpper) import qualified Data.List as L import qualified Data.Map as Map import Data.Maybe (fromMaybe) import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) import System.Directory import System.Environment (getEnvironment) @@ -62,7 +66,7 @@ import System.Timeout (timeout) import Build (getDeps, isNewerThan, - recompDeps) + recompDeps, safeReadFile) import GhcBuild (buildPackage, getBuildFlags) @@ -72,7 +76,7 @@ import Network (withSocketsDo) import Network.HTTP.Conduit (def, newManager) import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest), - waiProxyTo) + waiProxyToSettings, wpsTimeout, wpsOnExc) import Network.HTTP.Types (status200) import Network.Socket (sClose) import Network.Wai (responseLBS) @@ -113,13 +117,18 @@ -- | Run a reverse proxy from port 3000 to 3001. If there is no response on -- 3001, give an appropriate message to the user. -reverseProxy :: DevelOpts -> Int -> IO () -reverseProxy opts appPort = do +reverseProxy :: DevelOpts -> I.IORef Int -> IO () +reverseProxy opts iappPort = do manager <- newManager def let loop = forever $ do - run (develPort opts) $ waiProxyTo - (const $ return $ Right $ ProxyDest "127.0.0.1" appPort) - onExc + run (develPort opts) $ waiProxyToSettings + (const $ do + appPort <- liftIO $ I.readIORef iappPort + return $ Right $ ProxyDest "127.0.0.1" appPort) + def + { wpsOnExc = onExc + , wpsTimeout = Just 10000000 + } manager putStrLn "Reverse proxy stopped, but it shouldn't" threadDelay 1000000 @@ -151,8 +160,8 @@ devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do avail <- checkPort $ develPort opts unless avail $ error "devel port unavailable" - appPort <- getPort 17834 - _ <- forkIO $ reverseProxy opts appPort + iappPort <- getPort 17834 >>= I.newIORef + _ <- forkIO $ reverseProxy opts iappPort checkDevelFile writeLock opts @@ -160,7 +169,7 @@ _ <- forkIO $ do filesModified <- newEmptyMVar watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ())) - evalStateT (mainOuterLoop appPort filesModified) Map.empty + evalStateT (mainOuterLoop iappPort filesModified) Map.empty _ <- getLine writeLock opts exitSuccess @@ -168,7 +177,7 @@ bd = getBuildDir opts -- outer loop re-reads the cabal file - mainOuterLoop appPort filesModified = do + mainOuterLoop iappPort filesModified = do ghcVer <- liftIO ghcVersion cabal <- liftIO $ D.findPackageDesc "." gpd <- liftIO $ D.readPackageDescription D.normal cabal @@ -180,10 +189,10 @@ liftIO $ removeFileIfExists "yesod-devel/arargs.txt" -- the configure step, remove them to force liftIO $ removeFileIfExists "yesod-devel/ldargs.txt" -- a cabal build first rebuild <- liftIO $ mkRebuild gpd ghcVer cabal opts ldar - mainInnerLoop appPort hsSourceDirs filesModified cabal gpd lib ghcVer rebuild + mainInnerLoop iappPort hsSourceDirs filesModified cabal gpd lib ghcVer rebuild -- inner loop rebuilds after files change - mainInnerLoop appPort hsSourceDirs filesModified cabal gpd lib ghcVer rebuild = go + mainInnerLoop iappPort hsSourceDirs filesModified cabal gpd lib ghcVer rebuild = go where go = do _ <- recompDeps hsSourceDirs @@ -206,6 +215,11 @@ $ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs else "Starting development server..." env0 <- liftIO getEnvironment + + -- get a new port for the new process to listen on + appPort <- liftIO $ I.readIORef iappPort >>= getPort . (+ 1) + liftIO $ I.writeIORef iappPort appPort + (_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs) { env = Just $ ("PORT", show appPort) : ("DISPLAY_PORT", show $ develPort opts) : env0 } @@ -223,7 +237,7 @@ liftIO $ Ex.throwTo watchTid (userError "process finished") loop list n <- liftIO $ cabal `isNewerThan` (bd "setup-config") - if n then mainOuterLoop appPort filesModified else go + if n then mainOuterLoop iappPort filesModified else go runBuildHook :: Maybe String -> IO () runBuildHook (Just s) = do @@ -439,13 +453,16 @@ if not exists then return (Left $ "file does not exist: " ++ file) else do - xs <- readFile file - return $ case lines xs of - [_,l2] -> -- two lines, header and serialized rest - case reads l2 of - [(bi,_)] -> Right bi - _ -> (Left "cannot parse contents") - _ -> (Left "not a valid header/content file") + xs <- safeReadFile file + case xs of + Left e -> return $ Left $ show e + Right bs -> + return $ case lines $ T.unpack $ decodeUtf8With lenientDecode bs of + [_,l2] -> -- two lines, header and serialized rest + case reads l2 of + [(bi,_)] -> Right bi + _ -> (Left "cannot parse contents") + _ -> (Left "not a valid header/content file") fromMaybeErr :: String -> Maybe b -> IO b fromMaybeErr err Nothing = failWith err diff --git a/hsfiles/mongo.hsfiles b/hsfiles/mongo.hsfiles --- a/hsfiles/mongo.hsfiles +++ b/hsfiles/mongo.hsfiles @@ -139,7 +139,9 @@ -- default session idle timeout is 120 minutes makeSessionBackend _ = do key <- getKey "config/client_session_key.aes" - return . Just $ clientSessionBackend key 120 + let timeout = 120 * 60 -- 120 minutes + (getCachedDate, _closeDateCache) <- clientSessionDateCacher timeout + return . Just $ clientSessionBackend2 key getCachedDate defaultLayout widget = do master <- getYesod @@ -170,7 +172,13 @@ -- and names them based on a hash of their content. This allows -- expiration dates to be set far in the future without worry of -- users receiving stale content. - addStaticContent = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute []) + addStaticContent = + addStaticContentExternal minifym genFileName Settings.staticDir (StaticR . flip StaticRoute []) + where + -- Generate a unique filename based on the content itself + genFileName lbs + | development = "autogen-" ++ base64md5 lbs + | otherwise = base64md5 lbs -- Place Javascript at bottom of the body tag so the rest of the page loads first jsLoader _ = BottomOfBody @@ -364,7 +372,7 @@ build-depends: base >= 4 && < 5 -- , yesod-platform >= 1.1 && < 1.2 , yesod >= 1.1.5 && < 1.2 - , yesod-core >= 1.1.5 && < 1.2 + , yesod-core >= 1.1.7 && < 1.2 , yesod-auth >= 1.1 && < 1.2 , yesod-static >= 1.1 && < 1.2 , yesod-default >= 1.1 && < 1.2 @@ -465,6 +473,10 @@ -- | Settings for 'widgetFile', such as which template languages to support and -- default Hamlet settings. +-- +-- For more information on modifying behavior, see: +-- +-- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile widgetFileSettings :: WidgetFileSettings widgetFileSettings = def { wfsHamletSettings = defaultHamletSettings diff --git a/hsfiles/mysql.hsfiles b/hsfiles/mysql.hsfiles --- a/hsfiles/mysql.hsfiles +++ b/hsfiles/mysql.hsfiles @@ -141,7 +141,9 @@ -- default session idle timeout is 120 minutes makeSessionBackend _ = do key <- getKey "config/client_session_key.aes" - return . Just $ clientSessionBackend key 120 + let timeout = 120 * 60 -- 120 minutes + (getCachedDate, _closeDateCache) <- clientSessionDateCacher timeout + return . Just $ clientSessionBackend2 key getCachedDate defaultLayout widget = do master <- getYesod @@ -172,7 +174,13 @@ -- and names them based on a hash of their content. This allows -- expiration dates to be set far in the future without worry of -- users receiving stale content. - addStaticContent = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute []) + addStaticContent = + addStaticContentExternal minifym genFileName Settings.staticDir (StaticR . flip StaticRoute []) + where + -- Generate a unique filename based on the content itself + genFileName lbs + | development = "autogen-" ++ base64md5 lbs + | otherwise = base64md5 lbs -- Place Javascript at bottom of the body tag so the rest of the page loads first jsLoader _ = BottomOfBody @@ -362,7 +370,7 @@ build-depends: base >= 4 && < 5 -- , yesod-platform >= 1.1 && < 1.2 , yesod >= 1.1.5 && < 1.2 - , yesod-core >= 1.1.5 && < 1.2 + , yesod-core >= 1.1.7 && < 1.2 , yesod-auth >= 1.1 && < 1.2 , yesod-static >= 1.1 && < 1.2 , yesod-default >= 1.1 && < 1.2 @@ -463,6 +471,10 @@ -- | Settings for 'widgetFile', such as which template languages to support and -- default Hamlet settings. +-- +-- For more information on modifying behavior, see: +-- +-- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile widgetFileSettings :: WidgetFileSettings widgetFileSettings = def { wfsHamletSettings = defaultHamletSettings diff --git a/hsfiles/postgres.hsfiles b/hsfiles/postgres.hsfiles --- a/hsfiles/postgres.hsfiles +++ b/hsfiles/postgres.hsfiles @@ -141,7 +141,9 @@ -- default session idle timeout is 120 minutes makeSessionBackend _ = do key <- getKey "config/client_session_key.aes" - return . Just $ clientSessionBackend key 120 + let timeout = 120 * 60 -- 120 minutes + (getCachedDate, _closeDateCache) <- clientSessionDateCacher timeout + return . Just $ clientSessionBackend2 key getCachedDate defaultLayout widget = do master <- getYesod @@ -172,7 +174,13 @@ -- and names them based on a hash of their content. This allows -- expiration dates to be set far in the future without worry of -- users receiving stale content. - addStaticContent = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute []) + addStaticContent = + addStaticContentExternal minifym genFileName Settings.staticDir (StaticR . flip StaticRoute []) + where + -- Generate a unique filename based on the content itself + genFileName lbs + | development = "autogen-" ++ base64md5 lbs + | otherwise = base64md5 lbs -- Place Javascript at bottom of the body tag so the rest of the page loads first jsLoader _ = BottomOfBody @@ -362,7 +370,7 @@ build-depends: base >= 4 && < 5 -- , yesod-platform >= 1.1 && < 1.2 , yesod >= 1.1.5 && < 1.2 - , yesod-core >= 1.1.5 && < 1.2 + , yesod-core >= 1.1.7 && < 1.2 , yesod-auth >= 1.1 && < 1.2 , yesod-static >= 1.1 && < 1.2 , yesod-default >= 1.1 && < 1.2 @@ -463,6 +471,10 @@ -- | Settings for 'widgetFile', such as which template languages to support and -- default Hamlet settings. +-- +-- For more information on modifying behavior, see: +-- +-- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile widgetFileSettings :: WidgetFileSettings widgetFileSettings = def { wfsHamletSettings = defaultHamletSettings diff --git a/hsfiles/simple.hsfiles b/hsfiles/simple.hsfiles --- a/hsfiles/simple.hsfiles +++ b/hsfiles/simple.hsfiles @@ -124,7 +124,9 @@ -- default session idle timeout is 120 minutes makeSessionBackend _ = do key <- getKey "config/client_session_key.aes" - return . Just $ clientSessionBackend key 120 + let timeout = 120 * 60 -- 120 minutes + (getCachedDate, _closeDateCache) <- clientSessionDateCacher timeout + return . Just $ clientSessionBackend2 key getCachedDate defaultLayout widget = do master <- getYesod @@ -152,7 +154,13 @@ -- and names them based on a hash of their content. This allows -- expiration dates to be set far in the future without worry of -- users receiving stale content. - addStaticContent = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute []) + addStaticContent = + addStaticContentExternal minifym genFileName Settings.staticDir (StaticR . flip StaticRoute []) + where + -- Generate a unique filename based on the content itself + genFileName lbs + | development = "autogen-" ++ base64md5 lbs + | otherwise = base64md5 lbs -- Place Javascript at bottom of the body tag so the rest of the page loads first jsLoader _ = BottomOfBody @@ -294,7 +302,7 @@ build-depends: base >= 4 && < 5 -- , yesod-platform >= 1.1 && < 1.2 , yesod >= 1.1.5 && < 1.2 - , yesod-core >= 1.1.5 && < 1.2 + , yesod-core >= 1.1.7 && < 1.2 , yesod-static >= 1.1 && < 1.2 , yesod-default >= 1.1 && < 1.2 , yesod-form >= 1.1 && < 1.3 @@ -385,6 +393,10 @@ -- | Settings for 'widgetFile', such as which template languages to support and -- default Hamlet settings. +-- +-- For more information on modifying behavior, see: +-- +-- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile widgetFileSettings :: WidgetFileSettings widgetFileSettings = def { wfsHamletSettings = defaultHamletSettings diff --git a/hsfiles/sqlite.hsfiles b/hsfiles/sqlite.hsfiles --- a/hsfiles/sqlite.hsfiles +++ b/hsfiles/sqlite.hsfiles @@ -141,7 +141,9 @@ -- default session idle timeout is 120 minutes makeSessionBackend _ = do key <- getKey "config/client_session_key.aes" - return . Just $ clientSessionBackend key 120 + let timeout = 120 * 60 -- 120 minutes + (getCachedDate, _closeDateCache) <- clientSessionDateCacher timeout + return . Just $ clientSessionBackend2 key getCachedDate defaultLayout widget = do master <- getYesod @@ -172,7 +174,13 @@ -- and names them based on a hash of their content. This allows -- expiration dates to be set far in the future without worry of -- users receiving stale content. - addStaticContent = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute []) + addStaticContent = + addStaticContentExternal minifym genFileName Settings.staticDir (StaticR . flip StaticRoute []) + where + -- Generate a unique filename based on the content itself + genFileName lbs + | development = "autogen-" ++ base64md5 lbs + | otherwise = base64md5 lbs -- Place Javascript at bottom of the body tag so the rest of the page loads first jsLoader _ = BottomOfBody @@ -362,7 +370,7 @@ build-depends: base >= 4 && < 5 -- , yesod-platform >= 1.1 && < 1.2 , yesod >= 1.1.5 && < 1.2 - , yesod-core >= 1.1.5 && < 1.2 + , yesod-core >= 1.1.7 && < 1.2 , yesod-auth >= 1.1 && < 1.2 , yesod-static >= 1.1 && < 1.2 , yesod-default >= 1.1 && < 1.2 @@ -463,6 +471,10 @@ -- | Settings for 'widgetFile', such as which template languages to support and -- default Hamlet settings. +-- +-- For more information on modifying behavior, see: +-- +-- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile widgetFileSettings :: WidgetFileSettings widgetFileSettings = def { wfsHamletSettings = defaultHamletSettings diff --git a/yesod.cabal b/yesod.cabal --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 1.1.7.1 +version: 1.1.7.2 license: MIT license-file: LICENSE author: Michael Snoyman @@ -105,7 +105,7 @@ , resourcet >= 0.3 && < 0.5 , base64-bytestring , lifted-base - , http-reverse-proxy >= 0.1.0.4 + , http-reverse-proxy >= 0.1.1 , network , http-conduit , network-conduit