5c5c05f · elk · git.iko.soy

git.iko.soy/elk

Merge pull request #320 from jsl/313_verify_serialized_interfaces

Give more helpful error messages when deserializing elmi files

commit5c5c05fed9ba32568b09e34bd601b9e081fd118c authorEvan Czaplicki <info@elm-lang.org> dateMon 4 Nov 2013, 02:30 (13 years ago) parent82e9acf c845e58

7 files changed+125−44

compare with master

unifiedsplit

Elm.cabal+8−4 compiler/Compiler.hs+30−24 compiler/Initialize.hs+1−1 compiler/InterfaceSerialization.hs+50 compiler/Metadata/Prelude.hs+27−10 compiler/SourceSyntax/Module.hs+7−2 compiler/Transform/Canonicalize.hs+2−3

Elm.cabal+8−4

@@ -53,6 +53,7 @@ Library

5353 Transform.Optimize,

5454 Metadata.Prelude,

5555 Initialize,

56+ InterfaceSerialization,

5657 Parse.Binop,

5758 Parse.Declaration,

5859 Parse.Expression,

@@ -79,13 +80,14 @@ Library

7980 Paths_Elm

8081

8182 Build-depends: base >=4.2 && <5,

82− binary,

83+ binary >= 0.6.4.0,

8384 blaze-html == 0.5.* || == 0.6.*,

84− blaze-markup == 0.5.1.*,

85+ blaze-markup,

8586 bytestring,

8687 cmdargs,

8788 containers >= 0.3,

8889 directory,

90+ either-unwrap,

8991 filepath,

9092 indents,

9193 language-ecmascript < 1,

@@ -122,6 +124,7 @@ Executable elm

122124 Transform.Optimize,

123125 Metadata.Prelude,

124126 Initialize,

127+ InterfaceSerialization,

125128 Parse.Binop,

126129 Parse.Declaration,

127130 Parse.Expression,

@@ -148,7 +151,7 @@ Executable elm

148151 Paths_Elm

149152

150153 Build-depends: base >=4.2 && <5,

151− binary,

154+ binary >= 0.6.4.0,

152155 blaze-html == 0.5.* || == 0.6.*,

153156 blaze-markup == 0.5.1.*,

154157 bytestring,

@@ -156,6 +159,7 @@ Executable elm

156159 containers >= 0.3,

157160 directory,

158161 filepath,

162+ either-unwrap,

159163 indents,

160164 language-ecmascript < 1,

161165 mtl >= 2,

@@ -191,7 +195,7 @@ Executable elm-doc

191195 Build-depends: aeson,

192196 aeson-pretty,

193197 base >=4.2 && <5,

194− binary,

198+ binary >= 0.6.4.0,

195199 bytestring,

196200 cmdargs,

197201 containers >= 0.3,

compiler/Compiler.hs+30−24

@@ -24,6 +24,7 @@ import Parse.Module (getModuleName)

2424import Initialize (buildFromSource, getSortedDependencies)

2525import Generate.JavaScript (jsModule)

2626import Generate.Html (createHtml, JSSource(..))

27+import qualified InterfaceSerialization as IS

2728import Paths_Elm

2829

2930import SourceSyntax.PrettyPrint (pretty, variable)

@@ -39,9 +40,9 @@ data Flags =

3940 , print_types :: Bool

4041 , scripts :: [FilePath]

4142 , no_prelude :: Bool

42− , cache_dir :: FilePath

43− , build_dir :: FilePath

44− , src_dir :: [FilePath]

43+ , cache_dir :: FilePath

44+ , build_dir :: FilePath

45+ , src_dir :: [FilePath]

4546 }

4647 deriving (Data,Typeable,Show,Eq)

4748

@@ -93,27 +94,30 @@ elmo flags filePath = cachePath flags filePath "elmo"

9394elmi :: Flags -> FilePath -> FilePath

9495elmi flags filePath = cachePath flags filePath "elmi"

9596

97+buildFile :: Flags -> Int -> Int -> Interfaces -> FilePath -> IO (String, ModuleInterface)

98+buildFile flags moduleNum numModules interfaces filePath = do

99+ compiled <- alreadyCompiled

100+ if compiled then do

101+ bytes <- IS.loadInterface (elmi flags filePath)

102+ case bytes >>= IS.interfaceDecode (elmi flags filePath) >>=

103+ IS.validVersion filePath of

96104

97−buildFile :: Flags -> Int -> Int -> Interfaces -> FilePath -> IO (String,ModuleInterface)

98−buildFile flags moduleNum numModules interfaces filePath =

99− do compiled <- alreadyCompiled

100− case compiled of

101− False -> compile

102− True -> do

103− handle <- openBinaryFile (elmi flags filePath) ReadMode

104− bits <- L.hGetContents handle

