packages feed

yesod 0.9.1.1 → 0.9.2

raw patch · 7 files changed

+264/−169 lines, 7 filesdep +filepathdep +shakespeare-text

Dependencies added: filepath, shakespeare-text

Files

Build.hs view
@@ -1,35 +1,39 @@ {-# LANGUAGE OverloadedStrings #-} module Build-    ( touch-    , getDeps+    ( getDeps     , touchDeps+    , touch+    , recompDeps     , findHaskellFiles     ) where --- FIXME there's a bug when getFileStatus applies to a file temporary deleted (e.g., Vim saving a file)+-- FIXME there's a bug when getFileStatus applies to a file+-- temporary deleted (e.g., Vim saving a file) -import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist)-import Data.List (isSuffixOf)+import           Control.Applicative ((<|>))+import           Control.Exception (SomeException, try)+import           Control.Monad (when, filterM, forM, forM_)+ import qualified Data.Attoparsec.Text.Lazy as A-import qualified Data.Text.Lazy.IO as TIO-import Control.Applicative ((<|>))-import Data.Char (isSpace)-import Data.Monoid (mappend)+import           Data.Char (isSpace)+import           Data.Monoid (mappend)+import           Data.List (isSuffixOf) import qualified Data.Map as Map import qualified Data.Set as Set-import System.PosixCompat.Files (accessTime, modificationTime, getFileStatus, setFileTimes)+import qualified Data.Text.Lazy.IO as TIO+ import qualified System.Posix.Types-import Control.Monad (filterM, forM)-import Control.Exception (SomeException, try)+import           System.Directory+import           System.FilePath (replaceExtension, (</>))+import           System.PosixCompat.Files (getFileStatus, setFileTimes,+                                             accessTime, modificationTime) --- | Touch any files with altered dependencies but do not build touch :: IO ()-touch = do-    hss <- findHaskellFiles "."-    deps' <- mapM determineHamletDeps hss-    let deps = fixDeps $ zip hss deps'-    touchDeps deps+touch = touchDeps id updateFileTime =<< getDeps +recompDeps :: IO ()+recompDeps = touchDeps hiFile removeHi =<< getDeps+ type Deps = Map.Map FilePath (Set.Set FilePath)  getDeps :: IO Deps@@ -38,25 +42,48 @@     deps' <- mapM determineHamletDeps hss     return $ fixDeps $ zip hss deps' -touchDeps :: Deps -> IO ()-touchDeps =-    mapM_ go . Map.toList+touchDeps :: (FilePath -> FilePath) ->+             (FilePath -> FilePath -> IO ()) ->+             Deps -> IO ()+touchDeps f action deps = (mapM_ go . Map.toList) deps   where-    go (x, ys) = do-        (_, mod1) <- getFileStatus' x-        flip mapM_ (Set.toList ys) $ \y -> do-            (access, mod2) <- getFileStatus' y-            if mod2 < mod1-                then do-                    putStrLn $ "Touching " ++ y ++ " because of " ++ x-                    _ <- try' $ setFileTimes y access mod1-                    return ()-                else return ()+    go (x, ys) =+        forM_ (Set.toList ys) $ \y -> do+            n <- x `isNewerThan` f y+            when n $ do+              putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x)+              action x y +-- | 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" </> 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" </> replaceExtension hs "hi"+ try' :: IO x -> IO (Either SomeException x) try' = try -getFileStatus' :: FilePath -> IO (System.Posix.Types.EpochTime, System.Posix.Types.EpochTime)+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@@ -75,10 +102,11 @@     contents <- getDirectoryContents path     fmap concat $ mapM go contents   where-    go ('.':_)     = return []-    go ('d':"ist") = return []+    go ('.':_)          = return []+    go ('c':"abal-dev") = return []+    go ('d':"ist")      = return []     go x = do-        let y = path ++ '/' : x+        let y = path </> x         d <- doesDirectoryExist y         if d             then findHaskellFiles y
Devel.hs view
@@ -1,128 +1,120 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE ScopedTypeVariables #-} module Devel     ( devel     ) where --- import qualified Distribution.Simple.Build as B--- import Distribution.Simple.Configure (configure)-import Distribution.Simple (defaultMainArgs)--- import Distribution.Simple.Setup (defaultConfigFlags, configConfigurationsFlags, configUserInstall, Flag (..), defaultBuildFlags, defaultCopyFlags, defaultRegisterFlags)-import Distribution.Simple.Utils (defaultPackageDesc, defaultHookedPackageDesc)--- import Distribution.Simple.Program (defaultProgramConfiguration)-import Distribution.Verbosity (normal)-import Distribution.PackageDescription.Parse (readPackageDescription, readHookedBuildInfo)-import Distribution.PackageDescription (emptyHookedBuildInfo)--- import Distribution.Simple.LocalBuildInfo (localPkgDescr)-import Build (getDeps, touchDeps, findHaskellFiles)--- import Network.Wai.Handler.Warp (run)--- import Network.Wai.Middleware.Debug (debug)--- import Distribution.Text (display)--- import Distribution.Simple.Install (install)--- import Distribution.Simple.Register (register)-import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread)-import Control.Exception (try, SomeException)-import System.PosixCompat.Files (modificationTime, getFileStatus)++import qualified Distribution.Simple.Utils as D+import qualified Distribution.Verbosity as D+import qualified Distribution.Package as D+import qualified Distribution.PackageDescription.Parse as D+import qualified Distribution.PackageDescription as D++import           Control.Concurrent (forkIO, threadDelay)+import qualified Control.Exception as Ex+import           Control.Monad (forever)++import qualified Data.List as L import qualified Data.Map as Map-import System.Posix.Types (EpochTime)--- import Blaze.ByteString.Builder.Char.Utf8 (fromString)--- import Network.Wai (Application, Response (ResponseBuilder), responseLBS)--- import Network.HTTP.Types (status500)-import Control.Monad (when, forever)-import System.Process (runCommand, terminateProcess, waitForProcess)-import qualified Data.IORef as I-import qualified Data.ByteString.Lazy.Char8 as L-import System.Directory (doesFileExist, removeFile, getDirectoryContents)--- import Distribution.Package (PackageName (..), pkgName)-import Data.Maybe (mapMaybe)+import           Data.Maybe (listToMaybe)+import qualified Data.Text as T+import qualified Data.Text.IO as T -appMessage :: L.ByteString -> IO ()-appMessage _ = forever $ do-    -- run 3000 . const . return $ responseLBS status500 [("Content-Type", "text/plain")] l-    threadDelay 10000+import           System.Directory (createDirectoryIfMissing, removeFile,+                                           getDirectoryContents)+import           System.Exit (exitFailure, exitSuccess)+import           System.Posix.Types (EpochTime)+import           System.PosixCompat.Files (modificationTime, getFileStatus)+import           System.Process (runCommand, terminateProcess,+                                           waitForProcess, rawSystem) -swapApp :: I.IORef ThreadId -> IO ThreadId -> IO ()-swapApp i f = do-    I.readIORef i >>= killThread-    f >>= I.writeIORef i+import Text.Shakespeare.Text (st) -devel :: ([String] -> IO ()) -- ^ cabal-      -> IO ()-devel cabalCmd = do-    e <- doesFileExist "dist/devel-flag"-    when e $ removeFile "dist/devel-flag"-    listenThread <- forkIO (appMessage "Initializing, please wait") >>= I.newIORef+import Build (recompDeps, getDeps,findHaskellFiles) -    cabal <- defaultPackageDesc normal-    _ <- readPackageDescription normal cabal+lockFile :: FilePath+lockFile = "dist/devel-terminate" -    mhpd <- defaultHookedPackageDesc-    _ <- case mhpd of-            Nothing -> return emptyHookedBuildInfo-            Just fp -> readHookedBuildInfo normal fp+writeLock :: IO ()+writeLock = do+    createDirectoryIfMissing True "dist"+    writeFile lockFile "" -    cabalCmd ["configure", "-fdevel"]+removeLock :: IO ()+removeLock = try_ (removeFile lockFile) -    let myTry :: IO () -> IO ()-        myTry f = try f >>= \x -> case x of-                                    Left err -> swapApp listenThread $ forkIO $ appMessage $ L.pack $ show (err :: SomeException)-                                    Right y -> return y-    let getNewApp :: IO ()-        getNewApp = myTry $ do-            putStrLn "Rebuilding app"-            swapApp listenThread $ forkIO $ appMessage "Rebuilding your app, please wait"+devel :: Bool -> IO ()+devel isDevel = do+    writeLock -            deps <- getDeps-            touchDeps deps+    putStrLn "Yesod devel server. Press ENTER to quit"+    _ <- forkIO $ do+      cabal <- D.findPackageDesc "."+      gpd   <- D.readPackageDescription D.normal cabal+      let pid = (D.package . D.packageDescription) gpd -            cabalCmd ["build"]-            defaultMainArgs ["install"]+      checkCabalFile gpd -            pi' <- getPackageName-            writeFile "dist/devel.hs" $ unlines-                [ "{-# LANGUAGE PackageImports #-}"-                , concat-                    [ "import \""-                    , pi'-                    , "\" Application (withDevelAppPort)"-                    ]-                , "import Data.Dynamic (fromDynamic)"-                , "import Network.Wai.Handler.Warp (run)"-                , "import Data.Maybe (fromJust)"-                , "import Control.Concurrent (forkIO)"-                , "import System.Directory (doesFileExist, removeFile)"-                , "import Control.Concurrent (threadDelay)"-                , ""-                , "main :: IO ()"-                , "main = do"-                , "    putStrLn \"Starting app\""-                , "    wdap <- return $ fromJust $ fromDynamic withDevelAppPort"-                , "    forkIO $ wdap $ \\(port, app) -> run port app"-                , "    loop"-                , ""-                , "loop :: IO ()"-                , "loop = do"-                , "    threadDelay 100000"-                , "    e <- doesFileExist \"dist/devel-flag\""-                , "    if e then removeFile \"dist/devel-flag\" else loop"-                ]-            swapApp listenThread $ forkIO $ do-                putStrLn "Calling runghc..."-                ph <- runCommand "runghc dist/devel.hs"-                let forceType :: Either SomeException () -> ()-                    forceType = const ()-                fmap forceType $ try sleepForever-                writeFile "dist/devel-flag" ""-                putStrLn "Terminating external process"-                terminateProcess ph-                putStrLn "Process terminated"-                ec <- waitForProcess ph-                putStrLn $ "Exit code: " ++ show ec+      _ <- if isDevel+        then rawSystem "cabal-dev" ["configure", "--cabal-install-arg=-fdevel"]+        else rawSystem "cabal"     ["configure", "-fdevel"] -    loop Map.empty getNewApp+      T.writeFile "dist/devel.hs" (develFile pid) -sleepForever :: IO ()-sleepForever = forever $ threadDelay 1000000+      mainLoop isDevel +    _ <- getLine+    writeLock+    exitSuccess++++mainLoop :: Bool -> IO ()+mainLoop isDevel = forever $ do+   putStrLn "Rebuilding application..."++   recompDeps++   list <- getFileList+   _ <- if isDevel+     then rawSystem "cabal-dev" ["build"]+     else rawSystem "cabal"     ["build"]++   removeLock+   putStrLn "Starting development server..."+   pkg <- pkgConfigs isDevel+   ph <- runCommand $ concat ["runghc ", pkg, " dist/devel.hs"]+   watchTid <- forkIO . try_ $ do+     watchForChanges list+     putStrLn "Stopping development server..."+     writeLock+     threadDelay 1000000+     putStrLn "Terminating development server..."+     terminateProcess ph+   ec <- waitForProcess ph+   putStrLn $ "Exit code: " ++ show ec+   Ex.throwTo watchTid (userError "process finished")+   watchForChanges list++try_ :: forall a. IO a -> IO ()+try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return ()++pkgConfigs :: Bool -> IO String+pkgConfigs isDev+  | isDev = do+      devContents <- getDirectoryContents "cabal-dev"+      let confs = filter isConfig devContents+      return . unwords $ inplacePkg :+             map ("-package-confcabal-dev/"++) confs+  | otherwise = return inplacePkg+  where+    inplacePkg = "-package-confdist/package.conf.inplace"+    isConfig dir = "packages-" `L.isPrefixOf` dir &&+                   ".conf"     `L.isSuffixOf` dir+ type FileList = Map.Map FilePath EpochTime  getFileList :: IO FileList@@ -134,25 +126,68 @@         fs <- getFileStatus f         return (f, modificationTime fs) -loop :: FileList -> IO () -> IO ()-loop oldList getNewApp = do+watchForChanges :: FileList -> IO ()+watchForChanges list = do     newList <- getFileList-    when (newList /= oldList) getNewApp-    threadDelay 1000000-    loop newList getNewApp+    if list /= newList+      then return ()+      else threadDelay 1000000 >> watchForChanges list -{--errApp :: String -> Application-errApp s _ = return $ ResponseBuilder status500 [("Content-Type", "text/plain")] $ fromString s--}+showPkgName :: D.PackageId -> String+showPkgName = (\(D.PackageName n) -> n) . D.pkgName -getPackageName :: IO String-getPackageName = do-    xs <- getDirectoryContents "."-    case mapMaybe (toCabal . reverse) xs of-        [x] -> return x-        [] -> error "No cabal files found"-        _ -> error "Too many cabal files found"+develFile :: D.PackageId -> T.Text+develFile pid = [st|+{-# LANGUAGE PackageImports #-}+import "#{showPkgName pid}" Application (withDevelAppPort)+import Data.Dynamic (fromDynamic)+import Network.Wai.Handler.Warp (run)+import Data.Maybe (fromJust)+import Control.Concurrent (forkIO)+import System.Directory (doesFileExist, removeFile)+import System.Exit (exitSuccess)+import Control.Concurrent (threadDelay)++main :: IO ()+main = do+  putStrLn "Starting devel application"+  wdap <- (return . fromJust . fromDynamic) withDevelAppPort+  forkIO . wdap $ \(port, app) -> run port app+  loop++loop :: IO ()+loop = do+  threadDelay 100000+  e <- doesFileExist "dist/devel-terminate"+  if e then terminateDevel else loop++terminateDevel :: IO ()+terminateDevel = exitSuccess+|]++checkCabalFile :: D.GenericPackageDescription -> IO ()+checkCabalFile gpd = case D.condLibrary gpd of+    Nothing -> do+      putStrLn "Error: incorrect cabal file, no library"+      exitFailure+    Just ct ->+      case lookupDevelLib ct of+        Nothing   -> do+          putStrLn "Error: no library configuration for -fdevel"+          exitFailure+        Just dLib ->+         case (D.hsSourceDirs . D.libBuildInfo) dLib of+           []     -> return ()+           ["."]  -> return ()+           _      ->+             putStrLn $ "WARNING: yesod devel may not work correctly with " +++                        "custom hs-source-dirs"++lookupDevelLib :: D.CondTree D.ConfVar c a -> Maybe a+lookupDevelLib ct = listToMaybe . map (\(_,x,_) -> D.condTreeData x) .+                    filter isDevelLib . D.condTreeComponents  $ ct   where-    toCabal ('l':'a':'b':'a':'c':'.':x) = Just $ reverse x-    toCabal _ = Nothing+    isDevelLib ((D.Var (D.Flag (D.FlagName "devel"))), _, _) = True+    isDevelLib _                                             = False++
Scaffolding/Scaffolder.hs view
@@ -81,6 +81,11 @@         backendLower = uncapitalize $ show backend          upper = show backend +    let runMigration  =+          case backend of+            MongoDB -> ""+            _ -> "\n        runConnectionPool (runMigration migrateAll) p"+     putStrLn "That's it! I'm creating your files now..."      let withConnectionPool = case backend of@@ -93,7 +98,11 @@           Postgresql -> "import Data.Text (Text, pack, concat)\nimport Prelude hiding (concat)"           _          -> "import Data.Text (Text, pack)" -        packages = if backend == MongoDB then ", mongoDB\n               , bson\n" else ""+        packages =+          if backend == MongoDB+            then "                 , persistent-mongoDB >= 0.6.1 && < 0.7\n                 , mongoDB >= 1.1\n                 , bson >= 0.1.5\n"+            else "                 , persistent-" ++ backendLower ++ " >= 0.6 && < 0.7"+      let fst3 (x, _, _) = x     year <- show . fst3 . toGregorian . utctDay <$> getCurrentTime
input/done.cg view
@@ -26,4 +26,7 @@     cd ~project~ && cabal install && yesod devel +or if you use cabal-dev:++   cd ~project~ && cabal-dev install && yesod --dev devel
main.hs view
@@ -1,11 +1,21 @@+{-# LANGUAGE CPP #-}+ import Scaffolding.Scaffolder import System.Environment (getArgs) import System.Exit (exitWith)+import System.Process (rawSystem) +#ifndef WINDOWS import Build (touch)+#endif import Devel (devel) -import System.Process (rawSystem)+windowsWarning :: String+#ifdef WINDOWS+windowsWarning = "\n                    (does not work on Windows)"+#else+windowsWarning = ""+#endif  main :: IO () main = do@@ -15,13 +25,16 @@                 "--dev":rest -> (True, rest)                 _ -> (False, args')     let cmd = if isDev then "cabal-dev" else "cabal"-    let cabal rest = rawSystem cmd rest >> return ()+#ifndef WINDOWS     let build rest = rawSystem cmd $ "build":rest+#endif     case args of         ["init"] -> scaffold+#ifndef WINDOWS         "build":rest -> touch >> build rest >>= exitWith         ["touch"] -> touch-        ["devel"] -> devel cabal+#endif+        ["devel"] -> devel isDev         ["version"] -> putStrLn "0.9"         "configure":rest -> rawSystem cmd ("configure":rest) >>= exitWith         _ -> do@@ -29,7 +42,11 @@             putStrLn "Available commands:"             putStrLn "    init         Scaffold a new site"             putStrLn "    configure    Configure a project for building"-            putStrLn "    build        Build project (performs TH dependency analysis)"-            putStrLn "    touch        Touch any files with altered TH dependencies but do not build"+            putStrLn $ "    build        Build project (performs TH dependency analysis)"+                ++ windowsWarning+            putStrLn $ "    touch        Touch any files with altered TH dependencies but do not build"+                ++ windowsWarning             putStrLn "    devel        Run project with the devel server"+            putStrLn "                    use --dev devel to build with cabal-dev"             putStrLn "    version      Print the version of Yesod"+
scaffold/Application.hs.cg view
@@ -47,8 +47,7 @@ with~sitearg~ :: AppConfig -> Logger -> (Application -> IO a) -> IO () with~sitearg~ conf logger f = do     s <- static Settings.staticDir-    Settings.withConnectionPool conf $ \p -> do-        runConnectionPool (runMigration migrateAll) p+    Settings.withConnectionPool conf $ \p -> do~runMigration~         let h = ~sitearg~ conf logger s p #ifdef WINDOWS         toWaiApp h >>= f >> return ()
yesod.cabal view
@@ -1,5 +1,5 @@ name:            yesod-version:         0.9.1.1+version:         0.9.2 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -85,8 +85,11 @@         cpp-options:     -DGHC7     else         build-depends:   base                  >= 4        && < 4.3+    if os(windows)+        cpp-options:     -DWINDOWS     build-depends:     parsec             >= 2.1          && < 4                      , text               >= 0.11         && < 0.12+                     , shakespeare-text   >= 0.10         && < 0.11                      , bytestring         >= 0.9          && < 0.10                      , time               >= 1.1.4        && < 1.3                      , template-haskell@@ -97,6 +100,7 @@                      , attoparsec-text    >= 0.8.5        && < 0.9                      , http-types         >= 0.6.1        && < 0.7                      , blaze-builder      >= 0.2          && < 0.4+                     , filepath           >= 1.2          && < 1.3                      , process     ghc-options:       -Wall -threaded     main-is:           main.hs