diff --git a/AddHandler.hs b/AddHandler.hs --- a/AddHandler.hs +++ b/AddHandler.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module AddHandler (addHandler) where @@ -8,7 +9,11 @@ import Data.Maybe (fromMaybe, listToMaybe) import qualified Data.Text as T import qualified Data.Text.IO as TIO +#if MIN_VERSION_Cabal(2, 0, 0) +import Distribution.PackageDescription.Parse (readGenericPackageDescription) +#else import Distribution.PackageDescription.Parse (readPackageDescription) +#endif import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.PackageDescription (allBuildInfo, hsSourceDirs) import Distribution.Verbosity (normal) @@ -224,7 +229,11 @@ getSrcDir :: FilePath -> IO FilePath getSrcDir cabal = do +#if MIN_VERSION_Cabal(2, 0, 0) + pd <- flattenPackageDescription <$> readGenericPackageDescription normal cabal +#else pd <- flattenPackageDescription <$> readPackageDescription normal cabal +#endif let buildInfo = allBuildInfo pd srcDirs = concatMap hsSourceDirs buildInfo return $ fromMaybe "." $ listToMaybe srcDirs diff --git a/Build.hs b/Build.hs deleted file mode 100644 --- a/Build.hs +++ /dev/null @@ -1,270 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -module Build - ( getDeps - , touchDeps - , touch - , recompDeps - , isNewerThan - , safeReadFile - ) where - -import Control.Applicative as App ((<|>), many, (<$>)) -import qualified Data.Attoparsec.Text as A -import Data.Char (isSpace, isUpper) -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, 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 (MonadIO, liftIO) -import Control.Monad.Trans.Class (lift) - -import Data.Monoid (Monoid (..)) -import qualified Data.Map as Map -import qualified Data.Set as Set - -import qualified System.Posix.Types -import System.Directory -import System.FilePath (takeExtension, replaceExtension, (), takeDirectory, - splitPath, joinPath) -import System.PosixCompat.Files (getFileStatus, setFileTimes, - accessTime, modificationTime) - -import Text.Shakespeare (Deref) -import Text.Julius (juliusUsedIdentifiers) -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 - x <- fmap snd (getDeps []) - m' <- execStateT (execWriterT $ touchDeps id updateFileTime x) m - createDirectoryIfMissing True $ takeDirectory touchCache - writeFile touchCache $ show m' - where - touchCache = "dist/touchCache.txt" - --- | Returns True if any files were touched, otherwise False -recompDeps :: [FilePath] -> StateT (Map.Map FilePath (Set.Set Deref)) IO Bool -recompDeps = - fmap toBool . execWriterT . (liftIO . getDeps >=> touchDeps hiFile removeHi . snd) - where - toBool NoFilesTouched = False - toBool SomeFilesTouched = True - -type Deps = Map.Map FilePath ([FilePath], ComparisonType) - -getDeps :: [FilePath] -> IO ([FilePath], Deps) -getDeps hsSourceDirs = do - let defSrcDirs = case hsSourceDirs of - [] -> ["."] - ds -> ds - hss <- fmap concat $ mapM findHaskellFiles defSrcDirs - deps' <- mapM determineDeps hss - return $ (hss, fixDeps $ zip hss deps') - -data AnyFilesTouched = NoFilesTouched | SomeFilesTouched -instance Data.Monoid.Monoid AnyFilesTouched where - mempty = NoFilesTouched - mappend NoFilesTouched NoFilesTouched = mempty - mappend _ _ = SomeFilesTouched - -touchDeps :: (FilePath -> FilePath) -> - (FilePath -> FilePath -> IO ()) -> - Deps -> WriterT AnyFilesTouched (StateT (Map.Map FilePath (Set.Set Deref)) IO) () -touchDeps f action deps = (mapM_ go . Map.toList) deps - where - go (x, (ys, ct)) = do - isChanged <- handle (\(_ :: SomeException) -> return True) $ lift $ - case ct of - AlwaysOutdated -> return True - CompareUsedIdentifiers getDerefs -> do - derefMap <- get - 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 - _ -> return True - when isChanged $ forM_ ys $ \y -> do - n <- liftIO $ x `isNewerThan` f y - when n $ do - liftIO $ putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x) - liftIO $ action x y - tell SomeFilesTouched - --- | remove the .hi files for a .hs file, thereby forcing a recompile -removeHi :: FilePath -> FilePath -> IO () -removeHi _ hs = mapM_ removeFile' hiFiles - where - removeFile' file = try' (removeFile file) >> return () - hiFiles = map (\e -> "dist/build" removeSrc (replaceExtension hs e)) - ["hi", "p_hi"] - --- | change file mtime of .hs file to that of the dependency -updateFileTime :: FilePath -> FilePath -> IO () -updateFileTime x hs = do - (_ , modx) <- getFileStatus' x - (access, _ ) <- getFileStatus' hs - _ <- try' (setFileTimes hs access modx) - return () - -hiFile :: FilePath -> FilePath -hiFile hs = "dist/build" removeSrc (replaceExtension hs "hi") - -removeSrc :: FilePath -> FilePath -removeSrc f = case splitPath f of - ("src/" : xs) -> joinPath xs - _ -> f - -try' :: IO x -> IO (Either SomeException x) -try' = try - -isNewerThan :: FilePath -> FilePath -> IO Bool -isNewerThan f1 f2 = do - (_, mod1) <- getFileStatus' f1 - (_, mod2) <- getFileStatus' f2 - return (mod1 > mod2) - -getFileStatus' :: FilePath -> - IO (System.Posix.Types.EpochTime, System.Posix.Types.EpochTime) -getFileStatus' fp = do - efs <- try' $ getFileStatus fp - case efs of - Left _ -> return (0, 0) - Right fs -> return (accessTime fs, modificationTime fs) - -fixDeps :: [(FilePath, [(ComparisonType, FilePath)])] -> Deps -fixDeps = - Map.unionsWith combine . map go - where - go :: (FilePath, [(ComparisonType, FilePath)]) -> Deps - go (x, ys) = Map.fromList $ map (\(ct, y) -> (y, ([x], ct))) ys - - combine (ys1, ct) (ys2, _) = (ys1 `mappend` ys2, ct) - -findHaskellFiles :: FilePath -> IO [FilePath] -findHaskellFiles path = do - contents <- getDirectoryContents path - fmap concat $ mapM go contents - where - go ('.':_) = return [] - go filename = do - d <- doesDirectoryExist full - if not d - then if isHaskellFile - then return [full] - else return [] - else if isHaskellDir - then findHaskellFiles full - else return [] - where - -- this could fail on unicode - isHaskellDir = isUpper (head filename) - isHaskellFile = takeExtension filename `elem` watch_files - full = path filename - watch_files = [".hs", ".lhs"] - -data TempType = StaticFiles FilePath - | Verbatim | Messages FilePath | Hamlet | Widget | Julius | Cassius | Lucius - deriving Show - --- | How to tell if a file is outdated. -data ComparisonType = AlwaysOutdated - | CompareUsedIdentifiers (String -> [Deref]) - -determineDeps :: FilePath -> IO [(ComparisonType, FilePath)] -determineDeps x = do - 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) App.<$> getFolderContents fp - go (Just (Hamlet, f)) = return [(AlwaysOutdated, f)] - go (Just (Widget, f)) = return - [ (AlwaysOutdated, "templates/" ++ f ++ ".hamlet") - , (CompareUsedIdentifiers $ map fst . juliusUsedIdentifiers, "templates/" ++ f ++ ".julius") - , (CompareUsedIdentifiers $ map fst . luciusUsedIdentifiers, "templates/" ++ f ++ ".lucius") - , (CompareUsedIdentifiers $ map fst . cassiusUsedIdentifiers, "templates/" ++ f ++ ".cassius") - ] - go (Just (Julius, f)) = return [(CompareUsedIdentifiers $ map fst . juliusUsedIdentifiers, f)] - go (Just (Cassius, f)) = return [(CompareUsedIdentifiers $ map fst . cassiusUsedIdentifiers, f)] - go (Just (Lucius, f)) = return [(CompareUsedIdentifiers $ map fst . luciusUsedIdentifiers, f)] - go (Just (Verbatim, f)) = return [(AlwaysOutdated, f)] - go (Just (Messages f, _)) = map ((,) AlwaysOutdated) <$> getFolderContents f - go Nothing = return [] - - parser = do - ty <- (do _ <- A.string "\nstaticFiles \"" - x' <- A.many1 $ A.satisfy (/= '"') - return $ StaticFiles x') - <|> (A.string "$(parseRoutesFile " >> return Verbatim) - <|> (A.string "$(hamletFile " >> return Hamlet) - <|> (A.string "$(ihamletFile " >> return Hamlet) - <|> (A.string "$(whamletFile " >> return Hamlet) - <|> (A.string "$(html " >> return Hamlet) - <|> (A.string "$(widgetFile " >> return Widget) - <|> (A.string "$(Settings.hamletFile " >> return Hamlet) - <|> (A.string "$(Settings.widgetFile " >> return Widget) - <|> (A.string "$(juliusFile " >> return Julius) - <|> (A.string "$(cassiusFile " >> return Cassius) - <|> (A.string "$(luciusFile " >> return Lucius) - <|> (A.string "$(persistFile " >> return Verbatim) - <|> ( - A.string "$(persistFileWith " >> - A.many1 (A.satisfy (/= '"')) >> - return Verbatim) - <|> (do - _ <- A.string "\nmkMessage \"" - A.skipWhile (/= '"') - _ <- A.string "\" \"" - x' <- A.many1 $ A.satisfy (/= '"') - _ <- A.string "\" \"" - _y <- A.many1 $ A.satisfy (/= '"') - _ <- A.string "\"" - return $ Messages x') - case ty of - Messages{} -> return $ Just (ty, "") - StaticFiles{} -> return $ Just (ty, "") - _ -> do - A.skipWhile isSpace - _ <- A.char '"' - y <- A.many1 $ A.satisfy (/= '"') - _ <- A.char '"' - A.skipWhile isSpace - _ <- A.char ')' - return $ Just (ty, y) - - getFolderContents :: FilePath -> IO [FilePath] - getFolderContents fp = do - cs <- getDirectoryContents fp - let notHidden ('.':_) = False - notHidden ('t':"mp") = False - notHidden ('f':"ay") = False - notHidden _ = True - fmap concat $ forM (filter notHidden cs) $ \c -> do - let f = fp ++ '/' : c - isFile <- doesFileExist f - if isFile then return [f] else getFolderContents f diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 1.6.0 + +* Upgrade to conduit 1.3.0 +* Remove configure, build, touch, and test commands + ## 1.5.3 * Support typed-process-0.2.0.0 diff --git a/Devel.hs b/Devel.hs --- a/Devel.hs +++ b/Devel.hs @@ -9,17 +9,15 @@ ) where import Control.Applicative ((<|>)) +import UnliftIO (race_) import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (race_) import Control.Concurrent.STM -import qualified Control.Exception.Safe as Ex +import qualified UnliftIO.Exception as Ex import Control.Monad (forever, unless, void, when) import Data.ByteString (ByteString, isInfixOf) import qualified Data.ByteString.Lazy as LB -import Data.Conduit (($$), (=$)) -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.List as CL +import Conduit import Data.Default.Class (def) import Data.FileEmbed (embedFile) import qualified Data.Map as Map @@ -368,9 +366,10 @@ -- process is piped to the actual stdout and stderr handles. withProcess_ procConfig $ \p -> do let helper getter h = - getter p - $$ CL.iterM (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar)) - =$ CB.sinkHandle h + runConduit + $ getter p + .| iterMC (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar)) + .| sinkHandle h race_ (helper getStdout stdout) (helper getStderr stderr) -- Run the inner action with a TVar which will be set to True diff --git a/HsFile.hs b/HsFile.hs --- a/HsFile.hs +++ b/HsFile.hs @@ -2,20 +2,17 @@ {-# LANGUAGE OverloadedStrings #-} module HsFile (mkHsFile) where import Text.ProjectTemplate (createTemplate) -import Data.Conduit - ( ($$), (=$), awaitForever) -import Data.Conduit.Filesystem (sourceDirectory) -import Control.Monad.Trans.Resource (runResourceT) -import qualified Data.Conduit.List as CL +import Conduit import qualified Data.ByteString as BS import Control.Monad.IO.Class (liftIO) import Data.String (fromString) mkHsFile :: IO () -mkHsFile = runResourceT $ sourceDirectory "." - $$ readIt - =$ createTemplate - =$ awaitForever (liftIO . BS.putStr) +mkHsFile = runConduitRes + $ sourceDirectory "." + .| readIt + .| createTemplate + .| mapM_C (liftIO . BS.putStr) where -- Reads a filepath from upstream and dumps a pair of (filepath, filecontents) - readIt = CL.map $ \i -> (fromString i, liftIO $ BS.readFile i) + readIt = mapC $ \i -> (fromString i, liftIO $ BS.readFile i) diff --git a/main.hs b/main.hs --- a/main.hs +++ b/main.hs @@ -2,38 +2,19 @@ {-# LANGUAGE RecordWildCards #-} module Main (main) where -import Control.Monad (unless) import Data.Monoid import Data.Version (showVersion) import Options.Applicative -import System.Environment (getEnvironment) -import System.Exit (ExitCode (ExitSuccess), exitWith, exitFailure) -import System.Process (rawSystem) +import System.Exit (exitFailure) import AddHandler (addHandler) import Devel (DevelOpts (..), devel, develSignal) import Keter (keter) import Options (injectDefaults) import qualified Paths_yesod_bin -import System.IO (hPutStrLn, stderr) import HsFile (mkHsFile) -#ifndef WINDOWS -import Build (touch) -touch' :: IO () -touch' = touch - -windowsWarning :: String -windowsWarning = "" -#else -touch' :: IO () -touch' = return () - -windowsWarning :: String -windowsWarning = " (does not work on Windows)" -#endif - data CabalPgm = Cabal | CabalDev deriving (Show, Eq) data Options = Options @@ -91,17 +72,16 @@ c -> c }) ] optParser' - let cabal = rawSystem' (cabalCommand o) case optCommand o of Init _ -> initErrorMsg HsFiles -> mkHsFile - Configure -> cabal ["configure"] - Build es -> touch' >> cabal ("build":es) - Touch -> touch' + Configure -> cabalErrorMsg + Build _ -> cabalErrorMsg + Touch -> cabalErrorMsg Keter{..} -> keter (cabalCommand o) _keterNoRebuild _keterNoCopyTo _keterBuildArgs Version -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version) AddHandler{..} -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods - Test -> cabalTest cabal + Test -> cabalErrorMsg Devel{..} -> devel DevelOpts { verbose = optVerbose o , successHook = develSuccessHook @@ -113,19 +93,6 @@ } develExtraArgs DevelSignal -> develSignal where - cabalTest cabal = do - env <- getEnvironment - case lookup "STACK_EXE" env of - Nothing -> do - touch' - _ <- cabal ["configure", "--enable-tests", "-flibrary-only"] - _ <- cabal ["build"] - cabal ["test"] - Just _ -> do - hPutStrLn stderr "'yesod test' is no longer needed with Stack" - hPutStrLn stderr "Instead, please just run 'stack test'" - exitFailure - initErrorMsg = do mapM_ putStrLn [ "The init command has been removed." @@ -136,6 +103,13 @@ ] exitFailure + cabalErrorMsg = do + mapM_ putStrLn + [ "The configure, build, touch, and test commands have been removed." + , "Please use 'stack' for building your project." + ] + exitFailure + optParser' :: ParserInfo Options optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" ) @@ -148,17 +122,17 @@ <> command "hsfiles" (info (pure HsFiles) (progDesc "Create a hsfiles file for the current folder")) <> command "configure" (info (pure Configure) - (progDesc "Configure a project for building")) + (progDesc "DEPRECATED")) <> command "build" (info (helper <*> (Build <$> extraCabalArgs)) - (progDesc $ "Build project (performs TH dependency analysis)" ++ windowsWarning)) + (progDesc "DEPRECATED")) <> command "touch" (info (pure Touch) - (progDesc $ "Touch any files with altered TH dependencies but do not build" ++ windowsWarning)) + (progDesc "DEPRECATED")) <> command "devel" (info (helper <*> develOptions) (progDesc "Run project with the devel server")) <> command "devel-signal" (info (helper <*> pure DevelSignal) (progDesc "Used internally by the devel command")) <> command "test" (info (pure Test) - (progDesc "Build and run the integration tests")) + (progDesc "DEPRECATED")) <> command "add-handler" (info (helper <*> addHandlerOptions) (progDesc ("Add a new handler and module to the project." ++ " Interactively asks for input if you do not specify arguments."))) @@ -217,10 +191,3 @@ -- | Optional @String@ argument optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String) optStr m = option (Just <$> str) $ value Nothing <> m - --- | Like @rawSystem@, but exits if it receives a non-success result. -rawSystem' :: String -> [String] -> IO () -rawSystem' x y = do - res <- rawSystem x y - unless (res == ExitSuccess) $ exitWith res - diff --git a/yesod-bin.cabal b/yesod-bin.cabal --- a/yesod-bin.cabal +++ b/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.5.3 +version: 1.6.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -48,17 +48,16 @@ , fsnotify >= 0.0 && < 0.3 , split >= 0.2 && < 0.3 , file-embed - , conduit >= 1.2 - , conduit-extra >= 1.2.2 - , resourcet >= 0.3 && < 1.2 + , conduit >= 1.3 + , conduit-extra >= 1.3 + , resourcet >= 1.2 , base64-bytestring - , lifted-base , http-reverse-proxy >= 0.4 , network >= 2.5 , http-client-tls , http-client >= 0.4.7 , project-template >= 0.1.1 - , safe-exceptions + , unliftio , say , stm , transformers @@ -69,13 +68,11 @@ , data-default-class , streaming-commons , warp-tls >= 3.0.1 - , async - , deepseq + , unliftio ghc-options: -Wall -threaded -rtsopts main-is: main.hs other-modules: Devel - Build Keter AddHandler Paths_yesod_bin