crunghc (empty) → 0.1.0.0

raw patch · 4 files changed

+398/−0 lines, 4 filesdep +SHAdep +basedep +bytestringsetup-changed

Dependencies added: SHA, base, bytestring, directory, filelock, filepath, process, text, time, transformers, unix

Files

• LICENSE +121/−0
• Setup.hs +2/−0
• crunghc.cabal +33/−0
• main.hs +242/−0

@@ -0,0 +1,121 @@+Creative Commons Legal Code++CC0 1.0 Universal++    CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE+    LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN+    ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS+    INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES+    REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS+    PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM+    THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED+    HEREUNDER.++Statement of Purpose++The laws of most jurisdictions throughout the world automatically confer+exclusive Copyright and Related Rights (defined below) upon the creator+and subsequent owner(s) (each and all, an "owner") of an original work of+authorship and/or a database (each, a "Work").++Certain owners wish to permanently relinquish those rights to a Work for+the purpose of contributing to a commons of creative, cultural and+scientific works ("Commons") that the public can reliably and without fear+of later claims of infringement build upon, modify, incorporate in other+works, reuse and redistribute as freely as possible in any form whatsoever+and for any purposes, including without limitation commercial purposes.+These owners may contribute to the Commons to promote the ideal of a free+culture and the further production of creative, cultural and scientific+works, or to gain reputation or greater distribution for their Work in+part through the use and efforts of others.++For these and/or other purposes and motivations, and without any+expectation of additional consideration or compensation, the person+associating CC0 with a Work (the "Affirmer"), to the extent that he or she+is an owner of Copyright and Related Rights in the Work, voluntarily+elects to apply CC0 to the Work and publicly distribute the Work under its+terms, with knowledge of his or her Copyright and Related Rights in the+Work and the meaning and intended legal effect of CC0 on those rights.++1. Copyright and Related Rights. A Work made available under CC0 may be+protected by copyright and related or neighboring rights ("Copyright and+Related Rights"). Copyright and Related Rights include, but are not+limited to, the following:++  i. the right to reproduce, adapt, distribute, perform, display,+     communicate, and translate a Work;+ ii. moral rights retained by the original author(s) and/or performer(s);+iii. publicity and privacy rights pertaining to a person's image or+     likeness depicted in a Work;+ iv. rights protecting against unfair competition in regards to a Work,+     subject to the limitations in paragraph 4(a), below;+  v. rights protecting the extraction, dissemination, use and reuse of data+     in a Work;+ vi. database rights (such as those arising under Directive 96/9/EC of the+     European Parliament and of the Council of 11 March 1996 on the legal+     protection of databases, and under any national implementation+     thereof, including any amended or successor version of such+     directive); and+vii. other similar, equivalent or corresponding rights throughout the+     world based on applicable law or treaty, and any national+     implementations thereof.++2. Waiver. To the greatest extent permitted by, but not in contravention+of, applicable law, Affirmer hereby overtly, fully, permanently,+irrevocably and unconditionally waives, abandons, and surrenders all of+Affirmer's Copyright and Related Rights and associated claims and causes+of action, whether now known or unknown (including existing as well as+future claims and causes of action), in the Work (i) in all territories+worldwide, (ii) for the maximum duration provided by applicable law or+treaty (including future time extensions), (iii) in any current or future+medium and for any number of copies, and (iv) for any purpose whatsoever,+including without limitation commercial, advertising or promotional+purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each+member of the public at large and to the detriment of Affirmer's heirs and+successors, fully intending that such Waiver shall not be subject to+revocation, rescission, cancellation, termination, or any other legal or+equitable action to disrupt the quiet enjoyment of the Work by the public+as contemplated by Affirmer's express Statement of Purpose.++3. Public License Fallback. Should any part of the Waiver for any reason+be judged legally invalid or ineffective under applicable law, then the+Waiver shall be preserved to the maximum extent permitted taking into+account Affirmer's express Statement of Purpose. In addition, to the+extent the Waiver is so judged Affirmer hereby grants to each affected+person a royalty-free, non transferable, non sublicensable, non exclusive,+irrevocable and unconditional license to exercise Affirmer's Copyright and+Related Rights in the Work (i) in all territories worldwide, (ii) for the+maximum duration provided by applicable law or treaty (including future+time extensions), (iii) in any current or future medium and for any number+of copies, and (iv) for any purpose whatsoever, including without+limitation commercial, advertising or promotional purposes (the+"License"). The License shall be deemed effective as of the date CC0 was+applied by Affirmer to the Work. Should any part of the License for any+reason be judged legally invalid or ineffective under applicable law, such+partial invalidity or ineffectiveness shall not invalidate the remainder+of the License, and in such case Affirmer hereby affirms that he or she+will not (i) exercise any of his or her remaining Copyright and Related+Rights in the Work or (ii) assert any associated claims and causes of+action with respect to the Work, in either case contrary to Affirmer's+express Statement of Purpose.++4. Limitations and Disclaimers.++ a. No trademark or patent rights held by Affirmer are waived, abandoned,+    surrendered, licensed or otherwise affected by this document.+ b. Affirmer offers the Work as-is and makes no representations or+    warranties of any kind concerning the Work, express, implied,+    statutory or otherwise, including without limitation warranties of+    title, merchantability, fitness for a particular purpose, non+    infringement, or the absence of latent or other defects, accuracy, or+    the present or absence of errors, whether or not discoverable, all to+    the greatest extent permissible under applicable law.+ c. Affirmer disclaims responsibility for clearing rights of other persons+    that may apply to the Work or any use thereof, including without+    limitation any person's Copyright and Related Rights in the Work.+    Further, Affirmer disclaims responsibility for obtaining any necessary+    consents, permissions or other rights required for any use of the+    Work.+ d. Affirmer understands and acknowledges that Creative Commons is not a+    party to this document and has no duty or obligation with respect to+    this CC0 or use of the Work.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,33 @@+-- Initial crunghc.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                crunghc+version:             0.1.0.0+synopsis:            A runghc replacement with transparent caching+description:         crunghc is a program that acts like runghc. When it+                     executes a Haskell script, it automatically stores a+                     compiled cache of the script to the disk, so that the+                     compilation overhead can be avoided in subsequent runs.+license:             PublicDomain+license-file:        LICENSE+author:              Takano Akio+maintainer:          aljee@hyper.cx+-- copyright:           +category:            Development+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++executable crunghc+  main-is:  main.hs+  -- other-modules:       +  -- other-extensions:    +  build-depends:       base >=4.5 && <4.7, process >= 1.0, filepath >= 1.3,+                       directory >= 1.2, text >= 0.11, bytestring >= 0.9.2.1, SHA >= 1.6,+                       transformers >= 0.3, filelock >= 0.0, time >= 1.4+  -- hs-source-dirs:      +  default-language:    Haskell2010++  if !os(windows)+    build-depends:    unix+    cpp-options:      -DUSE_UNIX