105− let info :: (String, ModuleInterface)

106− info = Binary.decode bits

107− modInterface = snd info

105+ Left err -> do

106+ hPutStrLn stderr err

107+ exitFailure

108108

109− when (print_types flags)

110− (printTypes interfaces

111− (iTypes modInterface)

112− (iAliases modInterface)

113− (iImports modInterface))

109+ Right (name, interface) -> do

110+ when (print_types flags)

111+ (printTypes interfaces

112+ (iTypes interface)

113+ (iAliases interface)

114+ (iImports interface))

115+

116+ return (name, interface)

117+

118+ else

119+ compile

114120

115− L.length bits `seq` hClose handle

116− return info

117121 where

118122 alreadyCompiled :: IO Bool

119123 alreadyCompiled = do

@@ -140,6 +144,7 @@ buildFile flags moduleNum numModules interfaces filePath =

140144

141145 createDirectoryIfMissing True (cache_dir flags)

142146 createDirectoryIfMissing True (build_dir flags)

147+

143148 metaModule <-

144149 case buildFromSource (no_prelude flags) interfaces source of

145150 Left errors -> do

@@ -152,6 +157,7 @@ buildFile flags moduleNum numModules interfaces filePath =

152157 (types metaModule) (aliases metaModule) (imports metaModule))

153158

154159 let interface = Canonical.interface name $ ModuleInterface {

160+ iVersion = showVersion version,

155161 iTypes = types metaModule,

156162 iImports = imports metaModule,

157163 iAdts = datatypes metaModule,

@@ -206,12 +212,12 @@ build flags rootFile = do

206212 where

207213 appendToOutput :: BS.ByteString -> FilePath -> IO BS.ByteString

208214 appendToOutput js filePath =

209− do src <- BS.readFile (elmo flags filePath)

210− return (BS.append src js)

215+ do

216+ src <- BS.readFile (elmo flags filePath)

217+ return (BS.append src js)

211218

212219 sources js = map Link (scripts flags) ++ [ Source js ]

213220

214−

215221buildFiles :: Flags -> Int -> Interfaces -> String -> [FilePath] -> IO (String, Interfaces)

216222buildFiles _ _ interfaces moduleName [] = return (moduleName, interfaces)

217223buildFiles flags numModules interfaces _ (filePath:rest) = do

compiler/Initialize.hs+1−1

@@ -92,7 +92,7 @@ readDeps srcDirs noPrelude root = evalStateT (go root) Set.empty

9292 case Parse.dependencies txt of

9393 Left err -> liftIO (putStrLn msg >> print err >> exitFailure)

9494 where msg = "Error resolving dependencies in " ++ root' ++ ":"

95−

95+

9696 Right (name,deps) ->

9797 do seen <- get

9898 let realDeps = Set.difference (Set.fromList deps) builtIns

compiler/InterfaceSerialization.hsnew file+50

@@ -0,0 +1,50 @@

1+module InterfaceSerialization ( loadInterface

2+ , interfaceDecode

3+ , validVersion

4+ ) where

6+import qualified Data.ByteString.Lazy as L

7+import qualified Data.Binary as Binary

9+import Paths_Elm (version)

10+import Data.Version (showVersion)

11+import System.Directory (doesFileExist)

12+import System.IO (hPutStrLn, stderr)

13+import System.Exit (exitFailure)

14+

15+import SourceSyntax.Module

16+

17+loadInterface :: FilePath -> IO (Either String L.ByteString)

18+loadInterface filePath = do

19+ exists <- doesFileExist filePath

20+ if exists

21+ then do

22+ byteString <- L.readFile filePath

23+ return $ Right byteString

24+

25+ else

26+ return $ Left $ "Unable to find file " ++ filePath ++

27+ " for deserialization!"

28+

29+interfaceDecode :: Binary.Binary a => FilePath -> L.ByteString ->

30+ Either String a

31+interfaceDecode filePath bytes = do

32+ case Binary.decodeOrFail bytes of

33+ Left (_, offset, err) -> do

34+ Left $ "Got an error, '" ++ err ++ "' at offset " ++

35+ show offset ++ " of " ++ filePath ++ ".\n\n" ++

36+ "This error may be due to an outdated or corrupt " ++

37+ "artifact from a previous build. Please rebuild " ++

38+ filePath ++ " and try again."

39+

40+ Right (_, _, binaryInfo) -> Right binaryInfo

41+

42+validVersion :: FilePath -> (String, ModuleInterface) ->

43+ Either String (String, ModuleInterface)

44+validVersion filePath (name, interface) =

45+ if (iVersion interface) == showVersion version then

46+ Right (name, interface)

47+ else

48+ Left $ "Found build artifacts created by a different " ++

49+ "Elm compiler version. Please rebuild " ++

50+ filePath ++ " and try again."

compiler/Metadata/Prelude.hs+27−10

@@ -11,7 +11,9 @@ import System.IO.Unsafe (unsafePerformIO)

1111import SourceSyntax.Module

1212import qualified Data.Binary as Binary

1313import qualified Data.ByteString.Lazy as BS

14+import Data.Either.Unwrap (fromRight)

1415

16+import qualified InterfaceSerialization as IS

1517

1618add :: Module t v -> Module t v

1719add (Module name exs ims stmts) = Module name exs (customIms ++ ims) stmts

@@ -46,14 +48,29 @@ safeReadDocs name =

4648 , " and specify your versions of Elm and your OS" ]

