5c5c05f · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Merge pull request #320 from jsl/313_verify_serialized_interfaces

5c5c05fEvan Czaplicki13 years ago

Elm.cabal+8−4

compare with master

unifiedsplit

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

53 Transform.Optimize,

54 Metadata.Prelude,

55 Initialize,

56+ InterfaceSerialization,

56 Parse.Binop,

57 Parse.Binop,

57 Parse.Declaration,

58 Parse.Declaration,

58 Parse.Expression,

59 Parse.Expression,

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

79 Paths_Elm

80 Paths_Elm

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

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

82− binary,

83+ binary >= 0.6.4.0,

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

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

84− blaze-markup == 0.5.1.*,

85+ blaze-markup,

85 bytestring,

86 bytestring,

86 cmdargs,

87 cmdargs,

87 containers >= 0.3,

88 containers >= 0.3,

88 directory,

89 directory,

90+ either-unwrap,

89 filepath,

91 filepath,

90 indents,

92 indents,

91 language-ecmascript < 1,

93 language-ecmascript < 1,

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

122 Transform.Optimize,

124 Transform.Optimize,

123 Metadata.Prelude,

125 Metadata.Prelude,

124 Initialize,

126 Initialize,

127+ InterfaceSerialization,

125 Parse.Binop,

128 Parse.Binop,

126 Parse.Declaration,

129 Parse.Declaration,

127 Parse.Expression,

130 Parse.Expression,

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

148 Paths_Elm

151 Paths_Elm

149

152

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

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

151− binary,

154+ binary >= 0.6.4.0,

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

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

153 blaze-markup == 0.5.1.*,

156 blaze-markup == 0.5.1.*,

154 bytestring,

157 bytestring,

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

156 containers >= 0.3,

159 containers >= 0.3,

157 directory,

160 directory,

158 filepath,

161 filepath,

162+ either-unwrap,

159 indents,

163 indents,

160 language-ecmascript < 1,

164 language-ecmascript < 1,

161 mtl >= 2,

165 mtl >= 2,

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

191 Build-depends: aeson,

195 Build-depends: aeson,

192 aeson-pretty,

196 aeson-pretty,

193 base >=4.2 && <5,

197 base >=4.2 && <5,

194− binary,

198+ binary >= 0.6.4.0,

195 bytestring,

199 bytestring,

196 cmdargs,

200 cmdargs,

197 containers >= 0.3,

201 containers >= 0.3,

compiler/Compiler.hs+30−24

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

24import Initialize (buildFromSource, getSortedDependencies)

25import Generate.JavaScript (jsModule)

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

27+import qualified InterfaceSerialization as IS

27import Paths_Elm

28import Paths_Elm

29import SourceSyntax.PrettyPrint (pretty, variable)

30import SourceSyntax.PrettyPrint (pretty, variable)

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

39 , print_types :: Bool

40 , print_types :: Bool

40 , scripts :: [FilePath]

41 , scripts :: [FilePath]

41 , no_prelude :: Bool

42 , no_prelude :: Bool

42− , cache_dir :: FilePath

43+ , cache_dir :: FilePath

43− , build_dir :: FilePath

44+ , build_dir :: FilePath

44− , src_dir :: [FilePath]

45+ , src_dir :: [FilePath]

45 }

46 }

46 deriving (Data,Typeable,Show,Eq)

47 deriving (Data,Typeable,Show,Eq)

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

93elmi :: Flags -> FilePath -> FilePath

94elmi :: Flags -> FilePath -> FilePath

94elmi flags filePath = cachePath flags filePath "elmi"

95elmi flags filePath = cachePath flags filePath "elmi"

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

104

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

105+ Left err -> do

98−buildFile flags moduleNum numModules interfaces filePath =

106+ hPutStrLn stderr err

99− do compiled <- alreadyCompiled

107+ exitFailure

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

108

109+ Right (name, interface) -> do

109− when (print_types flags)

110+ when (print_types flags)

110− (printTypes interfaces

111+ (printTypes interfaces

111− (iTypes modInterface)

112+ (iTypes interface)

112− (iAliases modInterface)

113+ (iAliases interface)

113− (iImports modInterface))

114+ (iImports interface))

115+

116+ return (name, interface)

117+

118+ else

119+ compile

114

120

115− L.length bits `seq` hClose handle

