Skip to content
Browse files

compile with GHC 7.6.1

  • Loading branch information...
1 parent c890d44 commit 194329a8942ca514f570ee6cf1a4e6dff42cbc2a @JPMoresmau committed Oct 5, 2012
Showing with 476 additions and 474 deletions.
  1. +3 −3 scion-browser.cabal
  2. +50 −50 src/Main.hs
  3. +200 −200 src/Scion/Packages.hs
  4. +222 −220 src/Scion/PersistentBrowser/TempFile.hs
  5. +1 −1 src/Server/PersistentCommands.hs
View
6 scion-browser.cabal
@@ -49,7 +49,7 @@ library
if impl(ghc >= 7.0)
build-depends:
- containers >= 0.2 && < 0.5,
+ containers >= 0.2,
directory >= 1.1,
filepath >= 1.2,
bytestring,
@@ -96,7 +96,7 @@ executable scion-browser
hs-source-dirs: src
main-is: Main.hs
build-depends:
- haskeline >= 0.6 && < 0.7,
+ haskeline >= 0.7,
attoparsec >= 0.10,
base == 4.*,
mtl >= 2,
@@ -128,7 +128,7 @@ executable scion-browser
if impl(ghc >= 7.0)
build-depends:
- containers >= 0.2 && < 0.5,
+ containers >= 0.2,
directory >= 1.1,
filepath >= 1.2,
bytestring,
View
100 src/Main.hs
@@ -1,50 +1,50 @@
-{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
-
-module Main where
-
-import qualified Codec.Compression.Zlib as Zlib
-import Control.Monad.State
-import Data.Aeson
-import qualified Data.Aeson.Types as T
-import qualified Data.Attoparsec.ByteString as Atto
-import qualified Data.ByteString.Lazy.Char8 as LBS
-import qualified Data.ByteString.UTF8 as BSU(fromString)
-import Server.PersistentCommands
-import System.Console.Haskeline
-import System.IO (hFlush, stdout, stderr)
-import System.Environment (getArgs)
-import Data.Version (showVersion)
-import Paths_scion_browser
-import Scion.PersistentBrowser.Util (logToStdout)
-
-import GHC.IO.Handle (hDuplicate,hDuplicateTo)
-
-main :: IO ()
-main = do args <- getArgs
- case args of
- ("--version":_) -> putStrLn ("scion-browser executable, version " ++ (showVersion version))
- _ -> do runStateT (runInputT defaultSettings loop) initialState
- return ()
-
-loop :: InputT BrowserM ()
-loop = do
- maybeLine <- getInputLine ""
- case maybeLine of
- Nothing -> return () -- ctrl+D or EOF
- Just line -> do
- case Atto.parse json (BSU.fromString line) of
- Atto.Fail _ _ e -> (liftIO $ logToStdout ("error in command: " ++ e)) >> loop
- Atto.Partial _ -> (liftIO $ logToStdout ("incomplete data error in command: ")) >> loop
- Atto.Done _ value -> case T.parse parseJSON value of
- Error e -> (liftIO $ logToStdout ("error in command: " ++ e)) >> loop
- Success cmd -> do
- stdout_excl <- liftIO $ hDuplicate stdout
- liftIO $ hDuplicateTo stderr stdout -- redirect stdout to stderr
- (res, continue) <- lift $ executeCommand cmd
- liftIO $ hDuplicateTo stdout_excl stdout -- redirect stdout to original stdout
- let encoded = LBS.append (encode res) "\n"
- compressed = Zlib.compressWith Zlib.defaultCompressParams { Zlib.compressLevel = Zlib.bestSpeed } encoded
- liftIO $ LBS.putStr compressed
- liftIO $ hFlush stdout
- if continue then loop else return ()
-
+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
+
+module Main where
+
+import qualified Codec.Compression.Zlib as Zlib
+import Control.Monad.State.Strict
+import Data.Aeson
+import qualified Data.Aeson.Types as T
+import qualified Data.Attoparsec.ByteString as Atto
+import qualified Data.ByteString.Lazy.Char8 as LBS
+import qualified Data.ByteString.UTF8 as BSU(fromString)
+import Server.PersistentCommands
+import System.Console.Haskeline
+import System.IO (hFlush, stdout, stderr)
+import System.Environment (getArgs)
+import Data.Version (showVersion)
+import Paths_scion_browser
+import Scion.PersistentBrowser.Util (logToStdout)
+
+import GHC.IO.Handle (hDuplicate,hDuplicateTo)
+
+main :: IO ()
+main = do args <- getArgs
+ case args of
+ ("--version":_) -> putStrLn ("scion-browser executable, version " ++ (showVersion version))
+ _ -> do runStateT (runInputT defaultSettings loop) initialState
+ return ()
+
+loop :: InputT BrowserM ()
+loop = do
+ maybeLine <- getInputLine ""
+ case maybeLine of
+ Nothing -> return () -- ctrl+D or EOF
+ Just line -> do
+ case Atto.parse json (BSU.fromString line) of
+ Atto.Fail _ _ e -> (liftIO $ logToStdout ("error in command: " ++ e)) >> loop
+ Atto.Partial _ -> (liftIO $ logToStdout ("incomplete data error in command: ")) >> loop
+ Atto.Done _ value -> case T.parse parseJSON value of
+ Error e -> (liftIO $ logToStdout ("error in command: " ++ e)) >> loop
+ Success cmd -> do
+ stdout_excl <- liftIO $ hDuplicate stdout
+ liftIO $ hDuplicateTo stderr stdout -- redirect stdout to stderr
+ (res, continue) <- lift $ executeCommand cmd
+ liftIO $ hDuplicateTo stdout_excl stdout -- redirect stdout to original stdout
+ let encoded = LBS.append (encode res) "\n"
+ compressed = Zlib.compressWith Zlib.defaultCompressParams { Zlib.compressLevel = Zlib.bestSpeed } encoded
+ liftIO $ LBS.putStr compressed
+ liftIO $ hFlush stdout
+ if continue then loop else return ()
+
View
400 src/Scion/Packages.hs
@@ -1,200 +1,200 @@
-{-# LANGUAGE CPP #-}
--- |
--- Module : Scion.Packages
--- Author : Thiago Arrais
--- Copyright : (c) Thiago Arrais 2009
--- License : BSD-style
--- Url : http://stackoverflow.com/questions/1522104/how-to-programmatically-retrieve-ghc-package-information
---
--- Maintainer : nominolo@gmail.com
--- Stability : experimental
--- Portability : portable
---
--- Cabal-related functionality.
-module Scion.Packages ( getPkgInfos ) where
-
-import Prelude hiding (Maybe)
-import qualified Config
-import qualified System.Info
-import Data.List
-import Data.Maybe
-import Control.Monad
-import Distribution.InstalledPackageInfo
-import Distribution.Text
-import System.Directory
-import System.Environment (getEnv)
-import System.FilePath
-import System.IO
-import System.IO.Error
-
-import GHC.Paths
-
-import qualified Control.Exception as Exception
-
--- This was borrowed from the ghc-pkg source:
-type InstalledPackageInfoString = InstalledPackageInfo_ String
-
--- | Types of cabal package databases
-data CabalPkgDBType =
- PkgDirectory FilePath
- | PkgFile FilePath
-
-type InstalledPackagesList = [(FilePath, [InstalledPackageInfo])]
-
--- | Fetch the installed package info from the global and user package.conf
--- databases, mimicking the functionality of ghc-pkg.
-
-getPkgInfos :: IO InstalledPackagesList
-getPkgInfos =
- let
- -- | Test for package database's presence in a given directory
- -- NB: The directory is returned for later scanning by listConf,
- -- which parses the actual package database file(s).
- lookForPackageDBIn :: FilePath -> IO (Maybe InstalledPackagesList)
- lookForPackageDBIn dir =
- let
- path_dir = dir </> "package.conf.d"
- path_file = dir </> "package.conf"
- in do
- exists_dir <- doesDirectoryExist path_dir
- if exists_dir
- then do
- pkgs <- readContents (PkgDirectory path_dir)
- return $ Just pkgs
- else do
- exists_file <- doesFileExist path_file
- if exists_file
- then do
- pkgs <- readContents (PkgFile path_file)
- return $ Just pkgs
- else return Nothing
-
- currentArch :: String
- currentArch = System.Info.arch
-
- currentOS :: String
- currentOS = System.Info.os
-
- ghcVersion :: String
- ghcVersion = Config.cProjectVersion
- in do
- -- Get the global package configuration database:
- global_conf <- do
- r <- lookForPackageDBIn getLibDir
- case r of
- Nothing -> ioError $ userError ("Can't find package database in " ++ getLibDir)
- Just pkgs -> return $ pkgs
-
- -- Get the user package configuration database
- e_appdir <- try $ getAppUserDataDirectory "ghc"
- user_conf <- do
- case e_appdir of
- Left _ -> return []
- Right appdir -> do
- let subdir = currentArch ++ '-':currentOS ++ '-':ghcVersion
- dir = appdir </> subdir
- r <- lookForPackageDBIn dir
- case r of
- Nothing -> return []
- Just pkgs -> return pkgs
-
- -- Process GHC_PACKAGE_PATH, if present:
- e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH")
- env_stack <- do
- case e_pkg_path of
- Left _ -> return []
- Right path -> do
- pkgs <- mapM readContents [(PkgDirectory pkg) | pkg <- splitSearchPath path]
- return $ concat pkgs
-
- -- Send back the combined installed packages list:
- return (env_stack ++ user_conf ++ global_conf)
-
--- | Read the contents of the given directory, searching for ".conf" files, and parse the
--- package contents. Returns a singleton list (directory, [installed packages])
-
-readContents :: CabalPkgDBType -- ^ The package database
- -> IO [(FilePath, [InstalledPackageInfo])] -- ^ Installed packages
-
-readContents pkgdb =
- let
- -- | List package configuration files that might live in the given directory
- listConf :: FilePath -> IO [FilePath]
- listConf dbdir = do
- conf_dir_exists <- doesDirectoryExist dbdir
- if conf_dir_exists
- then do
- files <- getDirectoryContents dbdir
- return [ dbdir </> file | file <- files, isSuffixOf ".conf" file]
- else return []
-
- -- | Read a file, ensuring that UTF8 coding is used for GCH >= 6.12
- readUTF8File :: FilePath -> IO String
- readUTF8File file = do
- h <- openFile file ReadMode
-#if __GLASGOW_HASKELL__ >= 612
- -- fix the encoding to UTF-8
- hSetEncoding h utf8
- catch (hGetContents h) (\_ -> do
- -- logInfo $ ioeGetErrorString err
- hClose h
- h' <- openFile file ReadMode
- hSetEncoding h' localeEncoding
- hGetContents h'
- )
-#else
- hGetContents h
-#endif
-
-
- -- | This function was lifted directly from ghc-pkg. Its sole purpose is
- -- parsing an input package description string and producing an
- -- InstalledPackageInfo structure.
- convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
- convertPackageInfoIn
- (pkgconf@(InstalledPackageInfo { exposedModules = e,
- hiddenModules = h })) =
- pkgconf{ exposedModules = map convert e,
- hiddenModules = map convert h }
- where convert = fromJust . simpleParse
-
- -- | Utility function that just flips the arguments to Control.Exception.catch
- catchError :: IO a -> (String -> IO a) -> IO a
- catchError io handler = io `Exception.catch` handler'
- where handler' (Exception.ErrorCall err) = handler err
-
- -- | Slightly different approach in Cabal 1.8 series, with the package.conf.d
- -- directories, where individual package configuration files are association
- -- pairs.
- pkgInfoReader :: FilePath
- -> IO [InstalledPackageInfo]
- pkgInfoReader f =
- catch (
- do
- pkgStr <- readUTF8File f
- let pkgInfo = parseInstalledPackageInfo pkgStr
- case pkgInfo of
- ParseOk _ info -> return [info]
- ParseFailed _ -> do
- -- logInfo (show err)
- return [emptyInstalledPackageInfo]
- ) (\_->return [emptyInstalledPackageInfo])
-
- in case pkgdb of
- (PkgDirectory pkgdbDir) -> do
- confs <- listConf pkgdbDir
- pkgInfoList <- mapM pkgInfoReader confs
- return [(pkgdbDir, join pkgInfoList)]
-
- (PkgFile dbFile) -> do
- pkgStr <- readUTF8File dbFile
- let pkgs = map convertPackageInfoIn $ read pkgStr
- pkgInfoList <-
- Exception.evaluate pkgs
- `catchError`
- (\e-> ioError $ userError $ "parsing " ++ dbFile ++ ": " ++ (show e))
- return [(takeDirectory dbFile, pkgInfoList)]
-
--- GHC.Path sets libdir for us...
-getLibDir :: String
-getLibDir = libdir
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
+-- |
+-- Module : Scion.Packages
+-- Author : Thiago Arrais
+-- Copyright : (c) Thiago Arrais 2009
+-- License : BSD-style
+-- Url : http://stackoverflow.com/questions/1522104/how-to-programmatically-retrieve-ghc-package-information
+--
+-- Maintainer : nominolo@gmail.com
+-- Stability : experimental
+-- Portability : portable
+--
+-- Cabal-related functionality.
+module Scion.Packages ( getPkgInfos ) where
+
+import Prelude hiding (Maybe)
+import qualified Config
+import qualified System.Info
+import Data.List
+import Data.Maybe
+import Control.Monad
+import Distribution.InstalledPackageInfo
+import Distribution.Text
+import System.Directory
+import System.Environment (getEnv)
+import System.FilePath
+import System.IO
+import qualified Control.Exception as Exc
+
+import GHC.Paths
+
+import qualified Control.Exception as Exception
+
+-- This was borrowed from the ghc-pkg source:
+type InstalledPackageInfoString = InstalledPackageInfo_ String
+
+-- | Types of cabal package databases
+data CabalPkgDBType =
+ PkgDirectory FilePath
+ | PkgFile FilePath
+
+type InstalledPackagesList = [(FilePath, [InstalledPackageInfo])]
+
+-- | Fetch the installed package info from the global and user package.conf
+-- databases, mimicking the functionality of ghc-pkg.
+
+getPkgInfos :: IO InstalledPackagesList
+getPkgInfos =
+ let
+ -- | Test for package database's presence in a given directory
+ -- NB: The directory is returned for later scanning by listConf,
+ -- which parses the actual package database file(s).
+ lookForPackageDBIn :: FilePath -> IO (Maybe InstalledPackagesList)
+ lookForPackageDBIn dir =
+ let
+ path_dir = dir </> "package.conf.d"
+ path_file = dir </> "package.conf"
+ in do
+ exists_dir <- doesDirectoryExist path_dir
+ if exists_dir
+ then do
+ pkgs <- readContents (PkgDirectory path_dir)
+ return $ Just pkgs
+ else do
+ exists_file <- doesFileExist path_file
+ if exists_file
+ then do
+ pkgs <- readContents (PkgFile path_file)
+ return $ Just pkgs
+ else return Nothing
+
+ currentArch :: String
+ currentArch = System.Info.arch
+
+ currentOS :: String
+ currentOS = System.Info.os
+
+ ghcVersion :: String
+ ghcVersion = Config.cProjectVersion
+ in do
+ -- Get the global package configuration database:
+ global_conf <- do
+ r <- lookForPackageDBIn getLibDir
+ case r of
+ Nothing -> ioError $ userError ("Can't find package database in " ++ getLibDir)
+ Just pkgs -> return $ pkgs
+
+ -- Get the user package configuration database
+ e_appdir <- Exc.try $ getAppUserDataDirectory "ghc"
+ user_conf <- do
+ case e_appdir of
+ Left (_::Exc.IOException) -> return []
+ Right appdir -> do
+ let subdir = currentArch ++ '-':currentOS ++ '-':ghcVersion
+ dir = appdir </> subdir
+ r <- lookForPackageDBIn dir
+ case r of
+ Nothing -> return []
+ Just pkgs -> return pkgs
+
+ -- Process GHC_PACKAGE_PATH, if present:
+ e_pkg_path <- Exc.try $ getEnv "GHC_PACKAGE_PATH"
+ env_stack <- do
+ case e_pkg_path of
+ Left (_::Exc.IOException) -> return []
+ Right path -> do
+ pkgs <- mapM readContents [(PkgDirectory pkg) | pkg <- splitSearchPath path]
+ return $ concat pkgs
+
+ -- Send back the combined installed packages list:
+ return (env_stack ++ user_conf ++ global_conf)
+
+-- | Read the contents of the given directory, searching for ".conf" files, and parse the
+-- package contents. Returns a singleton list (directory, [installed packages])
+
+readContents :: CabalPkgDBType -- ^ The package database
+ -> IO [(FilePath, [InstalledPackageInfo])] -- ^ Installed packages
+
+readContents pkgdb =
+ let
+ -- | List package configuration files that might live in the given directory
+ listConf :: FilePath -> IO [FilePath]
+ listConf dbdir = do
+ conf_dir_exists <- doesDirectoryExist dbdir
+ if conf_dir_exists
+ then do
+ files <- getDirectoryContents dbdir
+ return [ dbdir </> file | file <- files, isSuffixOf ".conf" file]
+ else return []
+
+ -- | Read a file, ensuring that UTF8 coding is used for GCH >= 6.12
+ readUTF8File :: FilePath -> IO String
+ readUTF8File file = do
+ h <- openFile file ReadMode
+#if __GLASGOW_HASKELL__ >= 612
+ -- fix the encoding to UTF-8
+ hSetEncoding h utf8
+ catch (hGetContents h) (\_ -> do
+ -- logInfo $ ioeGetErrorString err
+ hClose h
+ h' <- openFile file ReadMode
+ hSetEncoding h' localeEncoding
+ hGetContents h'
+ )
+#else
+ hGetContents h
+#endif
+
+
+ -- | This function was lifted directly from ghc-pkg. Its sole purpose is
+ -- parsing an input package description string and producing an
+ -- InstalledPackageInfo structure.
+ convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
+ convertPackageInfoIn
+ (pkgconf@(InstalledPackageInfo { exposedModules = e,
+ hiddenModules = h })) =
+ pkgconf{ exposedModules = map convert e,
+ hiddenModules = map convert h }
+ where convert = fromJust . simpleParse
+
+ -- | Utility function that just flips the arguments to Control.Exception.catch
+ catchError :: IO a -> (String -> IO a) -> IO a
+ catchError io handler = io `Exception.catch` handler'
+ where handler' (Exception.ErrorCall err) = handler err
+
+ -- | Slightly different approach in Cabal 1.8 series, with the package.conf.d
+ -- directories, where individual package configuration files are association
+ -- pairs.
+ pkgInfoReader :: FilePath
+ -> IO [InstalledPackageInfo]
+ pkgInfoReader f =
+ catch (
+ do
+ pkgStr <- readUTF8File f
+ let pkgInfo = parseInstalledPackageInfo pkgStr
+ case pkgInfo of
+ ParseOk _ info -> return [info]
+ ParseFailed _ -> do
+ -- logInfo (show err)
+ return [emptyInstalledPackageInfo]
+ ) (\_->return [emptyInstalledPackageInfo])
+
+ in case pkgdb of
+ (PkgDirectory pkgdbDir) -> do
+ confs <- listConf pkgdbDir
+ pkgInfoList <- mapM pkgInfoReader confs
+ return [(pkgdbDir, join pkgInfoList)]
+
+ (PkgFile dbFile) -> do
+ pkgStr <- readUTF8File dbFile
+ let pkgs = map convertPackageInfoIn $ read pkgStr
+ pkgInfoList <-
+ Exception.evaluate pkgs
+ `catchError`
+ (\e-> ioError $ userError $ "parsing " ++ dbFile ++ ": " ++ (show e))
+ return [(takeDirectory dbFile, pkgInfoList)]
+
+-- GHC.Path sets libdir for us...
+getLibDir :: String
+getLibDir = libdir
View
442 src/Scion/PersistentBrowser/TempFile.hs
@@ -1,220 +1,222 @@
--- Taken from Cabal source
--- http://hackage.haskell.org/package/Cabal-1.10.2.0
-
-{-# OPTIONS -cpp #-}
--- OPTIONS required for ghc-6.4.x compat, and must appear first
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -cpp #-}
-{-# OPTIONS_NHC98 -cpp #-}
-{-# OPTIONS_JHC -fcpp #-}
--- #hide
-module Scion.PersistentBrowser.TempFile (
- openTempFile,
- openBinaryTempFile,
- openNewBinaryFile,
- createTempDirectory,
- ) where
-
-
-import System.FilePath ((</>))
-import Foreign.C (eEXIST)
-
-#if __NHC__ || __HUGS__
-import System.IO (openFile, openBinaryFile,
- Handle, IOMode(ReadWriteMode))
-import System.Directory (doesFileExist)
-import System.FilePath ((<.>), splitExtension)
-import System.IO.Error (try, isAlreadyExistsError)
-#else
-import System.IO (Handle, openTempFile, openBinaryTempFile)
-import Data.Bits ((.|.))
-import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR,
- o_BINARY, o_NONBLOCK, o_NOCTTY)
-import System.IO.Error (try, isAlreadyExistsError)
-#if __GLASGOW_HASKELL__ >= 611
-import System.Posix.Internals (withFilePath)
-#else
-import Foreign.C (withCString)
-#endif
-import Foreign.C (CInt)
-#if __GLASGOW_HASKELL__ >= 611
-import GHC.IO.Handle.FD (fdToHandle)
-#else
-import GHC.Handle (fdToHandle)
-#endif
-#endif
-import Foreign.C (getErrno, errnoToIOError)
-
-#if __NHC__
-import System.Posix.Types (CPid(..))
-foreign import ccall unsafe "getpid" c_getpid :: IO CPid
-#else
-import System.Posix.Internals (c_getpid)
-#endif
-
-#ifdef mingw32_HOST_OS
-import System.Directory ( createDirectory )
-#else
-import qualified System.Posix
-#endif
-
-#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610))
-#define NEW_EXCEPTION
-#endif
-
-import qualified Control.Exception as Exception
-
-onException :: IO a -> IO b -> IO a
-#ifdef NEW_EXCEPTION
-onException = Exception.onException
-#else
-onException io what = io `Exception.catch` \e -> do what
- Exception.throw e
-#endif
-
--- ------------------------------------------------------------
--- * temporary files
--- ------------------------------------------------------------
-
--- This is here for Haskell implementations that do not come with
--- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.
--- TODO: Not sure about jhc
-
-#if __NHC__ || __HUGS__
--- use a temporary filename that doesn't already exist.
--- NB. *not* secure (we don't atomically lock the tmp file we get)
-openTempFile :: FilePath -> String -> IO (FilePath, Handle)
-openTempFile tmp_dir template
- = do x <- getProcessID
- findTempName x
- where
- (templateBase, templateExt) = splitExtension template
- findTempName :: Int -> IO (FilePath, Handle)
- findTempName x
- = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt
- b <- doesFileExist path
- if b then findTempName (x+1)
- else do hnd <- openFile path ReadWriteMode
- return (path, hnd)
-
-openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
-openBinaryTempFile tmp_dir template
- = do x <- getProcessID
- findTempName x
- where
- (templateBase, templateExt) = splitExtension template
- findTempName :: Int -> IO (FilePath, Handle)
- findTempName x
- = do let path = tmp_dir </> (templateBase ++ show x) <.> templateExt
- b <- doesFileExist path
- if b then findTempName (x+1)
- else do hnd <- openBinaryFile path ReadWriteMode
- return (path, hnd)
-
-openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
-openNewBinaryFile = openBinaryTempFile
-
-getProcessID :: IO Int
-getProcessID = fmap fromIntegral c_getpid
-#else
--- This is a copy/paste of the openBinaryTempFile definition, but
--- if uses 666 rather than 600 for the permissions. The base library
--- needs to be changed to make this better.
-openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
-openNewBinaryFile dir template = do
- pid <- c_getpid
- findTempName pid
- where
- -- We split off the last extension, so we can use .foo.ext files
- -- for temporary files (hidden on Unix OSes). Unfortunately we're
- -- below filepath in the hierarchy here.
- (prefix,suffix) =
- case break (== '.') $ reverse template of
- -- First case: template contains no '.'s. Just re-reverse it.
- (rev_suffix, "") -> (reverse rev_suffix, "")
- -- Second case: template contains at least one '.'. Strip the
- -- dot from the prefix and prepend it to the suffix (if we don't
- -- do this, the unique number will get added after the '.' and
- -- thus be part of the extension, which is wrong.)
- (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
- -- Otherwise, something is wrong, because (break (== '.')) should
- -- always return a pair with either the empty string or a string
- -- beginning with '.' as the second component.
- _ -> error "bug in System.IO.openTempFile"
-
- oflags = rw_flags .|. o_EXCL .|. o_BINARY
-
-#if __GLASGOW_HASKELL__ < 611
- withFilePath = withCString
-#endif
-
- findTempName x = do
- fd <- withFilePath filepath $ \ f ->
- c_open f oflags 0o666
- if fd < 0
- then do
- errno <- getErrno
- if errno == eEXIST
- then findTempName (x+1)
- else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
- else do
- -- TODO: We want to tell fdToHandle what the filepath is,
- -- as any exceptions etc will only be able to report the
- -- fd currently
- h <-
-#if __GLASGOW_HASKELL__ >= 609
- fdToHandle fd
-#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS)
- -- fdToHandle is borked on Windows with ghc-6.6.x
- openFd (fromIntegral fd) Nothing False filepath
- ReadWriteMode True
-#else
- fdToHandle (fromIntegral fd)
-#endif
- `onException` c_close fd
- return (filepath, h)
- where
- filename = prefix ++ show x ++ suffix
- filepath = dir `combine` filename
-
- -- FIXME: bits copied from System.FilePath
- combine a b
- | null b = a
- | null a = b
- | last a == pathSeparator = a ++ b
- | otherwise = a ++ [pathSeparator] ++ b
-
--- FIXME: Should use filepath library
-pathSeparator :: Char
-#ifdef mingw32_HOST_OS
-pathSeparator = '\\'
-#else
-pathSeparator = '/'
-#endif
-
--- FIXME: Copied from GHC.Handle
-std_flags, output_flags, rw_flags :: CInt
-std_flags = o_NONBLOCK .|. o_NOCTTY
-output_flags = std_flags .|. o_CREAT
-rw_flags = output_flags .|. o_RDWR
-#endif
-
-createTempDirectory :: FilePath -> String -> IO FilePath
-createTempDirectory dir template = do
- pid <- c_getpid
- findTempName pid
- where
- findTempName x = do
- let dirpath = dir </> template ++ show x
- r <- try $ mkPrivateDir dirpath
- case r of
- Right _ -> return dirpath
- Left e | isAlreadyExistsError e -> findTempName (x+1)
- | otherwise -> ioError e
-
-mkPrivateDir :: String -> IO ()
-#ifdef mingw32_HOST_OS
-mkPrivateDir s = createDirectory s
-#else
-mkPrivateDir s = System.Posix.createDirectory s 0o700
-#endif
+-- Taken from Cabal source
+-- http://hackage.haskell.org/package/Cabal-1.10.2.0
+
+{-# OPTIONS -cpp #-}
+-- OPTIONS required for ghc-6.4.x compat, and must appear first
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# OPTIONS_GHC -cpp #-}
+{-# OPTIONS_NHC98 -cpp #-}
+{-# OPTIONS_JHC -fcpp #-}
+-- #hide
+module Scion.PersistentBrowser.TempFile (
+ openTempFile,
+ openBinaryTempFile,
+ openNewBinaryFile,
+ createTempDirectory,
+ ) where
+
+
+import System.FilePath ((</>))
+import Foreign.C (eEXIST)
+
+#if __NHC__ || __HUGS__
+import System.IO (openFile, openBinaryFile,
+ Handle, IOMode(ReadWriteMode))
+import System.Directory (doesFileExist)
+import System.FilePath ((<.>), splitExtension)
+import System.IO.Error (isAlreadyExistsError)
+#else
+import System.IO (Handle, openTempFile, openBinaryTempFile)
+import Data.Bits ((.|.))
+import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR,
+ o_BINARY, o_NONBLOCK, o_NOCTTY)
+
+import qualified Control.Exception as Exc
+import qualified GHC.IO.Exception as Exc
+#if __GLASGOW_HASKELL__ >= 611
+import System.Posix.Internals (withFilePath)
+#else
+import Foreign.C (withCString)
+#endif
+import Foreign.C (CInt)
+#if __GLASGOW_HASKELL__ >= 611
+import GHC.IO.Handle.FD (fdToHandle)
+#else
+import GHC.Handle (fdToHandle)
+#endif
+#endif
+import Foreign.C (getErrno, errnoToIOError)
+
+#if __NHC__
+import System.Posix.Types (CPid(..))
+foreign import ccall unsafe "getpid" c_getpid :: IO CPid
+#else
+import System.Posix.Internals (c_getpid)
+#endif
+
+#ifdef mingw32_HOST_OS
+import System.Directory ( createDirectory )
+#else
+import qualified System.Posix
+#endif
+
+#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610))
+#define NEW_EXCEPTION
+#endif
+
+import qualified Control.Exception as Exception
+
+onException :: IO a -> IO b -> IO a
+#ifdef NEW_EXCEPTION
+onException = Exception.onException
+#else
+onException io what = io `Exception.catch` \e -> do what
+ Exception.throw e
+#endif
+
+-- ------------------------------------------------------------
+-- * temporary files
+-- ------------------------------------------------------------
+
+-- This is here for Haskell implementations that do not come with
+-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.
+-- TODO: Not sure about jhc
+
+#if __NHC__ || __HUGS__
+-- use a temporary filename that doesn't already exist.
+-- NB. *not* secure (we don't atomically lock the tmp file we get)
+openTempFile :: FilePath -> String -> IO (FilePath, Handle)
+openTempFile tmp_dir template
+ = do x <- getProcessID
+ findTempName x
+ where
+ (templateBase, templateExt) = splitExtension template
+ findTempName :: Int -> IO (FilePath, Handle)
+ findTempName x
+ = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt
+ b <- doesFileExist path
+ if b then findTempName (x+1)
+ else do hnd <- openFile path ReadWriteMode
+ return (path, hnd)
+
+openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
+openBinaryTempFile tmp_dir template
+ = do x <- getProcessID
+ findTempName x
+ where
+ (templateBase, templateExt) = splitExtension template
+ findTempName :: Int -> IO (FilePath, Handle)
+ findTempName x
+ = do let path = tmp_dir </> (templateBase ++ show x) <.> templateExt
+ b <- doesFileExist path
+ if b then findTempName (x+1)
+ else do hnd <- openBinaryFile path ReadWriteMode
+ return (path, hnd)
+
+openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
+openNewBinaryFile = openBinaryTempFile
+
+getProcessID :: IO Int
+getProcessID = fmap fromIntegral c_getpid
+#else
+-- This is a copy/paste of the openBinaryTempFile definition, but
+-- if uses 666 rather than 600 for the permissions. The base library
+-- needs to be changed to make this better.
+openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
+openNewBinaryFile dir template = do
+ pid <- c_getpid
+ findTempName pid
+ where
+ -- We split off the last extension, so we can use .foo.ext files
+ -- for temporary files (hidden on Unix OSes). Unfortunately we're
+ -- below filepath in the hierarchy here.
+ (prefix,suffix) =
+ case break (== '.') $ reverse template of
+ -- First case: template contains no '.'s. Just re-reverse it.
+ (rev_suffix, "") -> (reverse rev_suffix, "")
+ -- Second case: template contains at least one '.'. Strip the
+ -- dot from the prefix and prepend it to the suffix (if we don't
+ -- do this, the unique number will get added after the '.' and
+ -- thus be part of the extension, which is wrong.)
+ (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
+ -- Otherwise, something is wrong, because (break (== '.')) should
+ -- always return a pair with either the empty string or a string
+ -- beginning with '.' as the second component.
+ _ -> error "bug in System.IO.openTempFile"
+
+ oflags = rw_flags .|. o_EXCL .|. o_BINARY
+
+#if __GLASGOW_HASKELL__ < 611
+ withFilePath = withCString
+#endif
+
+ findTempName x = do
+ fd <- withFilePath filepath $ \ f ->
+ c_open f oflags 0o666
+ if fd < 0
+ then do
+ errno <- getErrno
+ if errno == eEXIST
+ then findTempName (x+1)
+ else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
+ else do
+ -- TODO: We want to tell fdToHandle what the filepath is,
+ -- as any exceptions etc will only be able to report the
+ -- fd currently
+ h <-
+#if __GLASGOW_HASKELL__ >= 609
+ fdToHandle fd
+#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS)
+ -- fdToHandle is borked on Windows with ghc-6.6.x
+ openFd (fromIntegral fd) Nothing False filepath
+ ReadWriteMode True
+#else
+ fdToHandle (fromIntegral fd)
+#endif
+ `onException` c_close fd
+ return (filepath, h)
+ where
+ filename = prefix ++ show x ++ suffix
+ filepath = dir `combine` filename
+
+ -- FIXME: bits copied from System.FilePath
+ combine a b
+ | null b = a
+ | null a = b
+ | last a == pathSeparator = a ++ b
+ | otherwise = a ++ [pathSeparator] ++ b
+
+-- FIXME: Should use filepath library
+pathSeparator :: Char
+#ifdef mingw32_HOST_OS
+pathSeparator = '\\'
+#else
+pathSeparator = '/'
+#endif
+
+-- FIXME: Copied from GHC.Handle
+std_flags, output_flags, rw_flags :: CInt
+std_flags = o_NONBLOCK .|. o_NOCTTY
+output_flags = std_flags .|. o_CREAT
+rw_flags = output_flags .|. o_RDWR
+#endif
+
+createTempDirectory :: FilePath -> String -> IO FilePath
+createTempDirectory dir template = do
+ pid <- c_getpid
+ findTempName pid
+ where
+ findTempName x = do
+ let dirpath = dir </> template ++ show x
+ r <- Exc.try $ mkPrivateDir dirpath
+ case r of
+ Right _ -> return dirpath
+ Left (e::Exc.IOException) | Exc.AlreadyExists == (Exc.ioe_type e) -> findTempName (x+1)
+ | otherwise -> ioError e
+
+mkPrivateDir :: String -> IO ()
+#ifdef mingw32_HOST_OS
+mkPrivateDir s = createDirectory s
+#else
+mkPrivateDir s = System.Posix.createDirectory s 0o700
+#endif
View
2 src/Server/PersistentCommands.hs
@@ -4,7 +4,7 @@ module Server.PersistentCommands where
import Control.Applicative
import Control.Monad
-import Control.Monad.State
+import Control.Monad.State.Strict
import Data.Aeson
import qualified Data.HashMap.Lazy as M
import Data.Maybe (isJust, fromJust)

0 comments on commit 194329a

Please sign in to comment.
Something went wrong with that request. Please try again.