yesod-bin 1.5.3 → 1.6.0
raw patch · 7 files changed
+50/−346 lines, 7 filesdep +unliftiodep −asyncdep −deepseqdep −lifted-basedep ~conduitdep ~conduit-extradep ~resourcet
Dependencies added: unliftio
Dependencies removed: async, deepseq, lifted-base, safe-exceptions
Dependency ranges changed: conduit, conduit-extra, resourcet
Files
- AddHandler.hs +9/−0
- Build.hs +0/−270
- ChangeLog.md +5/−0
- Devel.hs +7/−8
- HsFile.hs +7/−10
- main.hs +16/−49
- yesod-bin.cabal +6/−9
AddHandler.hs view
@@ -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
− Build.hs
@@ -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
ChangeLog.md view
@@ -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
Devel.hs view
@@ -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
HsFile.hs view
@@ -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)
main.hs view
@@ -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-
yesod-bin.cabal view
@@ -1,5 +1,5 @@ name: yesod-bin-version: 1.5.3+version: 1.6.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -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