@@ -0,0 +1,242 @@+{-# LANGUAGE CPP #-}++import Control.Applicative+import qualified Control.Exception as E+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.Char+import qualified Data.Digest.Pure.SHA as SHA+import Data.List+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time.Clock+import Data.Maybe+import Data.Monoid+import System.Directory+import System.Environment+import System.Exit+import System.FileLock+import System.FilePath+import System.IO+import System.IO.Error+import System.Process++#if USE_UNIX+import System.Posix.Files (createLink)+#endif++data Config = Config+  { cmdGhcFlags :: [String]+  , cmdScriptPath :: FilePath+  , cmdScriptArgs :: [String]+  }++data CachePlan = CP+  { cpCachedir :: FilePath+  , cpStrategy :: CacheStrategy+  }++data CacheStrategy+  = HashPath FilePath+  | HashContent+      S.ByteString -- ^ 0-separated ghc args+      S.ByteString -- ^ content++main :: IO ()+main = do+  config <- fromRightIO . parseConfig =<< getArgs+  plan <- chooseCachePlan config+  createDirectoryIfMissing True $ cpCachedir plan+  (tempExeCopy, cleanup) <- withFileLock (lockfile plan) Exclusive $ \_ -> do+    needRecomp <- testRecompilationNeeded config plan+    when needRecomp $ recompile config plan++    -- Here we make a copy of the cached executable, and run that copy.+    -- This is needed for two reasons:+    --+    -- 1. we want to avoid the race condition where some other process replaces+    --  the cached executable after we unlock it and before we execute it.+    -- 2. on Windows you cannot replace an executable while it's running.+    makeTemporaryExeCopy plan+  runTemp config tempExeCopy `E.finally` cleanup++parseConfig :: [String] -> Either String Config+parseConfig args = case span ("-" `isPrefixOf`) args of+  (flags, path:scriptArgs) -> Right Config+    { cmdGhcFlags = flags+    , cmdScriptPath = path+    , cmdScriptArgs = scriptArgs+    }+  _ -> Left "No file is given"++lockfile :: CachePlan -> FilePath+lockfile plan = cpCachedir plan </> "lock"++-- | Decide where to store the cache, and which strategy to use.+chooseCachePlan :: Config -> IO CachePlan+chooseCachePlan config = do+  contentHead <- readPrefix (contentHashThreshold + 1) $ cmdScriptPath config+  let contentAndGhcArgs = contentHead <> packedGhcArgs+  (toHash, strat) <- if S.length contentAndGhcArgs <= contentHashThreshold+    then return (contentAndGhcArgs, HashContent packedGhcArgs contentHead)+    else do+      canonicalScriptPath <- canonicalizePath $ cmdScriptPath config+      return+        ( T.encodeUtf8 $ T.pack canonicalScriptPath+        , HashPath canonicalScriptPath+        )+  appDir <- getAppUserDataDirectory "crunghc"+  ghcVersion <- filter (/='\n') <$> readProcess "ghc" ["--numeric-version"] ""+  return $ CP+    { cpCachedir = appDir </> ghcVersion </> hashToDirname toHash+    , cpStrategy = strat+    }+  where+    -- | Use filepath hashing if the total size of the ghc command line and the+    -- script itself exceeds this value. In particular it should be large enough+    -- to allow the boilerplate Setup.hs to be content-hashed.+    contentHashThreshold = 50++    packedGhcArgs = S.intercalate (S.singleton 0) $+      map (T.encodeUtf8 . T.pack) $ cmdGhcFlags config++readPrefix :: Int -> FilePath -> IO S.ByteString+readPrefix n path = withFile path ReadMode $ \h -> S.hGet h n++-- | Does the script need to be recompiled?+testRecompilationNeeded :: Config -> CachePlan -> IO Bool+testRecompilationNeeded config CP{cpCachedir=cachedir, cpStrategy=strat}+    = fmap isNothing $ runMaybeT $ do+  case strat of+    HashPath canonicalScriptPath -> do+      shouldEqual canonicalScriptPath $+        readFile $ cachedir </> "path"+    HashContent ghcArgs content -> do+      shouldEqual ghcArgs $ S.readFile $ cachedir </> "ghc-args"+      shouldEqual content $ S.readFile $ cachedir </> "content"+  exeModTime <- checkIOError $+    getModificationTime $ cachedir </> "cached.exe"+  deps <- readDependencies $ cachedir </> "deps"+  if length deps == 1+    then do -- Single-file program+      scriptModTime <- checkIOError $ getModificationTime $+        cmdScriptPath config+      guard $ exeModTime > scriptModTime+    else do+      -- Make sure that the working directory is the same as when the cache+      -- was created.+      wdir <- liftIO getCurrentDirectory+      cachedWdir <- checkIOError $ readFile $ cachedir </> "wdir"+      guard $ wdir == cachedWdir+      -- Check for modification times of all the source files+      forM_ deps $ \srcPath -> do+        modTime <- checkIOError $ getModificationTime srcPath+        guard $ exeModTime > modTime+  where+    shouldEqual val action = do+      r <- checkIOError action+      guard $ val == r++-- | Compile the script and populate the cache directory.+recompile :: Config -> CachePlan -> IO ()+recompile config CP{cpCachedir=cachedir, cpStrategy=strat} = do+  createDirectoryIfMissing True $ cachedir </> "build"+  runGhc $ fullGhcArgs ["-M", "-dep-makefile", cachedir </> "deps"]+  runGhc $ fullGhcArgs+    [ "-hidir", builddir, "-odir", builddir+    , "-threaded"+    , "-o", cachedir </> "cached.exe"+    ]+  -- Try to strip it, but don't care if it fails.+  void (rawSystem "strip" [cachedir </> "cached.exe"])+    `E.catch` \e -> const (return ()) (e::E.IOException)+  wdir <- getCurrentDirectory+  writeFile (cachedir </> "wdir") wdir+  case strat of+    HashPath canonicalScriptPath ->+      writeFile (cachedir </> "path") canonicalScriptPath+    HashContent ghcArgs content -> do+      S.writeFile (cachedir </> "ghc-args") ghcArgs+      S.writeFile (cachedir </> "content") content+  where+    fullGhcArgs flags = cmdGhcFlags config ++ flags ++ [cmdScriptPath config]+    builddir = cachedir </> "build"+    runGhc args = do+      (exitCode, _, err) <- readProcessWithExitCode "ghc" args ""+      case exitCode of+        ExitSuccess -> return ()+        ExitFailure{} -> die err++-- | Create a temporary copy or hard link of the cached executable for+-- exclusive use by this process. Return the path of the copy and a cleanup+-- action.+makeTemporaryExeCopy :: CachePlan -> IO (FilePath, IO ())+makeTemporaryExeCopy plan = do+  createDirectoryIfMissing True tempdir+  mydir <- createFreshDirectoryIn tempdir+  let tempPath = mydir </> "temp.exe"+  linkOrCopy (cpCachedir plan </> "cached.exe") tempPath+  return (tempPath, removeDirectoryRecursive mydir)+  where+    tempdir = cpCachedir plan </> "temp"+#if USE_UNIX+    -- Use hard links if available, because they are much cheaper to create.+    linkOrCopy = createLink+#else+    linkOrCopy = copyFile+#endif++createFreshDirectoryIn :: FilePath -> IO FilePath+createFreshDirectoryIn dir = loop =<< randomNumber+  where+    loop n = do+      let fresh = dir </> show n+      r <- E.tryJust (guard . isAlreadyExistsError) $ createDirectory fresh+      case r of+        Left{} -> loop $ n + 1+        Right{} -> return fresh++    randomNumber = do+      tod <- utctDayTime <$> getCurrentTime+      return $ flip mod (100000::Int) $+        floor $ realToFrac tod * (1000000 :: Double)++-- | Run the cached executable.+runTemp :: Config -> FilePath -> IO ()+runTemp config path = exitWith =<< rawSystem path (cmdScriptArgs config)++readDependencies :: FilePath -> MaybeT IO [FilePath]+readDependencies depFile = do+  lns <- checkIOError $ lines <$> readFile depFile+  return $ mapMaybe extractDependency lns++extractDependency :: String -> Maybe FilePath+extractDependency ln+  | looksLikeSourceFile = Just $ takeWhileEnd (not . isSpace) ln+  | otherwise = Nothing+  where+    looksLikeSourceFile =+      ".hs" `isSuffixOf` ln ||+      ".lhs" `isSuffixOf` ln++takeWhileEnd :: (a -> Bool) -> [a] -> [a]+takeWhileEnd p = reverse . takeWhile p . reverse++checkIOError :: IO a -> MaybeT IO a+checkIOError action = MaybeT $+  (Just <$> action) `E.catch` \e -> const (return Nothing) (e::IOError)++hashToDirname :: S.ByteString -> FilePath+hashToDirname = SHA.showDigest . SHA.sha1 . L.fromChunks . (:[])++fromRightIO :: Either String a -> IO a+fromRightIO = either die return++die :: String -> IO a+die msg = do+  prog <- getProgName+  hPutStrLn stderr $ prog ++ ": " ++ msg+  exitFailure