From 79155103220e192d5eaae83a16866daec59f5ea0 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Tue, 19 Nov 2013 11:24:23 -0800 Subject: [PATCH] hlint & compiler warnings also tried out embeding the refresh file --- .gitignore | 4 ++- yesod-bin/Devel.hs | 62 ++++++++++++++++++++++++++------------------ yesod-bin/Options.hs | 25 +++++++++--------- yesod-bin/main.hs | 3 ++- 4 files changed, 55 insertions(+), 39 deletions(-) diff --git a/.gitignore b/.gitignore index e766dea6..00767768 100644 --- a/.gitignore +++ b/.gitignore @@ -6,7 +6,9 @@ dist client_session_key.aes cabal-dev/ yesod/foobar/ -.virthualenv +.hsenv/ +.cabal-sandbox/ +cabal.sandbox.config /vendor/ /.shelly/ /tarballs/ diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 3cf90d8b..a6b888c7 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -1,14 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +#ifdef EMBED_REFRESH +{-# LANGUAGE TemplateHaskell #-} +#endif module Devel ( devel , DevelOpts(..) , defaultDevelOpts ) where -import Paths_yesod_bin - import qualified Distribution.Compiler as D import qualified Distribution.ModuleName as D import qualified Distribution.PackageDescription as D @@ -24,7 +25,7 @@ import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, tryPutMVar) import qualified Control.Exception as Ex import Control.Monad (forever, unless, void, - when) + when, forM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.State (evalStateT, get) import qualified Data.IORef as I @@ -78,6 +79,11 @@ import Network.Socket (sClose) import Network.Wai (responseLBS) import Network.Wai.Handler.Warp (run) import SrcLoc (Located) +#ifdef EMBED_REFRESH +import Data.FileEmbed (embedFile) +#else +import Paths_yesod_bin +#endif lockFile :: DevelOpts -> FilePath lockFile _opts = "yesod-devel/devel-terminate" @@ -122,7 +128,18 @@ cabalProgram opts | isCabalDev opts = "cabal-dev" reverseProxy :: DevelOpts -> I.IORef Int -> IO () reverseProxy opts iappPort = do manager <- newManager def - let loop = forever $ do +#ifdef EMBED_REFRESH + let refreshHtml = LB.fromStrict $(embedFile "refreshing.html") +#else + refreshHtml <- liftIO $ getDataFileName "refreshing.html" >>= LB.readFile +#endif + let onExc _ _ = return $ responseLBS status200 + [ ("content-type", "text/html") + , ("Refresh", "1") + ] + refreshHtml + + let runProxy = run (develPort opts) $ waiProxyToSettings (const $ do appPort <- liftIO $ I.readIORef iappPort @@ -141,20 +158,13 @@ reverseProxy opts iappPort = do else Just (1000000 * proxyTimeout opts) } manager - putStrLn "Reverse proxy stopped, but it shouldn't" - threadDelay 1000000 - putStrLn "Restarting reverse proxy" - loop `Ex.onException` exitFailure + loop runProxy `Ex.onException` exitFailure where - onExc _ _ = do - refreshing <- liftIO $ getDataFileName "refreshing.html" - html <- liftIO $ LB.readFile refreshing - return $ responseLBS - status200 - [ ("content-type", "text/html") - , ("Refresh", "1") - ] - html + loop proxy = forever $ do + void proxy + putStrLn "Reverse proxy stopped, but it shouldn't" + threadDelay 1000000 + putStrLn "Restarting reverse proxy" checkPort :: Int -> IO Bool checkPort p = do @@ -174,10 +184,12 @@ getPort _ p0 = avail <- checkPort p if avail then return p else loop (succ p) +unlessM :: Monad m => m Bool -> m () -> m () +unlessM c a = c >>= \res -> unless res a + devel :: DevelOpts -> [String] -> IO () devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do - avail <- checkPort $ develPort opts - unless avail $ error "devel port unavailable" + unlessM (checkPort $ develPort opts) $ error "devel port unavailable" iappPort <- getPort opts 17834 >>= I.newIORef when (useReverseProxy opts) $ void $ forkIO $ reverseProxy opts iappPort checkDevelFile @@ -278,8 +290,8 @@ runBuildHook Nothing = return () -} configure :: DevelOpts -> [String] -> IO Bool configure opts extraArgs = - checkExit =<< (createProcess $ proc (cabalProgram opts) - ([ "configure" + checkExit =<< createProcess (proc (cabalProgram opts) $ + [ "configure" , "-flibrary-only" , "-fdevel" , "--disable-library-profiling" @@ -287,7 +299,7 @@ configure opts extraArgs = , "--with-ghc=yesod-ghc-wrapper" , "--with-ar=yesod-ar-wrapper" , "--with-hc-pkg=ghc-pkg" - ] ++ extraArgs) + ] ++ extraArgs ) removeFileIfExists :: FilePath -> IO () @@ -302,7 +314,7 @@ mkRebuild ghcVer cabalFile opts (ldPath, arPath) | GHC.cProjectVersion /= ghcVer = failWith "Yesod has been compiled with a different GHC version, please reinstall" | forceCabal opts = return (rebuildCabal opts) - | otherwise = do + | otherwise = return $ do ns <- mapM (cabalFile `isNewerThan`) [ "yesod-devel/ghcargs.txt", "yesod-devel/arargs.txt", "yesod-devel/ldargs.txt" ] @@ -327,7 +339,7 @@ rebuildCabal opts = do | otherwise = [ "build", "-v0" ] try_ :: forall a. IO a -> IO () -try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return () +try_ x = void (Ex.try x :: IO (Either Ex.SomeException a)) type FileList = Map.Map FilePath EpochTime @@ -335,7 +347,7 @@ getFileList :: [FilePath] -> [FilePath] -> IO FileList getFileList hsSourceDirs extraFiles = do (files, deps) <- getDeps hsSourceDirs let files' = extraFiles ++ files ++ map fst (Map.toList deps) - fmap Map.fromList $ flip mapM files' $ \f -> do + fmap Map.fromList $ forM files' $ \f -> do efs <- Ex.try $ getFileStatus f return $ case efs of Left (_ :: Ex.SomeException) -> (f, 0) diff --git a/yesod-bin/Options.hs b/yesod-bin/Options.hs index c180f31b..62a2aa30 100644 --- a/yesod-bin/Options.hs +++ b/yesod-bin/Options.hs @@ -11,7 +11,7 @@ import Data.Char (isAlphaNum, isSpace, toLower) import Data.List (foldl') import Data.List.Split (splitOn) import qualified Data.Map as M -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) import Data.Monoid import Options.Applicative import Options.Applicative.Types @@ -52,10 +52,10 @@ updateA env key upd a = -- | really simple key/value file reader: x.y = z -> (["x","y"],"z") configLines :: String -> [([String], String)] -configLines = catMaybes . map (mkLine . takeWhile (/='#')) . lines +configLines = mapMaybe (mkLine . takeWhile (/='#')) . lines where trim = let f = reverse . dropWhile isSpace in f . f - mkLine l | (k, ('=':v)) <- break (=='=') l = Just (splitOn "." (trim k), trim v) + mkLine l | (k, '=':v) <- break (=='=') l = Just (splitOn "." (trim k), trim v) | otherwise = Nothing -- | inject the environment into the parser @@ -75,21 +75,22 @@ injectDefaultP env path p@(OptP o) | (Option (FlagReader names a) _) <- o = p <|> if any ((==Just "1") . getEnvValue env path) names then pure a else empty | otherwise = p + where +#if MIN_VERSION_optparse_applicative(0,6,0) + right= ReadM . Right + left = ReadM . Left + either' f g (ReadM x) = either f g x +#else + right = Right + left = Left + either' = either +#endif injectDefaultP env path (MultP p1 p2) = MultP (injectDefaultP env path p1) (injectDefaultP env path p2) injectDefaultP env path (AltP p1 p2) = AltP (injectDefaultP env path p1) (injectDefaultP env path p2) injectDefaultP _env _path b@(BindP {}) = b -#if MIN_VERSION_optparse_applicative(0,6,0) -right = ReadM . Right -left = ReadM . Left -either' f g (ReadM x) = either f g x -#else -right = Right -left = Left -either' = either -#endif getEnvValue :: M.Map [String] String -> [String] -> OptName -> Maybe String getEnvValue env path (OptLong l) = M.lookup (path ++ [normalizeName l]) env diff --git a/yesod-bin/main.hs b/yesod-bin/main.hs index f0f4e4b0..f4016523 100755 --- a/yesod-bin/main.hs +++ b/yesod-bin/main.hs @@ -15,9 +15,10 @@ import Options (injectDefaults) import qualified Paths_yesod_bin import Scaffolding.Scaffolder -import Options.Applicative.Builder.Internal (Mod, OptionFields) #if MIN_VERSION_optparse_applicative(0,6,0) import Options.Applicative.Types (ReadM (ReadM)) +#else +import Options.Applicative.Builder.Internal (Mod, OptionFields) #endif #ifndef WINDOWS