4749 exitFailure

4850

51+firstModuleInterface :: Interfaces -> Either String (String, ModuleInterface)

52+firstModuleInterface interfaces =

53+ if Map.null interfaces then

54+ Left "No interfaces found in serialized Prelude!"

55+ else

56+ Right $ head $ Map.toList interfaces

57+

4958readDocs :: FilePath -> IO Interfaces

50−readDocs name = do

51− exists <- doesFileExist name

52− case exists of

53− False -> ioError . userError $ "File Not Found"

54− True -> do

55− handle <- openBinaryFile name ReadMode

56− bits <- BS.hGetContents handle

57− let ifaces = Map.fromList (Binary.decode bits)

58− BS.length bits `seq` hClose handle

59− return ifaces

59+readDocs filePath = do

60+ bytes <- IS.loadInterface filePath

61+ let interfaces = bytes >>= IS.interfaceDecode filePath

62+

63+ -- Although every ModuleInterface that is deserialized in this collection

64+ -- contains the compiler version, we only check the first ModuleInterface

65+ -- since it doesn't make sense that different modules in Prelude would have

66+ -- been compiled by different compiler versions.

67+ case interfaces >>= firstModuleInterface >>= IS.validVersion filePath of

68+ Left err -> do

69+ hPutStrLn stderr err

70+ exitFailure

71+

72+ -- Unwrapping the Right value here is safe since the whole above chain

73+ -- returns a Right value. The toList/fromList is necessary because of a

74+ -- problem with looking up keys in the Map after deserialization. Example

75+ -- at https://gist.github.com/jsl/7294493.

76+ Right _ -> return $ Map.fromList $ Map.toList $ fromRight interfaces

compiler/SourceSyntax/Module.hs+7−2

@@ -14,6 +14,9 @@ import SourceSyntax.Type

1414import System.FilePath (joinPath)

1515import Control.Monad (liftM)

1616

17+import Paths_Elm (version)

18+import Data.Version (showVersion)

19+

1720data Module tipe var =

1821 Module [String] Exports Imports [Declaration tipe var]

1922 deriving (Show)

@@ -52,12 +55,13 @@ data MetadataModule t v = MetadataModule {

5255 datatypes :: [ (String, [String], [(String,[Type])]) ],

5356 foreignImports :: [(String, LExpr t v, String, Type)],

5457 foreignExports :: [(String, String, Type)]

55−}

58+} deriving Show

5659

5760type Interfaces = Map.Map String ModuleInterface

5861type ADT = (String, [String], [(String,[Type])])

5962

6063data ModuleInterface = ModuleInterface {

64+ iVersion :: String,

6165 iTypes :: Map.Map String Type,

6266 iImports :: [(String, ImportMethod)],

6367 iAdts :: [ADT],

@@ -67,8 +71,9 @@ data ModuleInterface = ModuleInterface {

6771

6872

6973instance Binary ModuleInterface where

70− get = ModuleInterface <$> get <*> get <*> get <*> get <*> get

74+ get = ModuleInterface <$> get <*> get <*> get <*> get <*> get <*> get

7175 put modul = do

76+ put (iVersion modul)

7277 put (iTypes modul)

7378 put (iImports modul)

7479 put (iAdts modul)

compiler/Transform/Canonicalize.hs+2−3

@@ -15,11 +15,11 @@ import qualified SourceSyntax.Type as Type

1515import qualified Transform.SortDefinitions as SD

1616import Text.PrettyPrint as P

1717

18−

1918interface :: String -> ModuleInterface -> ModuleInterface

2019interface moduleName iface =

2120 ModuleInterface

22− { iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface))

21+ { iVersion = iVersion iface

22+ , iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface))

2323 , iImports = iImports iface

2424 , iAdts = map (both prefix renameCtors) (iAdts iface)

2525 , iAliases = map (both prefix renameType') (iAliases iface)

@@ -95,7 +95,6 @@ metadataModule ifaces modul =

9595 realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)

9696 initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)

9797

98−

9998type Env = Map.Map String String

10099

101100extend :: Env -> Pattern -> Env