116− return info

117 where

121 where

118 alreadyCompiled :: IO Bool

122 alreadyCompiled :: IO Bool

119 alreadyCompiled = do

123 alreadyCompiled = do

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

140

144

141 createDirectoryIfMissing True (cache_dir flags)

145 createDirectoryIfMissing True (cache_dir flags)

142 createDirectoryIfMissing True (build_dir flags)

146 createDirectoryIfMissing True (build_dir flags)

147+

143 metaModule <-

148 metaModule <-

144 case buildFromSource (no_prelude flags) interfaces source of

149 case buildFromSource (no_prelude flags) interfaces source of

145 Left errors -> do

150 Left errors -> do

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

152 (types metaModule) (aliases metaModule) (imports metaModule))

157 (types metaModule) (aliases metaModule) (imports metaModule))

153

158

154 let interface = Canonical.interface name $ ModuleInterface {

159 let interface = Canonical.interface name $ ModuleInterface {

160+ iVersion = showVersion version,

155 iTypes = types metaModule,

161 iTypes = types metaModule,

156 iImports = imports metaModule,

162 iImports = imports metaModule,

157 iAdts = datatypes metaModule,

163 iAdts = datatypes metaModule,

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

206 where

212 where

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

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

208 appendToOutput js filePath =

214 appendToOutput js filePath =

215+ do

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

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

210− return (BS.append src js)

217+ return (BS.append src js)

211

218

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

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

213

220

214−

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

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

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

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

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

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

compiler/Initialize.hs+1−1

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

92 case Parse.dependencies txt of

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

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

95−

95+

96 Right (name,deps) ->

97 do seen <- get

98 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)

11import SourceSyntax.Module

12import qualified Data.Binary as Binary

13import qualified Data.ByteString.Lazy as BS

14+import Data.Either.Unwrap (fromRight)

16+import qualified InterfaceSerialization as IS

16add :: Module t v -> Module t v

18add :: Module t v -> Module t v

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

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

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

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

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

47 exitFailure

49 exitFailure

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+

49readDocs :: FilePath -> IO Interfaces

58readDocs :: FilePath -> IO Interfaces

50−readDocs name = do

59+readDocs filePath = do

51− exists <- doesFileExist name

60+ bytes <- IS.loadInterface filePath

52− case exists of

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

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

62+

54− True -> do

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

55− handle <- openBinaryFile name ReadMode

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

56− bits <- BS.hGetContents handle

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

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

66+ -- been compiled by different compiler versions.

58− BS.length bits `seq` hClose handle

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

59− return ifaces

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

14import System.FilePath (joinPath)

15import Control.Monad (liftM)

17+import Paths_Elm (version)

18+import Data.Version (showVersion)

19+

17data Module tipe var =

20data Module tipe var =

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

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

19 deriving (Show)

22 deriving (Show)

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

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

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

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

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

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

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

55−}

58+} deriving Show

57type Interfaces = Map.Map String ModuleInterface

60type Interfaces = Map.Map String ModuleInterface

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

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

60data ModuleInterface = ModuleInterface {

63data ModuleInterface = ModuleInterface {

64+ iVersion :: String,

61 iTypes :: Map.Map String Type,

65 iTypes :: Map.Map String Type,

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

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

63 iAdts :: [ADT],

67 iAdts :: [ADT],

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

69instance Binary ModuleInterface where

73instance Binary ModuleInterface where

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

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

71 put modul = do

75 put modul = do

76+ put (iVersion modul)

72 put (iTypes modul)

77 put (iTypes modul)

73 put (iImports modul)

78 put (iImports modul)

74 put (iAdts modul)

79 put (iAdts modul)

compiler/Transform/Canonicalize.hs+2−3

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

15import qualified Transform.SortDefinitions as SD

16import Text.PrettyPrint as P

18−

19interface :: String -> ModuleInterface -> ModuleInterface

18interface :: String -> ModuleInterface -> ModuleInterface

20interface moduleName iface =

19interface moduleName iface =

21 ModuleInterface

20 ModuleInterface

21+ { iVersion = iVersion iface

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

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

23 , iImports = iImports iface

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

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

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

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

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

98−

99type Env = Map.Map String String

98type Env = Map.Map String String

100

101extend :: Env -> Pattern -> Env

100extend :: Env -> Pattern -> Env