yesod-bin-1.4.18.7/0000755000000000000000000000000012775725517012053 5ustar0000000000000000yesod-bin-1.4.18.7/AddHandler.hs0000644000000000000000000001526712775725517014410 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} module AddHandler (addHandler) where import Prelude hiding (readFile) import System.IO (hFlush, stdout) import Data.Char (isLower, toLower, isSpace) import Data.List (isPrefixOf, isSuffixOf, stripPrefix) import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.IO as TIO import System.Directory (getDirectoryContents, doesFileExist) import Control.Monad (unless) data RouteError = EmptyRoute | RouteCaseError | RouteExists FilePath deriving Eq instance Show RouteError where show EmptyRoute = "No name entered. Quitting ..." show RouteCaseError = "Name must start with an upper case letter" show (RouteExists file) = "File already exists: " ++ file -- strict readFile readFile :: FilePath -> IO String readFile = fmap T.unpack . TIO.readFile cmdLineArgsError :: String cmdLineArgsError = "You have to specify a route name if you want to add handler with command line arguments." addHandler :: Maybe String -> Maybe String -> [String] -> IO () addHandler (Just route) pat met = do cabal <- getCabal checked <- checkRoute route let routePair = case checked of Left err@EmptyRoute -> (error . show) err Left err@RouteCaseError -> (error . show) err Left err@(RouteExists _) -> (error . show) err Right p -> p addHandlerFiles cabal routePair pattern methods where pattern = fromMaybe "" pat -- pattern defaults to "" methods = unwords met -- methods default to none addHandler Nothing (Just _) _ = error cmdLineArgsError addHandler Nothing _ (_:_) = error cmdLineArgsError addHandler _ _ _ = addHandlerInteractive addHandlerInteractive :: IO () addHandlerInteractive = do cabal <- getCabal let routeInput = do putStr "Name of route (without trailing R): " hFlush stdout name <- getLine checked <- checkRoute name case checked of Left err@EmptyRoute -> (error . show) err Left err@RouteCaseError -> print err >> routeInput Left err@(RouteExists _) -> do print err putStrLn "Try another name or leave blank to exit" routeInput Right p -> return p routePair <- routeInput putStr "Enter route pattern (ex: /entry/#EntryId): " hFlush stdout pattern <- getLine putStr "Enter space-separated list of methods (ex: GET POST): " hFlush stdout methods <- getLine addHandlerFiles cabal routePair pattern methods addHandlerFiles :: FilePath -> (String, FilePath) -> String -> String -> IO () addHandlerFiles cabal (name, handlerFile) pattern methods = do modify "Application.hs" $ fixApp name modify cabal $ fixCabal name modify "config/routes" $ fixRoutes name pattern methods writeFile handlerFile $ mkHandler name pattern methods specExists <- doesFileExist specFile unless specExists $ writeFile specFile $ mkSpec name pattern methods where specFile = "test/Handler/" ++ name ++ "Spec.hs" modify fp f = readFile fp >>= writeFile fp . f getCabal :: IO FilePath getCabal = do allFiles <- getDirectoryContents "." case filter (".cabal" `isSuffixOf`) allFiles of [x] -> return x [] -> error "No cabal file found" _ -> error "Too many cabal files found" checkRoute :: String -> IO (Either RouteError (String, FilePath)) checkRoute name = case name of [] -> return $ Left EmptyRoute c:_ | isLower c -> return $ Left RouteCaseError | otherwise -> do -- Check that the handler file doesn't already exist let handlerFile = concat ["Handler/", name, ".hs"] exists <- doesFileExist handlerFile if exists then (return . Left . RouteExists) handlerFile else return $ Right (name, handlerFile) fixApp :: String -> String -> String fixApp name = unlines . reverse . go . reverse . lines where l spaces = "import " ++ spaces ++ "Handler." ++ name go [] = [l ""] go (x:xs) | Just y <- stripPrefix "import " x, "Handler." `isPrefixOf` dropWhile (== ' ') y = l (takeWhile (== ' ') y) : x : xs | otherwise = x : go xs fixCabal :: String -> String -> String fixCabal name orig = unlines $ (reverse $ go $ reverse libraryLines) ++ restLines where origLines = lines orig (libraryLines, restLines) = break isExeTestBench origLines isExeTestBench x = any (\prefix -> prefix `isPrefixOf` x) [ "executable" , "test-suite" , "benchmark" ] l = " Handler." ++ name go [] = [l] go (x:xs) | "Handler." `isPrefixOf` x' = (spaces ++ "Handler." ++ name) : x : xs | otherwise = x : go xs where (spaces, x') = span isSpace x fixRoutes :: String -> String -> String -> String -> String fixRoutes name pattern methods fileContents = fileContents ++ l where l = concat [ startingCharacter , pattern , " " , name , "R " , methods , "\n" ] startingCharacter = if "\n" `isSuffixOf` fileContents then "" else "\n" mkSpec :: String -> String -> String -> String mkSpec name _ methods = unlines $ ("module Handler." ++ name ++ "Spec (spec) where") : "" : "import TestImport" : "" : "spec :: Spec" : "spec = withApp $ do" : concatMap go (words methods) where go method = [ "" , " describe \"" ++ func ++ "\" $ do" , " error \"Spec not implemented: " ++ func ++ "\"" , ""] where func = concat [map toLower method, name, "R"] mkHandler :: String -> String -> String -> String mkHandler name pattern methods = unlines $ ("module Handler." ++ name ++ " where") : "" : "import Import" : concatMap go (words methods) where go method = [ "" , concat $ func : " :: " : map toArrow types ++ ["Handler Html"] , concat [ func , " " , concatMap toArgument types , "= error \"Not yet implemented: " , func , "\"" ] ] where func = concat [map toLower method, name, "R"] types = getTypes pattern toArrow t = concat [t, " -> "] toArgument t = concat [uncapitalize t, " "] getTypes "" = [] getTypes ('/':rest) = getTypes rest getTypes (c:rest) | c `elem` "#*" = typ : getTypes rest' where (typ, rest') = break (== '/') rest getTypes rest = getTypes $ dropWhile (/= '/') rest uncapitalize :: String -> String uncapitalize (x:xs) = toLower x : xs uncapitalize "" = "" yesod-bin-1.4.18.7/Build.hs0000644000000000000000000002516712775725517013461 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} module Build ( getDeps , touchDeps , touch , recompDeps , isNewerThan , safeReadFile ) where import Control.Applicative ((<|>), 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 (mappend, mempty)) 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 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) <$> 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 yesod-bin-1.4.18.7/certificate.pem0000644000000000000000000000155312775725517015044 0ustar0000000000000000-----BEGIN CERTIFICATE----- MIICWDCCAcGgAwIBAgIJAJG1ZMlcMDW6MA0GCSqGSIb3DQEBBQUAMEUxCzAJBgNV BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX aWRnaXRzIFB0eSBMdGQwHhcNMTExMDIyMTk0MjU3WhcNMTExMTIxMTk0MjU3WjBF MQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50 ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB gQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCdthgTK66SPXkx EXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cDJSSGK11eQEVs +p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQABo1AwTjAdBgNV HQ4EFgQUaA6FbOj/0VJMb4egNyIDZ/ZNV/YwHwYDVR0jBBgwFoAUaA6FbOj/0VJM b4egNyIDZ/ZNV/YwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0BAQUFAAOBgQCTQyOk D86Z+yzedXjTLI6FT8QugmQne1YQ8P0w37P76z2reagSvNee2e9B1oTHoPeKZMs0 k99oS9yJ/NOQ1Ms90P+q0yBVGxAs/gF65qKgE27YGXzNtNobj/D4OoxcFG+BsORw VvYSBV4FiVy9RwJsr7AMqkUBcOEPCuJHgTx58w== -----END CERTIFICATE----- yesod-bin-1.4.18.7/ChangeLog.md0000644000000000000000000000752612775725517014236 0ustar0000000000000000## 1.4.18.7 * Actually release the changes for #1284 ## 1.4.18.6 * Fix support for GHC 8.0.1 [#1284](https://github.com/yesodweb/yesod/issues/1284) ## 1.4.18.5 * yesod-bin: Make it build with latest optparse-applicative [#1282](https://github.com/yesodweb/yesod/pull/1282) ## 1.4.18.4 * Link yesod-bin with wxneeded on OpenBSD. [#1281](https://github.com/yesodweb/yesod/pull/1281) ## 1.4.18.3 * Adding a new handler adds it under wrong stanza [#1273](https://github.com/yesodweb/yesod/issues/1273) ## 1.4.18.2 * Work around change in behavior in newer optparse-applicative ([mailing list discussion](https://groups.google.com/d/msg/yesodweb/BrTkMKFREgU/AKVc9AK2AQAJ)) ## 1.4.18.1 * error handling when checking for stack binary [#1219](https://github.com/yesodweb/yesod/pull/1219) * GHC 8 support ## 1.4.18 * Disable `yesod test` when using Stack [#1198](https://github.com/yesodweb/yesod/issues/1198) ## 1.4.17 * Fully remove the `yesod init` command ## 1.4.16.1 * Workaround for [wai#478](https://github.com/yesodweb/wai/issues/478) ## 1.4.16 * Some updates for better reverse proxying [yesod-scaffold#114](https://github.com/yesodweb/yesod-scaffold/issues/114) ## 1.4.15 * Deprecate yesod init ## 1.4.14 * Fix order of -package-db arguments to runghc [#1057](https://github.com/yesodweb/yesod/issues/1057) ## 1.4.13 * Enable stack with yesod keter [#1041](https://github.com/yesodweb/yesod/pull/1041) ## 1.4.12 * Devel server: have to type quit to quit ## 1.4.11 * Add support to `yesod devel` to detect and use `GHC_PACKAGE_PATH`. This makes `yesod devel` compatible with `stack`, just run: `stack exec -- yesod devel`. ## 1.4.10 * Scaffolding update ## 1.4.9.2 * Collapse paths in keter bundles, see [mailing list thread](https://groups.google.com/d/msg/yesodweb/Ndd310qfSEc/pZOXldsKowsJ) ## 1.4.9 * Command line options for `yesod init` [#986](https://github.com/yesodweb/yesod/pull/986) ## 1.4.8 * Drop system-filepath ## 1.4.7.2 * Scaffolding updates, including fix for [#982](https://github.com/yesodweb/yesod/issues/982) ## 1.4.7 * GHC 7.10 support ## 1.4.6 * Add TLS support to `yesod devel` [#964](https://github.com/yesodweb/yesod/pull/964) ## 1.4.5 * add a switch to yesod to skip deploying a .keter with copy-to [#952](https://github.com/yesodweb/yesod/issues/952) ## 1.4.4 * Add and process Keter option 'extraFiles' [#947](https://github.com/yesodweb/yesod/pull/947) ## 1.4.3.11 * Disregard proxy environment variables in yesod devel [#945](https://github.com/yesodweb/yesod/pull/945) ## 1.4.3.10 * Allow blaze-builder 0.4 ## 1.4.3.9 * Scaffold update: minimal scaffold uses yesod-core instead of yesod [yesodweb/yesod-scaffold#65](https://github.com/yesodweb/yesod-scaffold/issues/65) ## 1.4.3.8 * Scaffold update: fix 404 for missing sourcemap ## 1.4.3.6 * Scaffold update: use `addToken` instead of `addNonce` ## 1.4.3.5 * Fix add-handler putting two routes on one line [#922](https://github.com/yesodweb/yesod/pull/922) ## 1.4.3.4 Scaffolding updates: * Improve `DevelMain` support * Wipe out database during test runs * Convenience `unsafeHandler` function * Remove deprecated Chrome Frame code ## 1.4.3.3 More consistent whitespace in hamlet files in scaffolding [#50](https://github.com/yesodweb/yesod-scaffold/issues/50) ## 1.4.3.2 add-handler adds arguments too [#898](https://github.com/yesodweb/yesod/issues/898) ## 1.4.3 Add the minimal scaffolding ## 1.4.2 Scaffolding updates: * Import.NoFoundation * Explanation of static files in Settings.StaticFiles * Explanation of environment variables in settings.yml ## 1.4.1.2 No args passed in keter.yml ## 1.4.1 Significant update to the scaffolding. ## 1.4.0.9 Allow devel.hs to be located in app/ or src/ subdirectories. ## 1.4.0.8 Updated postgres-fay scaffolding for yesod-fay 0.7.0 ## 1.4.0.7 Fix a bug in `yesod devel` when cabal config has `tests: True` #864 yesod-bin-1.4.18.7/Devel.hs0000644000000000000000000005754112775725517013462 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Devel ( devel , DevelOpts(..) , DevelTermOpt(..) , defaultDevelOpts ) where import qualified Distribution.Compiler as D import qualified Distribution.ModuleName as D import qualified Distribution.PackageDescription as D import qualified Distribution.PackageDescription.Parse as D import qualified Distribution.Simple.Configure as D import qualified Distribution.Simple.Program as D import qualified Distribution.Simple.Utils as D import qualified Distribution.Verbosity as D import Control.Applicative ((<$>), (<*>)) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, tryPutMVar) import Control.Concurrent.Async (race_) import qualified Control.Exception as Ex import Control.Monad (forever, unless, void, when, forM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.State (evalStateT, get) import qualified Data.IORef as I import qualified Data.ByteString.Lazy as LB 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 System.Directory import System.Environment (getEnvironment) import System.Exit (ExitCode (..), exitFailure, exitSuccess) import System.FilePath (dropExtension, splitDirectories, takeExtension, ()) import System.FSNotify import System.IO (Handle) import System.IO.Error (isDoesNotExistError) import System.Posix.Types (EpochTime) import System.PosixCompat.Files (getFileStatus, modificationTime) import System.Process (ProcessHandle, createProcess, env, getProcessExitCode, proc, readProcess, system, terminateProcess) import System.Timeout (timeout) import Build (getDeps, isNewerThan, recompDeps) import GhcBuild (buildPackage, getBuildFlags, getPackageArgs) import qualified Config as GHC import Data.Streaming.Network (bindPortTCP) import Network (withSocketsDo) import Network.HTTP.Conduit (conduitManagerSettings, newManager) import Data.Default.Class (def) #if MIN_VERSION_http_client(0,4,7) import Network.HTTP.Client (managerSetProxy, noProxy) #endif import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest), waiProxyToSettings, wpsTimeout, wpsOnExc) import qualified Network.HTTP.ReverseProxy as ReverseProxy import Network.HTTP.Types (status200, status503) import Network.Socket (sClose) import Network.Wai (responseLBS, requestHeaders, requestHeaderHost) import Network.Wai.Parse (parseHttpAccept) import Network.Wai.Handler.Warp (run, defaultSettings, setPort) import Network.Wai.Handler.WarpTLS (runTLS, tlsSettingsMemory) import SrcLoc (Located) import Data.FileEmbed (embedFile) lockFile :: FilePath lockFile = "yesod-devel/devel-terminate" writeLock :: DevelOpts -> IO () writeLock _opts = do createDirectoryIfMissing True "yesod-devel" writeFile lockFile "" createDirectoryIfMissing True "dist" -- for compatibility with old devel.hs writeFile "dist/devel-terminate" "" removeLock :: DevelOpts -> IO () removeLock _opts = do removeFileIfExists lockFile removeFileIfExists "dist/devel-terminate" -- for compatibility with old devel.hs data DevelTermOpt = TerminateOnEnter | TerminateOnlyInterrupt deriving (Show, Eq) data DevelOpts = DevelOpts { isCabalDev :: Bool , forceCabal :: Bool , verbose :: Bool , eventTimeout :: Int -- negative value for no timeout , successHook :: Maybe String , failHook :: Maybe String , buildDir :: Maybe String , develPort :: Int , develTlsPort :: Int , proxyTimeout :: Int , useReverseProxy :: Bool , terminateWith :: DevelTermOpt -- Support for GHC_PACKAGE_PATH wrapping , develConfigOpts :: [String] , develEnv :: Maybe [(String, String)] } deriving (Show, Eq) getBuildDir :: DevelOpts -> String getBuildDir opts = fromMaybe "dist" (buildDir opts) defaultDevelOpts :: DevelOpts defaultDevelOpts = DevelOpts { isCabalDev = False , forceCabal = False , verbose = False , eventTimeout = -1 , successHook = Nothing , failHook = Nothing , buildDir = Nothing , develPort = 3000 , develTlsPort = 3443 , proxyTimeout = 10 , useReverseProxy = True , terminateWith = TerminateOnEnter , develConfigOpts = [] , develEnv = Nothing } cabalProgram :: DevelOpts -> FilePath cabalProgram opts | isCabalDev opts = "cabal-dev" | otherwise = "cabal" -- | 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 -> I.IORef Int -> IO () reverseProxy opts iappPort = do #if MIN_VERSION_http_client(0,4,7) manager <- newManager $ managerSetProxy noProxy conduitManagerSettings #else manager <- newManager conduitManagerSettings #endif let refreshHtml = LB.fromChunks $ return $(embedFile "refreshing.html") let onExc _ req | maybe False (("application/json" `elem`) . parseHttpAccept) (lookup "accept" $ requestHeaders req) = return $ responseLBS status503 [ ("Retry-After", "1") ] "{\"message\":\"Recompiling\"}" | otherwise = return $ responseLBS status200 [ ("content-type", "text/html") , ("Refresh", "1") ] refreshHtml let proxyApp = waiProxyToSettings (const $ do appPort <- liftIO $ I.readIORef iappPort return $ ReverseProxy.WPRProxyDest $ ProxyDest "127.0.0.1" appPort) def { wpsOnExc = \e req f -> onExc e req >>= f , wpsTimeout = if proxyTimeout opts == 0 then Nothing else Just (1000000 * proxyTimeout opts) } manager runProxyTls port app = do let cert = $(embedFile "certificate.pem") key = $(embedFile "key.pem") tlsSettings = tlsSettingsMemory cert key runTLS tlsSettings (setPort port defaultSettings) $ \req send -> do let req' = req { requestHeaders = ("X-Forwarded-Proto", "https") -- Workaround for -- https://github.com/yesodweb/wai/issues/478, where -- the Host headers aren't set. Without this, generated -- URLs from guestApproot are incorrect, see: -- https://github.com/yesodweb/yesod-scaffold/issues/114 : (case lookup "host" (requestHeaders req) of Nothing -> case requestHeaderHost req of Just host -> (("Host", host):) Nothing -> id Just _ -> id) (requestHeaders req) } app req' send httpProxy = run (develPort opts) proxyApp httpsProxy = runProxyTls (develTlsPort opts) proxyApp putStrLn "Application can be accessed at:\n" putStrLn $ "http://localhost:" ++ show (develPort opts) putStrLn $ "https://localhost:" ++ show (develTlsPort opts) putStrLn $ "If you wish to test https capabilities, you should set the following variable:" putStrLn $ " export APPROOT=https://localhost:" ++ show (develTlsPort opts) putStrLn "" loop (race_ httpProxy httpsProxy) `Ex.catch` \e -> do print (e :: Ex.SomeException) _ <- exitFailure Ex.throwIO e -- heh, just for good measure where loop proxies = forever $ do void proxies putStrLn $ "Reverse proxy stopped, but it shouldn't" threadDelay 1000000 putStrLn $ "Restarting reverse proxies" checkPort :: Int -> IO Bool checkPort p = do es <- Ex.try $ bindPortTCP p "*4" case es of Left (_ :: Ex.IOException) -> return False Right s -> do sClose s return True getPort :: DevelOpts -> Int -> IO Int getPort opts _ | not (useReverseProxy opts) = return $ develPort opts getPort _ p0 = loop p0 where loop p = do 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 unlessM (checkPort $ develPort opts) $ error "devel port unavailable" iappPort <- getPort opts 17834 >>= I.newIORef when (useReverseProxy opts) $ void $ forkIO $ reverseProxy opts iappPort develHsPath <- checkDevelFile writeLock opts let (terminator, after) = case terminateWith opts of TerminateOnEnter -> ("Type 'quit'", blockQuit) TerminateOnlyInterrupt -> -- run for one year ("Interrupt", threadDelay $ 1000 * 1000 * 60 * 60 * 24 * 365) blockQuit = do s <- getLine if s == "quit" then return () else do putStrLn "Type 'quit' to quit" blockQuit putStrLn $ "Yesod devel server. " ++ terminator ++ " to quit" void $ forkIO $ do filesModified <- newEmptyMVar void $ forkIO $ void $ watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ())) evalStateT (mainOuterLoop develHsPath iappPort filesModified) Map.empty after writeLock opts exitSuccess where bd = getBuildDir opts -- outer loop re-reads the cabal file mainOuterLoop develHsPath iappPort filesModified = do ghcVer <- liftIO ghcVersion #if MIN_VERSION_Cabal(1,20,0) cabal <- liftIO $ D.tryFindPackageDesc "." #else cabal <- liftIO $ D.findPackageDesc "." #endif gpd <- liftIO $ D.readPackageDescription D.normal cabal ldar <- liftIO lookupLdAr (hsSourceDirs, _) <- liftIO $ checkCabalFile gpd liftIO $ removeFileIfExists (bd "setup-config") c <- liftIO $ configure opts passThroughArgs if c then do -- these files contain the wrong data after the configure step, -- remove them to force a cabal build first liftIO $ mapM_ removeFileIfExists [ "yesod-devel/ghcargs.txt" , "yesod-devel/arargs.txt" , "yesod-devel/ldargs.txt" ] rebuild <- liftIO $ mkRebuild ghcVer cabal opts ldar mainInnerLoop develHsPath iappPort hsSourceDirs filesModified cabal rebuild else do liftIO (threadDelay 5000000) mainOuterLoop develHsPath iappPort filesModified -- inner loop rebuilds after files change mainInnerLoop develHsPath iappPort hsSourceDirs filesModified cabal rebuild = go where go = do _ <- recompDeps hsSourceDirs list <- liftIO $ getFileList hsSourceDirs [cabal] success <- liftIO rebuild pkgArgs <- liftIO (ghcPackageArgs opts) let devArgs = pkgArgs ++ [develHsPath] let loop list0 = do (haskellFileChanged, list1) <- liftIO $ watchForChanges filesModified hsSourceDirs [cabal] list0 (eventTimeout opts) anyTouched <- recompDeps hsSourceDirs unless (anyTouched || haskellFileChanged) $ loop list1 if not success then liftIO $ do putStrLn "\x1b[1;31mBuild failure, pausing...\x1b[0m" runBuildHook $ failHook opts else do liftIO $ runBuildHook $ successHook opts liftIO $ removeLock opts liftIO $ putStrLn $ 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 opts . (+ 1) liftIO $ I.writeIORef iappPort appPort (_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs) { env = Just $ Map.toList $ Map.insert "PORT" (show appPort) $ Map.insert "DISPLAY_PORT" (show $ develPort opts) $ Map.fromList env0 } derefMap <- get watchTid <- liftIO . forkIO . try_ $ flip evalStateT derefMap $ do loop list liftIO $ do putStrLn "Stopping development server..." writeLock opts threadDelay 1000000 putStrLn "Terminating development server..." terminateProcess ph ec <- liftIO $ waitForProcess' ph liftIO $ putStrLn $ "Exit code: " ++ show ec liftIO $ Ex.throwTo watchTid (userError "process finished") loop list n <- liftIO $ cabal `isNewerThan` (bd "setup-config") if n then mainOuterLoop develHsPath iappPort filesModified else go runBuildHook :: Maybe String -> IO () runBuildHook (Just s) = do ret <- system s case ret of ExitFailure _ -> putStrLn ("Error executing hook: " ++ s) _ -> return () runBuildHook Nothing = return () {- run `cabal configure' with our wrappers -} configure :: DevelOpts -> [String] -> IO Bool configure opts extraArgs = checkExit =<< createProcess (proc (cabalProgram opts) $ [ "configure" , "-flibrary-only" , "--disable-tests" , "--disable-benchmarks" , "-fdevel" , "--disable-library-profiling" , "--with-ld=yesod-ld-wrapper" , "--with-ghc=yesod-ghc-wrapper" , "--with-ar=yesod-ar-wrapper" , "--with-hc-pkg=ghc-pkg" ] ++ develConfigOpts opts ++ extraArgs ) { env = develEnv opts } removeFileIfExists :: FilePath -> IO () removeFileIfExists file = removeFile file `Ex.catch` handler where handler :: IOError -> IO () handler e | isDoesNotExistError e = return () | otherwise = Ex.throw e mkRebuild :: String -> FilePath -> DevelOpts -> (FilePath, FilePath) -> IO (IO Bool) mkRebuild ghcVer cabalFile opts (ldPath, arPath) | GHC.cProjectVersion /= ghcVer = failWith "Yesod has been compiled with a different GHC version, please reinstall yesod-bin" | forceCabal opts = return (rebuildCabal opts) | otherwise = return $ do ns <- mapM (cabalFile `isNewerThan`) [ "yesod-devel/ghcargs.txt", "yesod-devel/arargs.txt", "yesod-devel/ldargs.txt" ] if or ns then rebuildCabal opts else do bf <- getBuildFlags rebuildGhc bf ldPath arPath rebuildGhc :: [Located String] -> FilePath -> FilePath -> IO Bool rebuildGhc bf ld ar = do putStrLn "Rebuilding application... (using GHC API)" buildPackage bf ld ar rebuildCabal :: DevelOpts -> IO Bool rebuildCabal opts = do putStrLn $ "Rebuilding application... (using " ++ cabalProgram opts ++ ")" checkExit =<< createProcess (proc (cabalProgram opts) args) { env = develEnv opts } where args | verbose opts = [ "build" ] | otherwise = [ "build", "-v0" ] try_ :: forall a. IO a -> IO () try_ x = void (Ex.try x :: IO (Either Ex.SomeException a)) type FileList = Map.Map FilePath EpochTime 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 $ forM files' $ \f -> do efs <- Ex.try $ getFileStatus f return $ case efs of Left (_ :: Ex.SomeException) -> (f, 0) Right fs -> (f, modificationTime fs) -- | Returns @True@ if a .hs file changed. watchForChanges :: MVar () -> [FilePath] -> [FilePath] -> FileList -> Int -> IO (Bool, FileList) watchForChanges filesModified hsSourceDirs extraFiles list t = do newList <- getFileList hsSourceDirs extraFiles if list /= newList then do let haskellFileChanged = not $ Map.null $ Map.filterWithKey isHaskell $ Map.differenceWith compareTimes newList list `Map.union` Map.differenceWith compareTimes list newList return (haskellFileChanged, newList) else timeout (1000000*t) (takeMVar filesModified) >> watchForChanges filesModified hsSourceDirs extraFiles list t where compareTimes x y | x == y = Nothing | otherwise = Just x isHaskell filename _ = takeExtension filename `elem` [".hs", ".lhs", ".hsc", ".cabal"] checkDevelFile :: IO FilePath checkDevelFile = loop paths where paths = ["app/devel.hs", "devel.hs", "src/devel.hs"] loop [] = failWith $ "file devel.hs not found, checked: " ++ show paths loop (x:xs) = do e <- doesFileExist x if e then return x else loop xs checkCabalFile :: D.GenericPackageDescription -> IO ([FilePath], D.Library) checkCabalFile gpd = case D.condLibrary gpd of Nothing -> failWith "incorrect cabal file, no library" Just ct -> case lookupDevelLib gpd ct of Nothing -> failWith "no development flag found in your configuration file. Expected a 'library-only' flag or the older 'devel' flag" Just dLib -> do let hsSourceDirs = D.hsSourceDirs . D.libBuildInfo $ dLib fl <- getFileList hsSourceDirs [] let unlisted = checkFileList fl dLib unless (null unlisted) $ do putStrLn "WARNING: the following source files are not listed in exposed-modules or other-modules:" mapM_ putStrLn unlisted when ("Application" `notElem` (map (last . D.components) $ D.exposedModules dLib)) $ putStrLn "WARNING: no exposed module Application" return (hsSourceDirs, dLib) failWith :: String -> IO a failWith msg = do putStrLn $ "ERROR: " ++ msg exitFailure checkFileList :: FileList -> D.Library -> [FilePath] checkFileList fl lib = filter (not . isSetup) . filter isUnlisted . filter isSrcFile $ sourceFiles where al = allModules lib -- a file is only a possible 'module file' if all path pieces start with a capital letter sourceFiles = filter isSrcFile . map fst . Map.toList $ fl isSrcFile file = let dirs = filter (/=".") $ splitDirectories file in all (isUpper . head) dirs && (takeExtension file `elem` [".hs", ".lhs"]) isUnlisted file = not (toModuleName file `Set.member` al) toModuleName = L.intercalate "." . filter (/=".") . splitDirectories . dropExtension isSetup "Setup.hs" = True isSetup "./Setup.hs" = True isSetup "Setup.lhs" = True isSetup "./Setup.lhs" = True isSetup _ = False allModules :: D.Library -> Set.Set String allModules lib = Set.fromList $ map toString $ D.exposedModules lib ++ (D.otherModules . D.libBuildInfo) lib where toString = L.intercalate "." . D.components ghcVersion :: IO String ghcVersion = fmap getNumber $ readProcess "runghc" ["--numeric-version", "0"] [] where getNumber = filter (\x -> isNumber x || x == '.') ghcPackageArgs :: DevelOpts -> IO [String] ghcPackageArgs opts = getBuildFlags >>= getPackageArgs (buildDir opts) lookupDevelLib :: D.GenericPackageDescription -> D.CondTree D.ConfVar c a -> Maybe a lookupDevelLib gpd ct | found = Just (D.condTreeData ct) | otherwise = Nothing where flags = map (unFlagName . D.flagName) $ D.genPackageFlags gpd unFlagName (D.FlagName x) = x found = any (`elem` ["library-only", "devel"]) flags -- location of `ld' and `ar' programs lookupLdAr :: IO (FilePath, FilePath) lookupLdAr = do mla <- lookupLdAr' case mla of Nothing -> failWith "Cannot determine location of `ar' or `ld' program" Just la -> return la lookupLdAr' :: IO (Maybe (FilePath, FilePath)) lookupLdAr' = do #if MIN_VERSION_Cabal(1,18,0) (_, _, pgmc) <- D.configCompilerEx (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent #else (_, pgmc) <- D.configCompiler (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent #endif pgmc' <- D.configureAllKnownPrograms D.silent pgmc return $ (,) <$> look D.ldProgram pgmc' <*> look D.arProgram pgmc' where look pgm pdb = fmap D.programPath (D.lookupProgram pgm pdb) -- | nonblocking version of @waitForProcess@ waitForProcess' :: ProcessHandle -> IO ExitCode waitForProcess' pid = go where go = do mec <- getProcessExitCode pid case mec of Just ec -> return ec Nothing -> threadDelay 100000 >> go -- | wait for process started by @createProcess@, return True for ExitSuccess checkExit :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO Bool checkExit (_,_,_,h) = (==ExitSuccess) <$> waitForProcess' h yesod-bin-1.4.18.7/GhcBuild.hs0000644000000000000000000005330012775725517014071 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} {- There is a lot of code copied from GHC here, and some conditional compilation. Instead of fixing all warnings and making it much more difficult to compare the code to the original, just ignore unused binds and imports. -} {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {- build package with the GHC API -} module GhcBuild (getBuildFlags, buildPackage, getPackageArgs) where import qualified Control.Exception as Ex import Control.Monad (when) import Data.IORef import System.Process (rawSystem) import System.Environment (getEnvironment) import CmdLineParser import Data.Char (toLower) import Data.List (isPrefixOf, isSuffixOf, partition) import Data.Maybe (fromMaybe) import DriverPhases (Phase (..), anyHsc, isHaskellSrcFilename, isSourceFilename, startPhase) import DriverPipeline (compileFile, link, linkBinary, oneShot) import DynFlags (DynFlags, compilerInfo) import qualified DynFlags import qualified DynFlags as DF import qualified GHC import GHC.Paths (libdir) import HscTypes (HscEnv (..), emptyHomePackageTable) import qualified Module import MonadUtils (liftIO) import Panic (throwGhcException, panic) import SrcLoc (Located, mkGeneralLocated) import qualified StaticFlags #if __GLASGOW_HASKELL__ >= 707 import DynFlags (ldInputs) #else import StaticFlags (v_Ld_inputs) #endif import System.FilePath (normalise, ()) import Util (consIORef, looksLikeModuleName) {- This contains a huge hack: GHC only accepts setting static flags once per process, however it has no way to get the remaining options from the command line, without setting the static flags. This code overwrites the IORef to disable the check. This will likely cause problems if the flags are modified, but fortunately that's relatively uncommon. -} getBuildFlags :: IO [Located String] getBuildFlags = do argv0 <- fmap read $ readFile "yesod-devel/ghcargs.txt" -- generated by yesod-ghc-wrapper argv0' <- prependHsenvArgv argv0 let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0' mbMinusB | null minusB_args = Nothing | otherwise = Just (drop 2 (last minusB_args)) let argv1' = map (mkGeneralLocated "on the commandline") argv1 writeIORef StaticFlags.v_opt_C_ready False -- the huge hack (argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1' return argv2 prependHsenvArgv :: [String] -> IO [String] prependHsenvArgv argv = do env <- getEnvironment return $ case (lookup "HSENV" env) of Nothing -> argv _ -> hsenvArgv ++ argv where hsenvArgv = words $ fromMaybe "" (lookup "PACKAGE_DB_FOR_GHC" env) -- construct a command line for loading the right packages getPackageArgs :: Maybe String -> [Located String] -> IO [String] getPackageArgs buildDir argv2 = do (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 GHC.runGhc (Just libdir) $ do dflags0 <- GHC.getSessionDynFlags (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 argv3 let pkgFlags = map convertPkgFlag (GHC.packageFlags dflags1) ignorePkgFlags = #if __GLASGOW_HASKELL__ >= 800 map convertIgnorePkgFlag (GHC.ignorePackageFlags dflags1) #else [] #endif trustPkgFlags = #if __GLASGOW_HASKELL__ >= 800 map convertTrustPkgFlag (GHC.trustFlags dflags1) #else [] #endif hideAll | gopt DF.Opt_HideAllPackages dflags1 = [ "-hide-all-packages"] | otherwise = [] ownPkg = packageString (DF.thisPackage dflags1) return (reverse (extra dflags1) ++ hideAll ++ trustPkgFlags ++ ignorePkgFlags ++ pkgFlags ++ ownPkg) where #if __GLASGOW_HASKELL__ >= 800 convertIgnorePkgFlag (DF.IgnorePackage p) = "-ignore-package" ++ p convertTrustPkgFlag (DF.TrustPackage p) = "-trust" ++ p convertTrustPkgFlag (DF.DistrustPackage p) = "-distrust" ++ p #else convertPkgFlag (DF.IgnorePackage p) = "-ignore-package" ++ p convertPkgFlag (DF.TrustPackage p) = "-trust" ++ p convertPkgFlag (DF.DistrustPackage p) = "-distrust" ++ p #endif #if __GLASGOW_HASKELL__ >= 800 convertPkgFlag (DF.ExposePackage _ (DF.PackageArg p) _) = "-package" ++ p convertPkgFlag (DF.ExposePackage _ (DF.UnitIdArg p) _) = "-package-id" ++ p #elif __GLASGOW_HASKELL__ == 710 convertPkgFlag (DF.ExposePackage (DF.PackageArg p) _) = "-package" ++ p convertPkgFlag (DF.ExposePackage (DF.PackageIdArg p) _) = "-package-id" ++ p convertPkgFlag (DF.ExposePackage (DF.PackageKeyArg p) _) = "-package-key" ++ p #else convertPkgFlag (DF.ExposePackage p) = "-package" ++ p convertPkgFlag (DF.ExposePackageId p) = "-package-id" ++ p #endif convertPkgFlag (DF.HidePackage p) = "-hide-package" ++ p #if __GLASGOW_HASKELL__ >= 800 -- See: https://github.com/yesodweb/yesod/issues/1284 packageString _flags = [] --packageString flags = "-package-id" ++ Module.unitIdString flags #elif __GLASGOW_HASKELL__ == 710 packageString flags = ["-package-key" ++ Module.packageKeyString flags] #else packageString flags = ["-package-id" ++ Module.packageIdString flags ++ "-inplace"] #endif #if __GLASGOW_HASKELL__ >= 705 extra df = inplaceConf ++ extra' where extra' = concatMap convertExtra (extraConfs df) -- old cabal-install sometimes misses the .inplace db, fix it here inplaceConf | any (".inplace" `isSuffixOf`) extra' = [] | otherwise = ["-package-db" ++ fromMaybe "dist" buildDir ++ "/package.conf.inplace"] extraConfs df = GHC.extraPkgConfs df [] convertExtra DF.GlobalPkgConf = [ ] convertExtra DF.UserPkgConf = [ ] convertExtra (DF.PkgConfFile file) = [ "-package-db" ++ file ] #else extra df = inplaceConf ++ extra' where extra' = map ("-package-conf"++) (GHC.extraPkgConfs df) -- old cabal-install sometimes misses the .inplace db, fix it here inplaceConf | any (".inplace" `isSuffixOf`) extra' = [] | otherwise = ["-package-conf" ++ fromMaybe "dist" buildDir ++ "/package.conf.inplace"] #endif #if __GLASGOW_HASKELL__ >= 707 gopt = DF.gopt #else gopt = DF.dopt #endif buildPackage :: [Located String] -> FilePath -> FilePath -> IO Bool buildPackage a ld ar = buildPackage' a ld ar `Ex.catch` \e -> do putStrLn ("exception building package: " ++ show (e :: Ex.SomeException)) return False buildPackage' :: [Located String] -> FilePath -> FilePath -> IO Bool buildPackage' argv2 ld ar = do (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 GHC.runGhc (Just libdir) $ do dflags0 <- GHC.getSessionDynFlags (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 argv3 let dflags2 = dflags1 { GHC.ghcMode = GHC.CompManager , GHC.hscTarget = GHC.hscTarget dflags1 , GHC.ghcLink = GHC.LinkBinary , GHC.verbosity = 1 } (dflags3, fileish_args, _) <- GHC.parseDynamicFlags dflags2 argv3 GHC.setSessionDynFlags dflags3 let normal_fileish_paths = map (normalise . GHC.unLoc) fileish_args (srcs, objs) = partition_args normal_fileish_paths [] [] (hs_srcs, non_hs_srcs) = partition haskellish srcs haskellish (f,Nothing) = looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f haskellish (_,Just phase) = #if MIN_VERSION_ghc(8,0,0) phase `notElem` [As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm, StopLn] #elif MIN_VERSION_ghc(7,8,3) phase `notElem` [As True, As False, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] #elif MIN_VERSION_ghc(7,4,0) phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] #else phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] #endif hsc_env <- GHC.getSession -- if (null hs_srcs) -- then liftIO (oneShot hsc_env StopLn srcs) -- else do #if MIN_VERSION_ghc(7,2,0) o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) #else o_files <- mapM (\x -> compileFile hsc_env StopLn x) #endif non_hs_srcs #if __GLASGOW_HASKELL__ >= 707 let dflags4 = dflags3 { ldInputs = map (DF.FileOption "") (reverse o_files) ++ ldInputs dflags3 } GHC.setSessionDynFlags dflags4 #else liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files) #endif targets <- mapM (uncurry GHC.guessTarget) hs_srcs GHC.setTargets targets ok_flag <- GHC.load GHC.LoadAllTargets if GHC.failed ok_flag then return False else liftIO (linkPkg ld ar) >> return True linkPkg :: FilePath -> FilePath -> IO () linkPkg ld ar = do arargs <- fmap read $ readFile "yesod-devel/arargs.txt" rawSystem ar arargs ldargs <- fmap read $ readFile "yesod-devel/ldargs.txt" rawSystem ld ldargs return () -------------------------------------------------------------------------------------------- -- stuff below copied from ghc main.hs -------------------------------------------------------------------------------------------- partition_args :: [String] -> [(String, Maybe Phase)] -> [String] -> ([(String, Maybe Phase)], [String]) partition_args [] srcs objs = (reverse srcs, reverse objs) partition_args ("-x":suff:args) srcs objs | "none" <- suff = partition_args args srcs objs | StopLn <- phase = partition_args args srcs (slurp ++ objs) | otherwise = partition_args rest (these_srcs ++ srcs) objs where phase = startPhase suff (slurp,rest) = break (== "-x") args these_srcs = zip slurp (repeat (Just phase)) partition_args (arg:args) srcs objs | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs | otherwise = partition_args args srcs (arg:objs) {- We split out the object files (.o, .dll) and add them to v_Ld_inputs for use by the linker. The following things should be considered compilation manager inputs: - haskell source files (strings ending in .hs, .lhs or other haskellish extension), - module names (not forgetting hierarchical module names), - and finally we consider everything not containing a '.' to be a comp manager input, as shorthand for a .hs or .lhs filename. Everything else is considered to be a linker object, and passed straight through to the linker. -} looks_like_an_input :: String -> Bool looks_like_an_input m = isSourceFilename m || looksLikeModuleName m || '.' `notElem` m -- Parsing the mode flag parseModeFlags :: [Located String] -> IO (Mode, [Located String], [Located String]) parseModeFlags args = do let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) = runCmdLine (processArgs mode_flags args) (Nothing, [], []) mode = case mModeFlag of Nothing -> doMakeMode Just (m, _) -> m errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2 #if __GLASGOW_HASKELL__ >= 710 errorsToGhcException' = errorsToGhcException . map (\(GHC.L _ e) -> ("on the commandline", e)) #else errorsToGhcException' = errorsToGhcException #endif when (not (null errs)) $ throwGhcException $ errorsToGhcException' errs return (mode, flags' ++ leftover, warns) type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String]) -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) -- so we collect the new ones and return them. mode_flags :: [Flag ModeM] mode_flags = [ ------- help / version ---------------------------------------------- mkFlag "?" (PassFlag (setMode showGhcUsageMode)) , mkFlag "-help" (PassFlag (setMode showGhcUsageMode)) , mkFlag "V" (PassFlag (setMode showVersionMode)) , mkFlag "-version" (PassFlag (setMode showVersionMode)) , mkFlag "-numeric-version" (PassFlag (setMode showNumVersionMode)) , mkFlag "-info" (PassFlag (setMode showInfoMode)) , mkFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) , mkFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) ] ++ [ mkFlag k' (PassFlag (setMode (printSetting k))) | k <- ["Project version", "Booter version", "Stage", "Build platform", "Host platform", "Target platform", "Have interpreter", "Object splitting supported", "Have native code generator", "Support SMP", "Unregisterised", "Tables next to code", "RTS ways", "Leading underscore", "Debug on", "LibDir", "Global Package DB", "C compiler flags", "Gcc Linker flags", "Ld Linker flags"], let k' = "-print-" ++ map (replaceSpace . toLower) k replaceSpace ' ' = '-' replaceSpace c = c ] ++ ------- interfaces ---------------------------------------------------- [ mkFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) "--show-iface")) ------- primary modes ------------------------------------------------ , mkFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f addFlag "-no-link" f)) , mkFlag "M" (PassFlag (setMode doMkDependHSMode)) , mkFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc))) , mkFlag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f addFlag "-fvia-C" f)) #if MIN_VERSION_ghc(7,8,3) , mkFlag "S" (PassFlag (setMode (stopBeforeMode (As True)))) #else , mkFlag "S" (PassFlag (setMode (stopBeforeMode As))) #endif , mkFlag "-make" (PassFlag (setMode doMakeMode)) , mkFlag "-interactive" (PassFlag (setMode doInteractiveMode)) , mkFlag "-abi-hash" (PassFlag (setMode doAbiHashMode)) , mkFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) ] #if MIN_VERSION_ghc(7,10,1) where mkFlag fName fOptKind = Flag fName fOptKind AllModes #else where mkFlag fName fOptKind = Flag fName fOptKind #endif setMode :: Mode -> String -> EwM ModeM () setMode newMode newFlag = liftEwM $ do (mModeFlag, errs, flags') <- getCmdLineState let (modeFlag', errs') = case mModeFlag of Nothing -> ((newMode, newFlag), errs) Just (oldMode, oldFlag) -> case (oldMode, newMode) of -- -c/--make are allowed together, and mean --make -no-link _ | isStopLnMode oldMode && isDoMakeMode newMode || isStopLnMode newMode && isDoMakeMode oldMode -> ((doMakeMode, "--make"), []) -- If we have both --help and --interactive then we -- want showGhciUsage _ | isShowGhcUsageMode oldMode && isDoInteractiveMode newMode -> ((showGhciUsageMode, oldFlag), []) | isShowGhcUsageMode newMode && isDoInteractiveMode oldMode -> ((showGhciUsageMode, newFlag), []) -- Otherwise, --help/--version/--numeric-version always win | isDominantFlag oldMode -> ((oldMode, oldFlag), []) | isDominantFlag newMode -> ((newMode, newFlag), []) -- We need to accumulate eval flags like "-e foo -e bar" (Right (Right (DoEval esOld)), Right (Right (DoEval [eNew]))) -> ((Right (Right (DoEval (eNew : esOld))), oldFlag), errs) -- Saying e.g. --interactive --interactive is OK _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs) -- Otherwise, complain _ -> let err = flagMismatchErr oldFlag newFlag in ((oldMode, oldFlag), err : errs) putCmdLineState (Just modeFlag', errs', flags') where isDominantFlag f = isShowGhcUsageMode f || isShowGhciUsageMode f || isShowVersionMode f || isShowNumVersionMode f flagMismatchErr :: String -> String -> String flagMismatchErr oldFlag newFlag = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'" addFlag :: String -> String -> EwM ModeM () addFlag s flag = liftEwM $ do (m, e, flags') <- getCmdLineState putCmdLineState (m, e, mkGeneralLocated loc s : flags') where loc = "addFlag by " ++ flag ++ " on the commandline" type Mode = Either PreStartupMode PostStartupMode type PostStartupMode = Either PreLoadMode PostLoadMode data PreStartupMode = ShowVersion -- ghc -V/--version | ShowNumVersion -- ghc --numeric-version | ShowSupportedExtensions -- ghc --supported-extensions | Print String -- ghc --print-foo showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode showVersionMode = mkPreStartupMode ShowVersion showNumVersionMode = mkPreStartupMode ShowNumVersion showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions mkPreStartupMode :: PreStartupMode -> Mode mkPreStartupMode = Left isShowVersionMode :: Mode -> Bool isShowVersionMode (Left ShowVersion) = True isShowVersionMode _ = False isShowNumVersionMode :: Mode -> Bool isShowNumVersionMode (Left ShowNumVersion) = True isShowNumVersionMode _ = False data PreLoadMode = ShowGhcUsage -- ghc -? | ShowGhciUsage -- ghci -? | ShowInfo -- ghc --info | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode showGhcUsageMode = mkPreLoadMode ShowGhcUsage showGhciUsageMode = mkPreLoadMode ShowGhciUsage showInfoMode = mkPreLoadMode ShowInfo printSetting :: String -> Mode printSetting k = mkPreLoadMode (PrintWithDynFlags f) where f dflags = fromMaybe (panic ("Setting not found: " ++ show k)) #if MIN_VERSION_ghc(7,2,0) $ lookup k (compilerInfo dflags) #else $ fmap convertPrintable (lookup k compilerInfo) where convertPrintable (DynFlags.String s) = s convertPrintable (DynFlags.FromDynFlags f) = f dflags #endif mkPreLoadMode :: PreLoadMode -> Mode mkPreLoadMode = Right . Left isShowGhcUsageMode :: Mode -> Bool isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True isShowGhcUsageMode _ = False isShowGhciUsageMode :: Mode -> Bool isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True isShowGhciUsageMode _ = False data PostLoadMode = ShowInterface FilePath -- ghc --show-iface | DoMkDependHS -- ghc -M | StopBefore Phase -- ghc -E | -C | -S -- StopBefore StopLn is the default | DoMake -- ghc --make | DoInteractive -- ghc --interactive | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"] | DoAbiHash -- ghc --abi-hash doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode doMkDependHSMode = mkPostLoadMode DoMkDependHS doMakeMode = mkPostLoadMode DoMake doInteractiveMode = mkPostLoadMode DoInteractive doAbiHashMode = mkPostLoadMode DoAbiHash showInterfaceMode :: FilePath -> Mode showInterfaceMode fp = mkPostLoadMode (ShowInterface fp) stopBeforeMode :: Phase -> Mode stopBeforeMode phase = mkPostLoadMode (StopBefore phase) doEvalMode :: String -> Mode doEvalMode str = mkPostLoadMode (DoEval [str]) mkPostLoadMode :: PostLoadMode -> Mode mkPostLoadMode = Right . Right isDoInteractiveMode :: Mode -> Bool isDoInteractiveMode (Right (Right DoInteractive)) = True isDoInteractiveMode _ = False isStopLnMode :: Mode -> Bool isStopLnMode (Right (Right (StopBefore StopLn))) = True isStopLnMode _ = False isDoMakeMode :: Mode -> Bool isDoMakeMode (Right (Right DoMake)) = True isDoMakeMode _ = False #ifdef GHCI isInteractiveMode :: PostLoadMode -> Bool isInteractiveMode DoInteractive = True isInteractiveMode _ = False #endif -- isInterpretiveMode: byte-code compiler involved isInterpretiveMode :: PostLoadMode -> Bool isInterpretiveMode DoInteractive = True isInterpretiveMode (DoEval _) = True isInterpretiveMode _ = False needsInputsMode :: PostLoadMode -> Bool needsInputsMode DoMkDependHS = True needsInputsMode (StopBefore _) = True needsInputsMode DoMake = True needsInputsMode _ = False -- True if we are going to attempt to link in this mode. -- (we might not actually link, depending on the GhcLink flag) isLinkMode :: PostLoadMode -> Bool isLinkMode (StopBefore StopLn) = True isLinkMode DoMake = True isLinkMode DoInteractive = True isLinkMode (DoEval _) = True isLinkMode _ = False isCompManagerMode :: PostLoadMode -> Bool isCompManagerMode DoMake = True isCompManagerMode DoInteractive = True isCompManagerMode (DoEval _) = True isCompManagerMode _ = False yesod-bin-1.4.18.7/ghcwrapper.hs0000644000000000000000000000433012775725517014551 0ustar0000000000000000{- wrapper executable that captures arguments to ghc, ar or ld -} {-# LANGUAGE CPP #-} module Main where import Control.Monad (when) import Data.Maybe (fromMaybe) import Distribution.Compiler (CompilerFlavor (..)) import qualified Distribution.Simple.Configure as D import Distribution.Simple.Program (arProgram, defaultProgramConfiguration, ghcProgram, ldProgram, programPath) import Distribution.Simple.Program.Db (configureAllKnownPrograms, lookupProgram) import Distribution.Simple.Program.Types (Program (..)) import Distribution.Verbosity (silent) import System.Directory (doesDirectoryExist) import System.Environment (getArgs) import System.Exit (ExitCode (..), exitWith) import System.IO (hPutStrLn, stderr) import System.Process (rawSystem, readProcess) #ifdef LDCMD cmd :: Program cmd = ldProgram outFile = "yesod-devel/ldargs.txt" #else #ifdef ARCMD cmd :: Program cmd = arProgram outFile ="yesod-devel/arargs.txt" #else cmd :: Program cmd = ghcProgram outFile = "yesod-devel/ghcargs.txt" #endif #endif runProgram :: Program -> [String] -> IO ExitCode runProgram pgm args = do #if MIN_VERSION_Cabal(1,18,0) (_, comp, pgmc) <- D.configCompilerEx (Just GHC) Nothing Nothing defaultProgramConfiguration silent #else (comp, pgmc) <- D.configCompiler (Just GHC) Nothing Nothing defaultProgramConfiguration silent #endif pgmc' <- configureAllKnownPrograms silent pgmc case lookupProgram pgm pgmc' of Nothing -> do hPutStrLn stderr ("cannot find program '" ++ programName pgm ++ "'") return (ExitFailure 1) Just p -> rawSystem (programPath p) args main :: IO () main = do args <- getArgs e <- doesDirectoryExist "yesod-devel" when e $ writeFile outFile (show args ++ "\n") ex <- runProgram cmd args exitWith ex yesod-bin-1.4.18.7/HsFile.hs0000644000000000000000000000135512775725517013565 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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 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) where -- Reads a filepath from upstream and dumps a pair of (filepath, filecontents) readIt = CL.map $ \i -> (fromString i, liftIO $ BS.readFile i) yesod-bin-1.4.18.7/Keter.hs0000644000000000000000000001160212775725517013461 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Keter ( keter ) where import Data.Yaml import qualified Data.HashMap.Strict as Map import qualified Data.Text as T import System.Environment (getEnvironment) import System.Exit import System.Process import Control.Monad import System.Directory hiding (findFiles) import Data.Maybe (mapMaybe,isJust,maybeToList) import Data.Monoid import System.FilePath (()) import qualified Codec.Archive.Tar as Tar import Control.Exception import qualified Data.ByteString.Lazy as L import Codec.Compression.GZip (compress) import qualified Data.Foldable as Fold import Control.Monad.Trans.Writer (tell, execWriter) run :: String -> [String] -> IO () run a b = do ec <- rawSystem a b unless (ec == ExitSuccess) $ exitWith ec keter :: String -- ^ cabal command -> Bool -- ^ no build? -> Bool -- ^ no copy to? -> [String] -- ^ build args -> IO () keter cabal noBuild noCopyTo buildArgs = do ketercfg <- keterConfig mvalue <- decodeFile ketercfg value <- case mvalue of Nothing -> error "No config/keter.yaml found" Just (Object value) -> case Map.lookup "host" value of Just (String s) | "<<" `T.isPrefixOf` s -> error $ "Please set your hostname in " ++ ketercfg _ -> case Map.lookup "user-edited" value of Just (Bool False) -> error $ "Please edit your Keter config file at " ++ ketercfg _ -> return value Just _ -> error $ ketercfg ++ " is not an object" env' <- getEnvironment cwd' <- getCurrentDirectory files <- getDirectoryContents "." project <- case mapMaybe (T.stripSuffix ".cabal" . T.pack) files of [x] -> return x [] -> error "No cabal file found" _ -> error "Too many cabal files found" let findFiles (Object v) = mapM_ go $ Map.toList v where go ("exec", String s) = tellFile s go ("extraFiles", Array a) = Fold.mapM_ tellExtra a go (_, v') = findFiles v' tellFile s = tell [collapse $ "config" T.unpack s] tellExtra (String s) = tellFile s tellExtra _ = error "extraFiles should be a flat array" findFiles (Array v) = Fold.mapM_ findFiles v findFiles _ = return () bundleFiles = execWriter $ findFiles $ Object value collapse = T.unpack . T.intercalate "/" . collapse' . T.splitOn "/" . T.pack collapse' (_:"..":rest) = collapse' rest collapse' (".":xs) = collapse' xs collapse' (x:xs) = x : collapse' xs collapse' [] = [] unless noBuild $ do stackQueryRunSuccess <- do eres <- try $ readProcessWithExitCode "stack" ["query"] "" :: IO (Either IOException (ExitCode, String, String)) return $ either (\_ -> False) (\(ec, _, _) -> (ec == ExitSuccess)) eres let inStackExec = isJust $ lookup "STACK_EXE" env' mStackYaml = lookup "STACK_YAML" env' useStack = inStackExec || isJust mStackYaml || stackQueryRunSuccess if useStack then do let stackYaml = maybeToList $ fmap ("--stack-yaml="<>) mStackYaml localBinPath = cwd' "dist/bin" run "stack" $ stackYaml <> ["clean"] createDirectoryIfMissing True localBinPath run "stack" (stackYaml <> ["--local-bin-path",localBinPath,"build","--copy-bins"] <> buildArgs) else do run cabal ["clean"] run cabal ["configure"] run cabal ("build" : buildArgs) _ <- try' $ removeDirectoryRecursive "static/tmp" archive <- Tar.pack "" $ "config" : "static" : bundleFiles let fp = T.unpack project ++ ".keter" L.writeFile fp $ compress $ Tar.write archive unless noCopyTo $ case Map.lookup "copy-to" value of Just (String s) -> let baseArgs = [fp, T.unpack s] :: [String] scpArgs = case parseMaybe (.: "copy-to-args") value of Just as -> as ++ baseArgs Nothing -> baseArgs args = case parseMaybe (.: "copy-to-port") value of Just i -> "-P" : show (i :: Int) : scpArgs Nothing -> scpArgs in run "scp" args _ -> return () where -- Test for alternative config file extension (yaml or yml). keterConfig = do let yml = "config/keter.yml" ymlExists <- doesFileExist yml return $ if ymlExists then yml else "config/keter.yaml" try' :: IO a -> IO (Either SomeException a) try' = try yesod-bin-1.4.18.7/key.pem0000644000000000000000000000156712775725517013357 0ustar0000000000000000-----BEGIN RSA PRIVATE KEY----- MIICXAIBAAKBgQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCd thgTK66SPXkxEXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cD JSSGK11eQEVs+p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQAB AoGAR8pgAgjo7tZ60ccIUjOX/LSxB6d5J2Eu6wvNjk6qZD9OuWtOa7up/HigmZ63 CDMjQNI2/o6AOrWtEQkPYZNbibuifzg5V517nHGSqkqjoIgesAiwEsoKpeOgGTtM MM08oHbJ9uOnDnEEnDBiE0iE3jCTDfmwjqDMpUhu9dZ1EAECQQDKVpzSSV3pzMOp ixNxMpYxzcE+4K9jgM+MlxPBJSQhVrg/cRQWb26cKBi8LdSxF23hQTsFr+8qLwid Ah2AgUOBAkEAyaaCjrNRCiHRpd6YzWZ6GKkxbUvxSuOKX3N7hDaE2OFzQTv2Li8B 5mrCsXnSZtOG+MBFdHU66UYie1OzDSDKtwJAKMsvkOID0ihbZmpIwDC/wUjHZkLs eXY14hVvgShY0XPnb7r/nspWlZsr6Xyf/hhIKfr5yFrBMFMNPIJ5qjflgQJAWsyV YTgxN4S+6BdxapvIQq58ySA3CGeo+Q4BAimibB4oTal4UpdsHZrZDB00toRs9Dlv jN70pfGkuS+ZIkIvxQJBAKSf5qpXWp4oZcThkieAiMeAhG96xqRPXhPUxq6QF+YG T4PF1sjlpZwqy7C+2oF3BqLP09mCW7YkH9Jgnl1zDF8= -----END RSA PRIVATE KEY----- yesod-bin-1.4.18.7/LICENSE0000644000000000000000000000207512775725517013064 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. yesod-bin-1.4.18.7/main.hs0000644000000000000000000003015512775725517013337 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} 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.FilePath (splitSearchPath) import System.Process (rawSystem) import AddHandler (addHandler) import Devel (DevelOpts (..), devel, DevelTermOpt(..)) 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 { optCabalPgm :: CabalPgm , optVerbose :: Bool , optCommand :: Command } deriving (Show, Eq) data Command = Init [String] | HsFiles | Configure | Build { buildExtraArgs :: [String] } | Touch | Devel { _develDisableApi :: Bool , _develSuccessHook :: Maybe String , _develFailHook :: Maybe String , _develRescan :: Int , _develBuildDir :: Maybe String , develIgnore :: [String] , develExtraArgs :: [String] , _develPort :: Int , _develTlsPort :: Int , _proxyTimeout :: Int , _noReverseProxy :: Bool , _interruptOnly :: Bool } | Test | AddHandler { addHandlerRoute :: Maybe String , addHandlerPattern :: Maybe String , addHandlerMethods :: [String] } | Keter { _keterNoRebuild :: Bool , _keterNoCopyTo :: Bool , _keterBuildArgs :: [String] } | Version deriving (Show, Eq) cabalCommand :: Options -> String cabalCommand mopt | optCabalPgm mopt == CabalDev = "cabal-dev" | otherwise = "cabal" main :: IO () main = do o <- execParser =<< injectDefaults "yesod" [ ("yesod.devel.extracabalarg" , \o args -> o { optCommand = case optCommand o of d@Devel{} -> d { develExtraArgs = args } c -> c }) , ("yesod.devel.ignore" , \o args -> o { optCommand = case optCommand o of d@Devel{} -> d { develIgnore = args } c -> c }) , ("yesod.build.extracabalarg" , \o args -> o { optCommand = case optCommand o of b@Build{} -> b { buildExtraArgs = args } 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' 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 Devel{..} ->do (configOpts, menv) <- handleGhcPackagePath let develOpts = DevelOpts { isCabalDev = optCabalPgm o == CabalDev , forceCabal = _develDisableApi , verbose = optVerbose o , eventTimeout = _develRescan , successHook = _develSuccessHook , failHook = _develFailHook , buildDir = _develBuildDir , develPort = _develPort , develTlsPort = _develTlsPort , proxyTimeout = _proxyTimeout , useReverseProxy = not _noReverseProxy , terminateWith = if _interruptOnly then TerminateOnlyInterrupt else TerminateOnEnter , develConfigOpts = configOpts , develEnv = menv } devel develOpts develExtraArgs 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." , "Please use 'stack new