diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,12 @@ +1.2.0 +===== + +- Test with GHC 8.8.4, 8.10.7, 9.0.2, 9.2.4, 9.2.5, 9.4.4 +- Add a fantom parameter type to `ElfXX` to differentiate + between nodes on the type level. +- Revise warning options +- Use monad optics for ELF write builder + 1.1.0 ===== diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,12 +7,12 @@ ## Parsing the header and table entries Module -[`Data.Elf.Headers`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html) +[`Data.Elf.Headers`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html) implements parsing and serialization of the ELF file header and the entries of section and segment tables. ELF files come in two flavors: 64-bit and 32-bit. To differentiate between them type -[`ElfClass`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#t:ElfClass) +[`ElfClass`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#t:ElfClass) is defined: ``` Haskell @@ -24,7 +24,7 @@ Some fields of the header and table entries have different bitwidth for 64-bit and 32-bit files. So the type -[`WordXX a`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#t:WordXX) +[`WordXX a`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#t:WordXX) was borrowed from the `data-elf` package: ``` Haskell @@ -59,7 +59,7 @@ ``` The header of the ELF file is represented with the type -[`HeaderXX a`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#t:HeaderXX): +[`HeaderXX a`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#t:HeaderXX): ``` Haskell -- | Parsed ELF header @@ -84,7 +84,7 @@ So we have two types `HeaderXX 'ELFCLASS64` and `HeaderXX 'ELFCLASS32`. To be able to work with headers uniformly the type -[`Header`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#t:Header) +[`Header`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#t:Header) was introduced: ``` Haskell @@ -124,7 +124,7 @@ is defined in the package [`binary`](https://hackage.haskell.org/package/binary). The function -[`withElfClass`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#v:withElfClass) +[`withElfClass`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#v:withElfClass) creates a context with an implicit word width available and looks like [`withSingI`](https://hackage.haskell.org/package/singletons-3.0.1/docs/Data-Singletons.html#v:withSingI): @@ -138,42 +138,52 @@ ``` The module `Data.Elf.Headers` also defines the types -[`SectionXX`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#t:SectionXX), -[`SegmentXX`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#t:SegmentXX) and -[`SymbolXX`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#t:SymbolXX) +[`SectionXX`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#t:SectionXX), +[`SegmentXX`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#t:SegmentXX) and +[`SymbolXX`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#t:SymbolXX) for the elements of section, segment and symbol tables. ## Parsing the whole ELF file The module -[`Data.Elf`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf.html) +[`Data.Elf`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html) implements parsing and serialization of the whole ELF files. To parse ELF file it reads ELF header, section table and segment table and uses that data to create -a list of elements of the type -[`ElfXX`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf.html#t:ElfXX) +a list of type +[`ElfListXX`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html#t:ElfListXX) +of elements of the type +[`ElfXX`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html#t:ElfXX) representing the recursive structure of the ELF file. It also restores section names from the the string table indexes. That results in creating an object of type -[`Elf`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf.html#t:Elf): +[`Elf`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html#t:Elf): ``` Haskell -- | `Elf` is a forrest of trees of type `ElfXX`. -- Trees are composed of `ElfXX` nodes, `ElfSegment` can contain subtrees -newtype ElfList c = ElfList [ElfXX c] +data ElfNodeType = Header | SectionTable | SegmentTable | Section | Segment | RawData | RawAlign +data ElfListXX c where + ElfListCons :: ElfXX t c -> ElfListXX c -> ElfListXX c + ElfListNull :: ElfListXX c -- | Elf is a sigma type where `ElfClass` defines the type of `ElfList` -type Elf = Sigma ElfClass (TyCon1 ElfList) +type Elf = Sigma ElfClass (TyCon1 ElfListXX) -- | Section data may contain a string table. -- If a section contains a string table with section names, the data -- for such a section is generated and `esData` should contain `ElfSectionDataStringTable` -data ElfSectionData - = ElfSectionData BSL.ByteString -- ^ Regular section data +data ElfSectionData c + = ElfSectionData -- ^ Regular section data + { esdData :: BSL.ByteString -- ^ The content of the section + } | ElfSectionDataStringTable -- ^ Section data will be generated from section names + | ElfSectionDataNoBits -- ^ SHT_NOBITS uninitialized section data: section has size but no content + { esdSize :: WordXX c -- ^ Size of the section + } -- | The type of node that defines Elf structure. -data ElfXX (c :: ElfClass) - = ElfHeader +data ElfXX t c where + ElfHeader :: { ehData :: ElfData -- ^ Data encoding (big- or little-endian) , ehOSABI :: ElfOSABI -- ^ OS/ABI identification , ehABIVersion :: Word8 -- ^ ABI version @@ -181,10 +191,10 @@ , ehMachine :: ElfMachine -- ^ Machine type , ehEntry :: WordXX c -- ^ Entry point address , ehFlags :: Word32 -- ^ Processor-specific flags - } - | ElfSectionTable - | ElfSegmentTable - | ElfSection + } -> ElfXX 'Header c + ElfSectionTable :: ElfXX 'SectionTable c + ElfSegmentTable :: ElfXX 'SegmentTable c + ElfSection :: { esName :: String -- ^ Section name (NB: string, not offset in the string table) , esType :: ElfSectionType -- ^ Section type , esFlags :: ElfSectionFlag -- ^ Section attributes @@ -194,9 +204,9 @@ , esN :: ElfSectionIndex -- ^ Section number , esInfo :: Word32 -- ^ Miscellaneous information , esLink :: Word32 -- ^ Link to other section - , esData :: ElfSectionData -- ^ The content of the section - } - | ElfSegment + , esData :: ElfSectionData c -- ^ The content of the section + } -> ElfXX 'Section c + ElfSegment :: { epType :: ElfSegmentType -- ^ Type of segment , epFlags :: ElfSegmentFlag -- ^ Segment attributes , epVirtAddr :: WordXX c -- ^ Virtual address in memory @@ -204,20 +214,24 @@ , epAddMemSize :: WordXX c -- ^ Add this amount of memory after the section when the section is loaded to memory by execution system. -- Or, in other words this is how much `pMemSize` is bigger than `pFileSize` , epAlign :: WordXX c -- ^ Alignment of segment - , epData :: [ElfXX c] -- ^ Content of the segment - } - | ElfRawData -- ^ Some ELF files (some executables) don't bother to define - -- sections for linking and have just raw data in segments. + , epData :: ElfListXX c -- ^ Content of the segment + } -> ElfXX 'Segment c + -- | Some ELF files (some executables) don't bother to define + -- sections for linking and have just raw data in segments. + ElfRawData :: { edData :: BSL.ByteString -- ^ Raw data in ELF file - } - | ElfRawAlign -- ^ Align the next data in the ELF file. - -- The offset of the next data in the ELF file - -- will be the minimal @x@ such that - -- @x mod eaAlign == eaOffset mod eaAlign @ + } -> ElfXX 'RawData c + -- | Align the next data in the ELF file. + -- The offset of the next data in the ELF file + -- will be the minimal @x@ such that + -- @x mod eaAlign == eaOffset mod eaAlign @ + ElfRawAlign :: { eaOffset :: WordXX c -- ^ Align value , eaAlign :: WordXX c -- ^ Align module - } + } -> ElfXX 'RawAlign c +(~:) :: ElfXX t a -> ElfListXX a -> ElfListXX a +(~:) = ElfListCons ``` Not each object of that type can be serialized. @@ -238,9 +252,9 @@ node `ElfSegmentTable`. Correctly composed ELF object can be serialized with the function -[`serializeElf`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf.html#v:serializeElf) +[`serializeElf`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html#v:serializeElf) and parsed with the function -[`parseElf`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf.html#v:parseElf): +[`parseElf`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html#v:parseElf): ``` Haskell serializeElf :: MonadThrow m => Elf -> m ByteString @@ -255,7 +269,7 @@ To create machine code that is used in the examples a pair of modules were created. The module -[`AsmAArch64`](https://github.com/aleksey-makarov/melf/blob/v1.0.2/examples/AsmAArch64.hs) +[`AsmAArch64`](https://github.com/aleksey-makarov/melf/blob/v1.2.0/examples/AsmAArch64.hs) provides a DSL embedded in Haskell. This DSL is a kind of assembler language for the AArch64 platform. It exports some primitives to generate machine instructions and organize machine code. @@ -270,10 +284,10 @@ ["Monads to Machine Code"](https://www.stephendiehl.com/posts/monads_machine_code.html) by Stephen Diehl. Detailed description of this module is available in russian: -[README_ru.md](https://github.com/aleksey-makarov/melf/blob/v1.0.2/examples/README_ru.md). +[README_ru.md](https://github.com/aleksey-makarov/melf/blob/v1.2.0/examples/README_ru.md) (outdated). The module -[`HelloWorld`](https://github.com/aleksey-makarov/melf/blob/v1.0.2/examples/HelloWorld.hs) +[`HelloWorld`](https://github.com/aleksey-makarov/melf/blob/v1.2.0/examples/HelloWorld.hs) uses primitives from `AsmAArch64` to compose relocatable executable code that uses system calls to output a "Hello World!" message into standard output and exit: @@ -284,8 +298,8 @@ Function `assemble` uses the `melf` library to generate an object file: ``` Haskell - return $ SELFCLASS64 :&: ElfList - [ ElfHeader + return $ SELFCLASS64 :&: + ElfHeader { ehData = ELFDATA2LSB , ehOSABI = ELFOSABI_SYSV , ehABIVersion = 0 @@ -294,7 +308,7 @@ , ehEntry = 0 , ehFlags = 0 } - , ElfSection + ~: ElfSection { esName = ".text" , esType = SHT_PROGBITS , esFlags = SHF_EXECINSTR .|. SHF_ALLOC @@ -306,7 +320,7 @@ , esInfo = 0 , esData = ElfSectionData txt } - , ElfSection + ~: ElfSection { esName = ".shstrtab" , esType = SHT_STRTAB , esFlags = 0 @@ -318,7 +332,7 @@ , esInfo = 0 , esData = ElfSectionDataStringTable } - , ElfSection + ~: ElfSection { esName = ".symtab" , esType = SHT_SYMTAB , esFlags = 0 @@ -330,7 +344,7 @@ , esInfo = 1 , esData = ElfSectionData symbolTableData } - , ElfSection + ~: ElfSection { esName = ".strtab" , esType = SHT_STRTAB , esFlags = 0 @@ -342,8 +356,8 @@ , esInfo = 0 , esData = ElfSectionData stringTableData } - , ElfSectionTable - ] + ~: ElfSectionTable + ~: ElfListNull ``` It runs the `State` monad that was passed as an argument. @@ -396,22 +410,22 @@ ## Generation of executable files The module -[`DummyLd`](https://github.com/aleksey-makarov/melf/blob/v1.0.2/examples/DummyLd.hs) +[`DummyLd`](https://github.com/aleksey-makarov/melf/blob/v1.2.0/examples/DummyLd.hs) uses the section `.text` of object file to create an executable file. Code relocation and symbol resolution is not implemented so that procedure works only for position-independent code that does not refer to external translation units, for example, it works with the code described above. Function `dummyLd` consumes an object of the type `Elf` and finds a section `.text` -(using [`elfFindSectionByName`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf.html#v:elfFindSectionByName)) +(using [`elfFindSectionByName`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html#v:elfFindSectionByName)) and header -(using [`elfFindHeader`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf.html#v:elfFindHeader)) +(using [`elfFindHeader`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html#v:elfFindHeader)) in it. Then the header type is changed to `ET_EXEC`, the address of the first executable instruction is specified and a loadable segment containing the header and the content of `.text` is formed: ``` Haskell -data MachineConfig (a :: ElfClass) +data MachineConfig a = MachineConfig { mcAddress :: WordXX a -- ^ Virtual address of the executable segment , mcAlign :: WordXX a -- ^ Required alignment of the executable segment @@ -423,20 +437,23 @@ getMachineConfig EM_X86_64 = return $ MachineConfig 0x400000 0x1000 getMachineConfig _ = $chainedError "could not find machine config for this arch" -dummyLd' :: forall a m . (MonadThrow m, IsElfClass a) => ElfList a -> m (ElfList a) -dummyLd' (ElfList es) = do +dummyLd' :: forall a m . (MonadThrow m, IsElfClass a) => ElfListXX a -> m (ElfListXX a) +dummyLd' es = do - txtSection <- elfFindSectionByName es ".text" - txtSectionData <- case txtSection of - ElfSection { esData = ElfSectionData textData } -> return textData + section' <- elfFindSectionByName es ".text" + + txtSectionData <- case esData section' of + ElfSectionData textData -> return textData _ -> $chainedError "could not find correct \".text\" section" - header <- elfFindHeader es - case header of - ElfHeader { .. } -> do - MachineConfig { .. } <- getMachineConfig ehMachine - return $ ElfList - [ ElfSegment + header' <- elfFindHeader es + + MachineConfig { .. } <- getMachineConfig (ehMachine header') + + return $ + case header' of + ElfHeader { .. } -> + ElfSegment { epType = PT_LOAD , epFlags = PF_X .|. PF_R , epVirtAddr = mcAddress @@ -444,19 +461,18 @@ , epAddMemSize = 0 , epAlign = mcAlign , epData = - [ ElfHeader + ElfHeader { ehType = ET_EXEC , ehEntry = mcAddress + headerSize (fromSing $ sing @a) , .. } - , ElfRawData + ~: ElfRawData { edData = txtSectionData } - ] + ~: ElfListNull } - , ElfSegmentTable - ] - _ -> $chainedError "could not find ELF header" + ~: ElfSegmentTable + ~: ElfListNull -- | @dummyLd@ places the content of ".text" section of the input ELF -- into the loadable segment of the resulting ELF. diff --git a/examples/AsmAArch64.hs b/examples/AsmAArch64.hs --- a/examples/AsmAArch64.hs +++ b/examples/AsmAArch64.hs @@ -261,7 +261,7 @@ steType = STT_NoType steShNdx = textSecN steValue = fromIntegral $ findOffset poolOffset r - steSize = 0 + steSize = 0 :: Word64 in ElfSymbolXX{..} @@ -269,8 +269,8 @@ (symbolTableData, stringTableData) <- serializeSymbolTable ELFDATA2LSB (zeroIndexStringItem : symbolTable) - return $ SELFCLASS64 :&: ElfList - [ ElfHeader + return $ SELFCLASS64 :&: + ElfHeader { ehData = ELFDATA2LSB , ehOSABI = ELFOSABI_SYSV , ehABIVersion = 0 @@ -279,7 +279,7 @@ , ehEntry = 0 , ehFlags = 0 } - , ElfSection + ~: ElfSection { esName = ".text" , esType = SHT_PROGBITS , esFlags = SHF_EXECINSTR .|. SHF_ALLOC @@ -291,7 +291,7 @@ , esInfo = 0 , esData = ElfSectionData txt } - , ElfSection + ~: ElfSection { esName = ".shstrtab" , esType = SHT_STRTAB , esFlags = 0 @@ -303,7 +303,7 @@ , esInfo = 0 , esData = ElfSectionDataStringTable } - , ElfSection + ~: ElfSection { esName = ".symtab" , esType = SHT_SYMTAB , esFlags = 0 @@ -315,7 +315,7 @@ , esInfo = 1 , esData = ElfSectionData symbolTableData } - , ElfSection + ~: ElfSection { esName = ".strtab" , esType = SHT_STRTAB , esFlags = 0 @@ -327,5 +327,5 @@ , esInfo = 0 , esData = ElfSectionData stringTableData } - , ElfSectionTable - ] + ~: ElfSectionTable + ~: ElfListNull diff --git a/examples/DummyLd.hs b/examples/DummyLd.hs --- a/examples/DummyLd.hs +++ b/examples/DummyLd.hs @@ -18,7 +18,7 @@ import Data.Elf.Headers import Control.Exception.ChainedException -data MachineConfig (a :: ElfClass) +data MachineConfig a = MachineConfig { mcAddress :: WordXX a -- ^ Virtual address of the executable segment , mcAlign :: WordXX a -- ^ Required alignment of the executable segment @@ -30,20 +30,29 @@ getMachineConfig EM_X86_64 = return $ MachineConfig 0x400000 0x1000 getMachineConfig _ = $chainedError "could not find machine config for this arch" -dummyLd' :: forall a m . (MonadThrow m, IsElfClass a) => ElfList a -> m (ElfList a) -dummyLd' (ElfList es) = do +dummyLd' :: forall a m . (MonadThrow m, IsElfClass a) => ElfListXX a -> m (ElfListXX a) +dummyLd' es = do - txtSection <- elfFindSectionByName es ".text" - txtSectionData <- case txtSection of - ElfSection { esData = ElfSectionData textData } -> return textData + section' <- elfFindSectionByName es ".text" + + txtSectionData <- case esData section' of + ElfSectionData textData -> return textData _ -> $chainedError "could not find correct \".text\" section" - header <- elfFindHeader es - case header of - ElfHeader { .. } -> do - MachineConfig { .. } <- getMachineConfig ehMachine - return $ ElfList - [ ElfSegment + -- FIXME: it's better to match constructor here, but there is a bug that prevents to conclude that + -- the match is irrefutable: + -- https://stackoverflow.com/questions/72803815/phantom-type-makes-pattern-matching-irrefutable-but-that-seemingly-does-not-wor + -- https://gitlab.haskell.org/ghc/ghc/-/issues/15681#note_165436 + -- But if I use lazy pattern match, then some other bug comes up that prevents type inference + -- on GHC 9.0.2 + header' <- elfFindHeader es + + MachineConfig { .. } <- getMachineConfig (ehMachine header') + + return $ + case header' of + ElfHeader { .. } -> + ElfSegment { epType = PT_LOAD , epFlags = PF_X .|. PF_R , epVirtAddr = mcAddress @@ -51,19 +60,18 @@ , epAddMemSize = 0 , epAlign = mcAlign , epData = - [ ElfHeader + ElfHeader { ehType = ET_EXEC , ehEntry = mcAddress + headerSize (fromSing $ sing @a) , .. } - , ElfRawData + ~: ElfRawData { edData = txtSectionData } - ] + ~: ElfListNull } - , ElfSegmentTable - ] - _ -> $chainedError "could not find ELF header" + ~: ElfSegmentTable + ~: ElfListNull -- | @dummyLd@ places the content of ".text" section of the input ELF -- into the loadable segment of the resulting ELF. diff --git a/examples/ForwardLabel.hs b/examples/ForwardLabel.hs --- a/examples/ForwardLabel.hs +++ b/examples/ForwardLabel.hs @@ -5,7 +5,6 @@ import Prelude as P -import Control.Monad.Catch import Control.Monad.Fix import Control.Monad.State import Data.Word @@ -23,7 +22,7 @@ sysWrite = 64 sysExit = 93 -forwardLabel :: (MonadCatch m, MonadFix m) => StateT CodeState m () +forwardLabel :: MonadFix m => StateT CodeState m () forwardLabel = mdo label >>= exportSymbol "_start" diff --git a/melf.cabal b/melf.cabal --- a/melf.cabal +++ b/melf.cabal @@ -1,11 +1,11 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.34.5. +-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack name: melf -version: 1.1.0 +version: 1.2.0 synopsis: An Elf parser description: Parser for ELF object format category: Data @@ -18,7 +18,7 @@ license-file: LICENSE build-type: Simple tested-with: - GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.1, GHC == 9.2.1 + GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.4, GHC == 9.2.5, GHC == 9.4.4 extra-doc-files: ChangeLog.md README.md @@ -69,21 +69,25 @@ Data.BList hs-source-dirs: src - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints + ghc-options: -Wall -Wcompat build-depends: base >=4.13 && <5.0 , binary >=0.8.7 && <0.9 , bytestring >=0.10.10 && <0.12 , exceptions >=0.10.4 && <0.11 + , lens >=5.0.1 && <5.3 , mtl >=2.2.2 && <2.3 , prettyprinter >=1.7.0 && <1.8 - , singletons >=2.6 && <3.2 - , template-haskell >=2.15 && <2.19 + , template-haskell >=2.15 && <2.20 + default-language: Haskell2010 if impl(ghc >= 9.0) build-depends: - singletons-base >=3.0 && <3.2 + singletons ==3.0.* + , singletons-base >=3.0 && <3.2 , singletons-th >=3.0 && <3.2 - default-language: Haskell2010 + else + build-depends: + singletons >=2.6 && <2.8 executable hobjdump main-is: hObjDump.hs @@ -91,13 +95,13 @@ Paths_melf hs-source-dirs: app - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Wcompat -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.13 && <5.0 , binary , bytestring , melf - , optparse-applicative >=0.16.1 && <0.17 + , optparse-applicative >=0.16.1 && <0.18 , prettyprinter default-language: Haskell2010 @@ -107,7 +111,7 @@ Paths_melf hs-source-dirs: app - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Wcompat -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.13 && <5.0 , binary @@ -128,24 +132,26 @@ Paths_melf hs-source-dirs: examples - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints + ghc-options: -Wall -Wcompat build-depends: base >=4.13 && <5.0 , bytestring - , containers >=0.6.2.1 && <0.7 , exceptions , filepath , melf , mtl - , singletons , tasty , tasty-golden , tasty-hunit , unix >=2.7.2.2 && <2.8 + default-language: Haskell2010 if impl(ghc >= 9.0) build-depends: - singletons-th - default-language: Haskell2010 + singletons + , singletons-th + else + build-depends: + singletons test-suite exceptions type: exitcode-stdio-1.0 @@ -154,7 +160,7 @@ Paths_melf hs-source-dirs: tests/exceptions - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints + ghc-options: -Wall -Wcompat build-depends: base >=4.13 && <5.0 , exceptions @@ -170,7 +176,7 @@ Paths_melf hs-source-dirs: tests - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints + ghc-options: -Wall -Wcompat build-depends: base >=4.13 && <5.0 , binary diff --git a/src/Data/Elf.hs b/src/Data/Elf.hs --- a/src/Data/Elf.hs +++ b/src/Data/Elf.hs @@ -11,10 +11,12 @@ module Data.Elf ( -- * Elf - ElfList (..) + ElfNodeType (..) + , ElfListXX (..) , Elf , ElfSectionData (..) , ElfXX (..) + , (~:) , parseElf , serializeElf diff --git a/src/Data/Elf/Constants/TH.hs b/src/Data/Elf/Constants/TH.hs --- a/src/Data/Elf/Constants/TH.hs +++ b/src/Data/Elf/Constants/TH.hs @@ -22,6 +22,7 @@ let patternName s = mkName (patternPrefixString ++ s) let defaultPatternName = mkName defaultPatternNameString let + baseTypeT :: Q Type baseTypeT = case baseType of BaseWord8 -> conT $ mkName "Word8" @@ -55,7 +56,9 @@ (normalB [| patternPrefixString ++ s |]) [] - let showClauses = map mkShowClause enums + let + showClauses :: [Q Clause] + showClauses = map mkShowClause enums (nP, nE) <- newNamePE "n" let @@ -149,6 +152,7 @@ localName3 <- newName "n" let + defaultPatternDef :: Q Dec defaultPatternDef = patSynD defaultPatternName diff --git a/src/Data/Elf/Headers.hs b/src/Data/Elf/Headers.hs --- a/src/Data/Elf/Headers.hs +++ b/src/Data/Elf/Headers.hs @@ -104,13 +104,11 @@ import Data.Singletons.TH import Data.Typeable (Typeable) -#if defined(MIN_VERSION_GLASGOW_HASKELL) -#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +#if MIN_VERSION_singletons(3,0,0) import Data.Eq.Singletons import Text.Show.Singletons import Data.Bool.Singletons #endif -#endif import Control.Exception.ChainedException import Data.BList @@ -598,7 +596,7 @@ relaSym32 v = v `shiftR` 8 relaType32 :: Word32 -> Word32 -relaType32 v = fromIntegral $ v .&. 0xff +relaType32 v = v .&. 0xff relaSym64 :: Word64 -> Word32 relaSym64 v = fromIntegral $ v `shiftR` 32 diff --git a/src/Data/Elf/PrettyPrint.hs b/src/Data/Elf/PrettyPrint.hs --- a/src/Data/Elf/PrettyPrint.hs +++ b/src/Data/Elf/PrettyPrint.hs @@ -242,6 +242,7 @@ let xs = concatMap printRBuilder' rbpData l = longest xs + appendSectionBar :: [(a1, String, c1)] -> [(a1, String, c1)] appendSectionBar = fmap (mapL ('│' : )) xsf = appendSectionBar $ equalize l xs b = '┌' : replicate l '─' @@ -252,6 +253,7 @@ [(if empty i then o else o + s - 1, e, [] )] f RBuilderRawData{} = let + doc :: [Doc ()] doc = [ "R" ] in [(o, "╓", doc) @@ -347,7 +349,7 @@ <+> "value:" <+> printWordXX steValue <+> "size:" <+> printWordXX steSize) -printRelocationTableA_AARCH64 :: MonadThrow m => Bool -> Word32 -> [ElfXX 'ELFCLASS64] -> BSL.ByteString -> m (Doc ()) +printRelocationTableA_AARCH64 :: MonadThrow m => Bool -> Word32 -> ElfListXX 'ELFCLASS64 -> BSL.ByteString -> m (Doc ()) printRelocationTableA_AARCH64 full sLink elfs bs = do symTableSection <- elfFindSection elfs sLink symTable <- parseSymbolTable ELFDATA2LSB symTableSection elfs @@ -383,21 +385,25 @@ -- | Print ELF. If first argument is False, don't dump all the data, print just the first two and the last lines. printElf_ :: MonadThrow m => Bool -> Elf -> m (Doc ()) -printElf_ full (classS :&: ElfList elfs) = withElfClass classS do +printElf_ full (classS :&: elfs) = withElfClass classS $ printElf_' full elfs - (hData, hMachine) <- do - header <- elfFindHeader elfs - case header of - ElfHeader{..} -> return (ehData, ehMachine) - _ -> $chainedError "not a header" -- FIXME +printElf_' :: forall a m . (MonadThrow m, IsElfClass a) => Bool -> ElfListXX a -> m (Doc ()) +printElf_' full elfs = do + -- FIXME: lazy matching here is a workaround for some GHC bug, see + -- https://stackoverflow.com/questions/72803815/phantom-type-makes-pattern-matching-irrefutable-but-that-seemingly-does-not-wor + -- https://gitlab.haskell.org/ghc/ghc/-/issues/15681#note_165436 + ~(ElfHeader { .. }) <- elfFindHeader elfs + let - printElf' elfs' = align . vsep <$> mapM printElf'' elfs' + printElf' :: ElfListXX a -> m (Doc ()) + printElf' elfs' = align . vsep <$> mapMElfList printElf'' elfs' - printElf'' ElfHeader{..} = + printElf'' :: ElfXX t' a -> m (Doc ()) + printElf'' ElfHeader {} = return $ formatPairsBlock "header" - [ ("Class", viaShow $ fromSing classS ) + [ ("Class", viaShow $ fromSing $ sing @a) , ("Data", viaShow ehData ) -- ElfData , ("OSABI", viaShow ehOSABI ) -- ElfOSABI , ("ABIVersion", viaShow ehABIVersion ) -- Word8 @@ -427,21 +433,21 @@ ElfSectionData bs -> if sectionIsSymbolTable esType then do - stes <- parseSymbolTable hData s elfs + stes <- parseSymbolTable ehData s elfs return $ printSection' "symbol table section" $ if null stes then "" else line <> indent 4 (printElfSymbolTable full stes) - else if hMachine == EM_AARCH64 - && hData == ELFDATA2LSB - && esType == SHT_RELA - && esEntSize == withElfClass classS relocationTableAEntrySize then - case classS of + else if ehMachine == EM_AARCH64 + && ehData == ELFDATA2LSB + && esType == SHT_RELA + && esEntSize == relocationTableAEntrySize then + case sing @a of SELFCLASS64 -> printSection' "section" <$> printRelocationTableA_AARCH64 full esLink elfs bs SELFCLASS32 -> $chainedError "invalid ELF: EM_AARCH64 and ELFCLASS32" else return $ printSection' "section" $ printData full bs printElf'' ElfSegment{..} = do - dataDoc <- if null epData - then return "" - else do + dataDoc <- case epData of + ElfListNull -> return "" + _ -> do dataDoc' <- printElf' epData return $ line <> indent 4 dataDoc' return $ formatPairsBlock "segment" diff --git a/src/Data/Internal/Elf.hs b/src/Data/Internal/Elf.hs --- a/src/Data/Internal/Elf.hs +++ b/src/Data/Internal/Elf.hs @@ -7,6 +7,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTSyntax #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -25,6 +26,8 @@ import Data.Elf.Headers import Data.Interval as I +import Control.Lens.Combinators hiding (contains) +import Control.Lens.Operators import Control.Monad import Control.Monad.Catch import Control.Monad.State as MS @@ -40,23 +43,6 @@ import Data.Singletons import Data.Singletons.Sigma --- import System.IO.Unsafe - -headerInterval :: forall a . IsElfClass a => HeaderXX a -> Interval (WordXX a) -headerInterval _ = I 0 $ headerSize $ fromSing $ sing @a - -sectionTableInterval :: IsElfClass a => HeaderXX a -> Interval (WordXX a) -sectionTableInterval HeaderXX{..} = I hShOff $ fromIntegral $ hShEntSize * hShNum - -segmentTableInterval :: IsElfClass a => HeaderXX a -> Interval (WordXX a) -segmentTableInterval HeaderXX{..} = I hPhOff $ fromIntegral $ hPhEntSize * hPhNum - -sectionInterval :: IsElfClass a => SectionXX a -> Interval (WordXX a) -sectionInterval SectionXX{..} = I sOffset if sType == SHT_NOBITS then 0 else sSize - -segmentInterval :: IsElfClass a => SegmentXX a -> Interval (WordXX a) -segmentInterval SegmentXX{..} = I pOffset pFileSize - -- | @RBuilder@ is an intermediate internal data type that is used by parser. -- It contains information about layout of the ELF file that can be used -- by `Data.Elf.PrettyPrint.printLayout` @@ -88,6 +74,138 @@ , rbraAlign :: WordXX c } +data LZip a = LZip [a] (Maybe a) [a] + +instance Foldable LZip where + foldMap f (LZip l (Just c) r) = foldMap f $ LZip l Nothing (c : r) + foldMap f (LZip l Nothing r) = foldMap f $ L.reverse l ++ r + +-- FIXME: Use validity (https://hackage.haskell.org/package/validity) +-- for constraints on the Elf type (???) + +-- | `Elf` is a forrest of trees of type `ElfXX`. +-- Trees are composed of `ElfXX` nodes, `ElfSegment` can contain subtrees +data ElfNodeType = Header | SectionTable | SegmentTable | Section | Segment | RawData | RawAlign +data ElfListXX c where + ElfListCons :: ElfXX t c -> ElfListXX c -> ElfListXX c + ElfListNull :: ElfListXX c + +-- | Elf is a sigma type where `ElfClass` defines the type of `ElfList` +type Elf = Sigma ElfClass (TyCon1 ElfListXX) + +-- | Section data may contain a string table. +-- If a section contains a string table with section names, the data +-- for such a section is generated and `esData` should contain `ElfSectionDataStringTable` +data ElfSectionData c + = ElfSectionData -- ^ Regular section data + { esdData :: BSL.ByteString -- ^ The content of the section + } + | ElfSectionDataStringTable -- ^ Section data will be generated from section names + | ElfSectionDataNoBits -- ^ SHT_NOBITS uninitialized section data: section has size but no content + { esdSize :: WordXX c -- ^ Size of the section + } + +-- | The type of node that defines Elf structure. +data ElfXX t c where + ElfHeader :: + { ehData :: ElfData -- ^ Data encoding (big- or little-endian) + , ehOSABI :: ElfOSABI -- ^ OS/ABI identification + , ehABIVersion :: Word8 -- ^ ABI version + , ehType :: ElfType -- ^ Object file type + , ehMachine :: ElfMachine -- ^ Machine type + , ehEntry :: WordXX c -- ^ Entry point address + , ehFlags :: Word32 -- ^ Processor-specific flags + } -> ElfXX 'Header c + ElfSectionTable :: ElfXX 'SectionTable c + ElfSegmentTable :: ElfXX 'SegmentTable c + ElfSection :: + { esName :: String -- ^ Section name (NB: string, not offset in the string table) + , esType :: ElfSectionType -- ^ Section type + , esFlags :: ElfSectionFlag -- ^ Section attributes + , esAddr :: WordXX c -- ^ Virtual address in memory + , esAddrAlign :: WordXX c -- ^ Address alignment boundary + , esEntSize :: WordXX c -- ^ Size of entries, if section has table + , esN :: ElfSectionIndex -- ^ Section number + , esInfo :: Word32 -- ^ Miscellaneous information + , esLink :: Word32 -- ^ Link to other section + , esData :: ElfSectionData c -- ^ The content of the section + } -> ElfXX 'Section c + ElfSegment :: + { epType :: ElfSegmentType -- ^ Type of segment + , epFlags :: ElfSegmentFlag -- ^ Segment attributes + , epVirtAddr :: WordXX c -- ^ Virtual address in memory + , epPhysAddr :: WordXX c -- ^ Physical address + , epAddMemSize :: WordXX c -- ^ Add this amount of memory after the section when the section is loaded to memory by execution system. + -- Or, in other words this is how much `pMemSize` is bigger than `pFileSize` + , epAlign :: WordXX c -- ^ Alignment of segment + , epData :: ElfListXX c -- ^ Content of the segment + } -> ElfXX 'Segment c + -- | Some ELF files (some executables) don't bother to define + -- sections for linking and have just raw data in segments. + ElfRawData :: + { edData :: BSL.ByteString -- ^ Raw data in ELF file + } -> ElfXX 'RawData c + -- | Align the next data in the ELF file. + -- The offset of the next data in the ELF file + -- will be the minimal @x@ such that + -- @x mod eaAlign == eaOffset mod eaAlign @ + ElfRawAlign :: + { eaOffset :: WordXX c -- ^ Align value + , eaAlign :: WordXX c -- ^ Align module + } -> ElfXX 'RawAlign c + +data WBuilderData + = WBuilderDataHeader + | WBuilderDataByteStream { wbdData :: BSL.ByteString } + | WBuilderDataSectionTable + | WBuilderDataSegmentTable + +data WBuilderState a = + WBuilderState + { _wbsSections :: [(ElfSectionIndex, SectionXX a)] + , _wbsSegmentsReversed :: [SegmentXX a] + , _wbsDataReversed :: [WBuilderData] + , _wbsOffset :: WordXX a + , _wbsPhOff :: WordXX a + , _wbsShOff :: WordXX a + , _wbsShStrNdx :: ElfSectionIndex + , _wbsNameIndexes :: [Int64] + } + +makeLenses ''WBuilderState + +infixr 9 ~: + +(~:) :: ElfXX t a -> ElfListXX a -> ElfListXX a +(~:) = ElfListCons + +foldMapElfList :: Monoid m => (forall t' . (ElfXX t' a -> m)) -> ElfListXX a -> m +foldMapElfList f (ElfListCons v@(ElfSegment { .. }) l) = f v <> foldMapElfList f epData <> foldMapElfList f l +foldMapElfList f (ElfListCons v l) = f v <> foldMapElfList f l +foldMapElfList _ ElfListNull = mempty + +foldMapElfList' :: Monoid m => (forall t' . (ElfXX t' a -> m)) -> ElfListXX a -> m +foldMapElfList' f (ElfListCons v l) = f v <> foldMapElfList' f l +foldMapElfList' _ ElfListNull = mempty + +mapMElfList :: Monad m => (forall t' . (ElfXX t' a -> m b)) -> ElfListXX a -> m [b] +mapMElfList f l = sequence $ foldMapElfList' ((: []) . f) l + +headerInterval :: forall a . IsElfClass a => HeaderXX a -> Interval (WordXX a) +headerInterval _ = I 0 $ headerSize $ fromSing $ sing @a + +sectionTableInterval :: IsElfClass a => HeaderXX a -> Interval (WordXX a) +sectionTableInterval HeaderXX{..} = I hShOff $ fromIntegral $ hShEntSize * hShNum + +segmentTableInterval :: IsElfClass a => HeaderXX a -> Interval (WordXX a) +segmentTableInterval HeaderXX{..} = I hPhOff $ fromIntegral $ hPhEntSize * hPhNum + +sectionInterval :: IsElfClass a => SectionXX a -> Interval (WordXX a) +sectionInterval SectionXX{..} = I sOffset if sType == SHT_NOBITS then 0 else sSize + +segmentInterval :: IsElfClass a => SegmentXX a -> Interval (WordXX a) +segmentInterval SegmentXX{..} = I pOffset pFileSize + rBuilderInterval :: IsElfClass a => RBuilder a -> Interval (WordXX a) rBuilderInterval RBuilderHeader{..} = headerInterval rbhHeader rBuilderInterval RBuilderSectionTable{..} = sectionTableInterval rbstHeader @@ -97,12 +215,6 @@ rBuilderInterval RBuilderRawData{..} = rbrdInterval rBuilderInterval RBuilderRawAlign{} = undefined -- FIXME -data LZip a = LZip [a] (Maybe a) [a] - -instance Foldable LZip where - foldMap f (LZip l (Just c) r) = foldMap f $ LZip l Nothing (c : r) - foldMap f (LZip l Nothing r) = foldMap f $ L.reverse l ++ r - findInterval :: (Ord t, Num t) => (a -> Interval t) -> t -> [a] -> LZip a findInterval f e = findInterval' [] where @@ -140,8 +252,8 @@ addRBuilderEmpty t ts = -- (unsafePerformIO $ Prelude.putStrLn $ "Add Empty " ++ showRBuilder t ++ " to " ++ showERBList ts) `seq` let - to = offset $ rBuilderInterval t - (LZip l c' r) = findInterval rBuilderInterval to ts + to' = offset $ rBuilderInterval t + (LZip l c' r) = findInterval rBuilderInterval to' ts -- Let `(le, lo)` is the result of `allEmptyStarting a l`. -- Then `le` is the initial sublist of `l` each element of which is empty and starts at `a`, @@ -161,16 +273,16 @@ d <- $addContext' $ addRBuilderEmpty t rbpData return $ toList $ LZip l (Just RBuilderSegment{ rbpData = d, .. }) r Just c -> - if offset (rBuilderInterval c) /= to then + if offset (rBuilderInterval c) /= to' then $chainedError $ intersectMessage t c else let - (ce, re) = allEmptyStartingAt to (c : r) + (ce, re') = allEmptyStartingAt to' (c : r) in case t of RBuilderSegment{..} -> - return $ toList $ LZip l (Just RBuilderSegment{ rbpData = ce, .. }) re + return $ toList $ LZip l (Just RBuilderSegment{ rbpData = ce, .. }) re' _ -> - return $ toList $ LZip l Nothing (ce ++ (t : re)) + return $ toList $ LZip l Nothing (ce ++ (t : re')) Nothing -> return $ toList $ LZip l (Just t) r addRBuilderNonEmpty :: (IsElfClass a, MonadCatch m) => RBuilder a -> [RBuilder a] -> m [RBuilder a] @@ -284,112 +396,40 @@ in addRBuilders' addRBuilderNonEmpty nonEmptyRBs [] >>= addRBuilders' addRBuilderEmpty emptyRBs --- FIXME: Use validity (https://hackage.haskell.org/package/validity) for constraints on the Elf type (???) - --- | `Elf` is a forrest of trees of type `ElfXX`. --- Trees are composed of `ElfXX` nodes, `ElfSegment` can contain subtrees -newtype ElfList c = ElfList [ElfXX c] - --- | Elf is a sigma type where `ElfClass` defines the type of `ElfList` -type Elf = Sigma ElfClass (TyCon1 ElfList) - --- | Section data may contain a string table. --- If a section contains a string table with section names, the data --- for such a section is generated and `esData` should contain `ElfSectionDataStringTable` -data ElfSectionData c - = ElfSectionData -- ^ Regular section data - { esdData :: BSL.ByteString -- ^ The content of the section - } - | ElfSectionDataStringTable -- ^ Section data will be generated from section names - | ElfSectionDataNoBits -- ^ SHT_NOBITS uninitialized section data: section has size but no content - { esdSize :: WordXX c -- ^ Size of the section - } - --- | The type of node that defines Elf structure. -data ElfXX c - = ElfHeader - { ehData :: ElfData -- ^ Data encoding (big- or little-endian) - , ehOSABI :: ElfOSABI -- ^ OS/ABI identification - , ehABIVersion :: Word8 -- ^ ABI version - , ehType :: ElfType -- ^ Object file type - , ehMachine :: ElfMachine -- ^ Machine type - , ehEntry :: WordXX c -- ^ Entry point address - , ehFlags :: Word32 -- ^ Processor-specific flags - } - | ElfSectionTable - | ElfSegmentTable - | ElfSection - { esName :: String -- ^ Section name (NB: string, not offset in the string table) - , esType :: ElfSectionType -- ^ Section type - , esFlags :: ElfSectionFlag -- ^ Section attributes - , esAddr :: WordXX c -- ^ Virtual address in memory - , esAddrAlign :: WordXX c -- ^ Address alignment boundary - , esEntSize :: WordXX c -- ^ Size of entries, if section has table - , esN :: ElfSectionIndex -- ^ Section number - , esInfo :: Word32 -- ^ Miscellaneous information - , esLink :: Word32 -- ^ Link to other section - , esData :: ElfSectionData c -- ^ The content of the section - } - | ElfSegment - { epType :: ElfSegmentType -- ^ Type of segment - , epFlags :: ElfSegmentFlag -- ^ Segment attributes - , epVirtAddr :: WordXX c -- ^ Virtual address in memory - , epPhysAddr :: WordXX c -- ^ Physical address - , epAddMemSize :: WordXX c -- ^ Add this amount of memory after the section when the section is loaded to memory by execution system. - -- Or, in other words this is how much `pMemSize` is bigger than `pFileSize` - , epAlign :: WordXX c -- ^ Alignment of segment - , epData :: [ElfXX c] -- ^ Content of the segment - } - | ElfRawData -- ^ Some ELF files (some executables) don't bother to define - -- sections for linking and have just raw data in segments. - { edData :: BSL.ByteString -- ^ Raw data in ELF file - } - | ElfRawAlign -- ^ Align the next data in the ELF file. - -- The offset of the next data in the ELF file - -- will be the minimal @x@ such that - -- @x mod eaAlign == eaOffset mod eaAlign @ - { eaOffset :: WordXX c -- ^ Align value - , eaAlign :: WordXX c -- ^ Align module - } - -foldMapElf :: Monoid m => (ElfXX a -> m) -> ElfXX a -> m -foldMapElf f e@ElfSegment{..} = f e <> foldMapElfList f epData -foldMapElf f e = f e - -foldMapElfList :: Monoid m => (ElfXX a -> m) -> [ElfXX a] -> m -foldMapElfList f = foldMap (foldMapElf f) - -- | Find section with a given number elfFindSection :: forall a m b . (SingI a, MonadThrow m, Integral b, Show b) - => [ElfXX a] -- ^ Structured ELF data - -> b -- ^ Number of the section - -> m (ElfXX a) -- ^ The section in question + => ElfListXX a -- ^ Structured ELF data + -> b -- ^ Number of the section + -> m (ElfXX 'Section a) -- ^ The section in question elfFindSection elfs n = if n == 0 then $chainedError "no section 0" else $maybeAddContext ("no section " ++ show n) maybeSection where maybeSection = getFirst $ foldMapElfList f elfs + f :: ElfXX t a -> First (ElfXX 'Section a) f s@ElfSection{..} | esN == fromIntegral n = First $ Just s f _ = First Nothing -- | Find section with a given name elfFindSectionByName :: forall a m . (SingI a, MonadThrow m) - => [ElfXX a] -- ^ Structured ELF data - -> String -- ^ Section name - -> m (ElfXX a) -- ^ The section in question + => ElfListXX a -- ^ Structured ELF data + -> String -- ^ Section name + -> m (ElfXX 'Section a) -- ^ The section in question elfFindSectionByName elfs n = $maybeAddContext ("no section \"" ++ show n ++ "\"") maybeSection where maybeSection = getFirst $ foldMapElfList f elfs + f :: ElfXX t a -> First (ElfXX 'Section a) f s@ElfSection{..} | esName == n = First $ Just s f _ = First Nothing -- | Find ELF header elfFindHeader :: forall a m . (SingI a, MonadThrow m) - => [ElfXX a] -- ^ Structured ELF data - -> m (ElfXX a) -- ^ ELF header + => ElfListXX a -- ^ Structured ELF data + -> m (ElfXX 'Header a) -- ^ ELF header elfFindHeader elfs = $maybeAddContext "no header" maybeHeader where maybeHeader = getFirst $ foldMapElfList f elfs + f :: ElfXX t a -> First (ElfXX 'Header a) f h@ElfHeader{} = First $ Just h f _ = First Nothing @@ -552,9 +592,9 @@ rbs <- parseRBuilder hdr ss ps bs let - rBuilderToElf :: RBuilder a -> m (ElfXX a) - rBuilderToElf RBuilderHeader{} = - return ElfHeader + rBuilderToElf :: RBuilder a -> ElfListXX a -> m (ElfListXX a) + rBuilderToElf RBuilderHeader{} l = + return $ ElfListCons ElfHeader { ehData = hData , ehOSABI = hOSABI , ehABIVersion = hABIVersion @@ -562,13 +602,13 @@ , ehMachine = hMachine , ehEntry = hEntry , ehFlags = hFlags - } - rBuilderToElf RBuilderSectionTable{} = - return ElfSectionTable - rBuilderToElf RBuilderSegmentTable{} = - return ElfSegmentTable - rBuilderToElf RBuilderSection{ rbsHeader = s@SectionXX{..}, ..} = - return ElfSection + } l + rBuilderToElf RBuilderSectionTable{} l = + return $ ElfListCons ElfSectionTable l + rBuilderToElf RBuilderSegmentTable{} l = + return $ ElfListCons ElfSegmentTable l + rBuilderToElf RBuilderSection{ rbsHeader = s@SectionXX{..}, ..} l = + return $ ElfListCons ElfSection { esName = rbsName , esType = sType , esFlags = fromIntegral sFlags @@ -584,13 +624,13 @@ else if sType == SHT_NOBITS then ElfSectionDataNoBits sSize else ElfSectionData $ getSectionData bs s - } - rBuilderToElf RBuilderSegment{ rbpHeader = SegmentXX{..}, ..} = do - d <- mapM rBuilderToElf rbpData + } l + rBuilderToElf RBuilderSegment{ rbpHeader = SegmentXX{..}, ..} l = do + d <- foldrM rBuilderToElf ElfListNull rbpData addMemSize <- if pMemSize /= 0 && pFileSize /= 0 && pMemSize < pFileSize then $chainedError "memSize < fileSize" else return (pMemSize - pFileSize) - return ElfSegment + return $ ElfListCons ElfSegment { epType = pType , epFlags = pFlags , epVirtAddr = pVirtAddr @@ -598,14 +638,14 @@ , epAddMemSize = addMemSize , epAlign = pAlign , epData = d - } - rBuilderToElf RBuilderRawData{ rbrdInterval = I o s } = - return $ ElfRawData $ cut bs (fromIntegral o) (fromIntegral s) - rBuilderToElf RBuilderRawAlign{..} = - return $ ElfRawAlign rbraOffset rbraAlign + } l + rBuilderToElf RBuilderRawData{ rbrdInterval = I o s } l = + return $ ElfListCons (ElfRawData $ cut bs (fromIntegral o) (fromIntegral s)) l + rBuilderToElf RBuilderRawAlign{..} l = + return $ ElfListCons (ElfRawAlign rbraOffset rbraAlign) l - el <- mapM rBuilderToElf rbs - return $ sing :&: ElfList el + el <- foldrM rBuilderToElf ElfListNull rbs -- mapM rBuilderToElf rbs + return $ sing :&: el -- | Parse ELF file parseElf :: MonadCatch m => BSL.ByteString -> m Elf @@ -617,34 +657,16 @@ -- ------------------------------------------------------------------------------- -data WBuilderData - = WBuilderDataHeader - | WBuilderDataByteStream { wbdData :: BSL.ByteString } - | WBuilderDataSectionTable - | WBuilderDataSegmentTable - -data WBuilderState a = - WBuilderState - { wbsSections :: [(ElfSectionIndex, SectionXX a)] - , wbsSegmentsReversed :: [SegmentXX a] - , wbsDataReversed :: [WBuilderData] - , wbsOffset :: WordXX a - , wbsPhOff :: WordXX a - , wbsShOff :: WordXX a - , wbsShStrNdx :: ElfSectionIndex - , wbsNameIndexes :: [Int64] - } - wbStateInit :: forall a . IsElfClass a => WBuilderState a wbStateInit = WBuilderState - { wbsSections = [] - , wbsSegmentsReversed = [] - , wbsDataReversed = [] - , wbsOffset = 0 - , wbsPhOff = 0 - , wbsShOff = 0 - , wbsShStrNdx = 0 - , wbsNameIndexes = [] + { _wbsSections = [] + , _wbsSegmentsReversed = [] + , _wbsDataReversed = [] + , _wbsOffset = 0 + , _wbsPhOff = 0 + , _wbsShOff = 0 + , _wbsShStrNdx = 0 + , _wbsNameIndexes = [] } zeroSection :: forall a . IsElfClass a => SectionXX a @@ -701,15 +723,16 @@ ((i', o') : iosff, insff) else (iosff, (i', n') : insff) --- FIXME: rewrite serializeElf using lenses (???) -serializeElf' :: forall a m . (IsElfClass a, MonadThrow m) => [ElfXX a] -> m BSL.ByteString +serializeElf' :: forall a m . (IsElfClass a, MonadCatch m) => ElfListXX a -> m BSL.ByteString serializeElf' elfs = do - (header', hData') <- do - header <- elfFindHeader elfs - case header of - ElfHeader{..} -> return (header, ehData) - _ -> $chainedError "not a header" -- FIXME + -- FIXME: it's better to match constructor here, but there is a bug that prevents to conclude that + -- the match is irrefutable: + -- https://stackoverflow.com/questions/72803815/phantom-type-makes-pattern-matching-irrefutable-but-that-seemingly-does-not-wor + -- https://gitlab.haskell.org/ghc/ghc/-/issues/15681#note_165436 + -- But if I use lazy pattern match, then some other bug comes up that prevents type inference + -- on GHC 9.0.2 + header' <- $addContext' $ elfFindHeader elfs let @@ -724,6 +747,7 @@ sectionNames :: [String] sectionNames = foldMapElfList f elfs where + f :: ElfXX t a -> [String] f ElfSection{..} = [ esName ] f _ = [] @@ -741,22 +765,17 @@ f ElfSectionTable = Any True f _ = Any False - align :: MonadThrow n => WordXX a -> WordXX a -> WBuilderState a -> n (WBuilderState a) - align _ 0 x = return x - align _ 1 x = return x - align t m WBuilderState{..} | m .&. (m - 1) /= 0 = $chainedError $ "align module is not power of two " ++ show m - | otherwise = - let - wbsOffset' = nextOffset t m wbsOffset - d = WBuilderDataByteStream $ BSL.replicate (fromIntegral $ wbsOffset' - wbsOffset) 0 - in - return WBuilderState - { wbsDataReversed = d : wbsDataReversed - , wbsOffset = wbsOffset' - , .. - } + align :: (MonadThrow n, MonadState (WBuilderState a) n) => WordXX a -> WordXX a -> n () + align _ 0 = return () + align _ 1 = return () + align t m | m .&. (m - 1) /= 0 = $chainedError $ "align module is not power of two " ++ show m + | otherwise = do + offset <- use wbsOffset + wbsOffset .= nextOffset t m offset + offset' <- use wbsOffset + wbsDataReversed %= (WBuilderDataByteStream (BSL.replicate (fromIntegral $ offset' - offset) 0) :) - alignWord :: MonadThrow n => WBuilderState a -> n (WBuilderState a) + alignWord :: (MonadThrow n, MonadState (WBuilderState a) n) => n () alignWord = align 0 $ wordSize $ fromSing $ sing @a dataIsEmpty :: ElfSectionData c -> Bool @@ -764,106 +783,88 @@ dataIsEmpty ElfSectionDataStringTable = BSL.null stringTable dataIsEmpty (ElfSectionDataNoBits _) = True - lastSectionIsEmpty :: [ElfXX a] -> Bool - lastSectionIsEmpty [] = False - lastSectionIsEmpty l = case L.last l of - ElfSection{..} -> dataIsEmpty esData - _ -> False + lastSection :: ElfListXX a -> (forall t' . (ElfXX t' a -> b)) -> b -> b + lastSection ElfListNull _ b = b + lastSection (ElfListCons v ElfListNull) f _ = f v + lastSection (ElfListCons _ l) f b = lastSection l f b - elf2WBuilder' :: MonadThrow n => ElfXX a -> WBuilderState a -> n (WBuilderState a) - elf2WBuilder' ElfHeader{} WBuilderState{..} = - return WBuilderState - { wbsDataReversed = WBuilderDataHeader : wbsDataReversed - , wbsOffset = wbsOffset + headerSize elfClass - , .. - } - elf2WBuilder' ElfSectionTable s = do - WBuilderState{..} <- alignWord s - return WBuilderState - { wbsDataReversed = WBuilderDataSectionTable : wbsDataReversed - , wbsOffset = wbsOffset + (sectionN + 1) * sectionTableEntrySize elfClass - , wbsShOff = wbsOffset - , .. - } - elf2WBuilder' ElfSegmentTable s = do - WBuilderState{..} <- alignWord s - return WBuilderState - { wbsDataReversed = WBuilderDataSegmentTable : wbsDataReversed - , wbsOffset = wbsOffset + segmentN * segmentTableEntrySize elfClass - , wbsPhOff = wbsOffset - , .. - } - elf2WBuilder' ElfSection{esFlags = ElfSectionFlag f, ..} s = do - when (f .&. fromIntegral (complement (maxBound @(WordXX a))) /= 0) - ($chainedError $ "section flags at section " ++ show esN ++ "don't fit") - -- I don't see any sense in aligning NOBITS sections + lastSectionIsEmpty :: ElfListXX a -> Bool + lastSectionIsEmpty l = lastSection l f False + where + f ElfSection { .. } = dataIsEmpty esData + f _ = False + + elf2WBuilder :: (MonadThrow n, MonadState (WBuilderState a) n) => ElfXX t a -> n () + elf2WBuilder ElfHeader{} = do + -- FIXME: add push monad + wbsDataReversed %= (WBuilderDataHeader :) + wbsOffset += headerSize elfClass + elf2WBuilder ElfSectionTable = do + alignWord + use wbsOffset >>= assign wbsShOff + wbsDataReversed %= (WBuilderDataSectionTable :) + wbsOffset += (sectionN + 1) * sectionTableEntrySize elfClass + elf2WBuilder ElfSegmentTable = do + alignWord + use wbsOffset >>= assign wbsPhOff + wbsDataReversed %= (WBuilderDataSegmentTable :) + wbsOffset += segmentN * segmentTableEntrySize elfClass + elf2WBuilder ElfSection{esFlags = ElfSectionFlag f, ..} = do + when (f .&. fromIntegral (complement (maxBound @(WordXX a))) /= 0) do + $chainedError $ "section flags at section " ++ show esN ++ "don't fit" + -- I don't see any sense in aligning NOBITS section data -- still gcc does it for .o files - WBuilderState{..} <- if esType == SHT_NOBITS && (ehType header') /= ET_REL - then return s - else align 0 esAddrAlign s + when (esType /= SHT_NOBITS || (ehType header') == ET_REL) do + align 0 esAddrAlign + (n, ns) <- uses wbsNameIndexes \case + n' : ns' -> (n', ns') + _ -> error "internal error: different number of sections in two iterations" + shStrNdx' <- use wbsShStrNdx let (d, shStrNdx, sz) = case esData of - ElfSectionData { .. } -> (esdData, wbsShStrNdx, fromIntegral $ BSL.length esdData) + ElfSectionData { .. } -> (esdData, shStrNdx', fromIntegral $ BSL.length esdData) ElfSectionDataStringTable -> (stringTable, esN, fromIntegral $ BSL.length stringTable) - ElfSectionDataNoBits { .. } -> (BSL.empty, wbsShStrNdx, esdSize) - (n, ns) = case wbsNameIndexes of - n' : ns' -> (n', ns') - _ -> error "internal error: different number of sections in two iterations" + ElfSectionDataNoBits { .. } -> (BSL.empty, shStrNdx', esdSize) sName = fromIntegral n -- Word32 sType = esType -- ElfSectionType sFlags = fromIntegral f sAddr = esAddr -- WXX c - sOffset = wbsOffset -- WXX c sSize = sz -- WXX c sLink = esLink -- Word32 sInfo = esInfo -- Word32 sAddrAlign = esAddrAlign -- WXX c sEntSize = esEntSize -- WXX c - return WBuilderState - { wbsSections = (esN, SectionXX{..}) : wbsSections - , wbsDataReversed = WBuilderDataByteStream d : wbsDataReversed - , wbsOffset = wbsOffset + fromIntegral (BSL.length d) - , wbsShStrNdx = shStrNdx - , wbsNameIndexes = ns - , .. - } - elf2WBuilder' ElfSegment{..} s = do - s' <- align epVirtAddr epAlign s - let - offset = wbsOffset s' - WBuilderState{..} <- execStateT (mapM elf2WBuilder epData) s' + sOffset <- use wbsOffset -- WXX c + wbsSections %= ((esN, SectionXX { .. }) :) + wbsDataReversed %= (WBuilderDataByteStream d :) + wbsOffset += fromIntegral (BSL.length d) + wbsShStrNdx .= shStrNdx + wbsNameIndexes .= ns + elf2WBuilder ElfSegment { .. } = do + align epVirtAddr epAlign + offset <- use wbsOffset + void $ mapMElfList elf2WBuilder epData + offset' <- use wbsOffset let -- allocate one more byte in the end of segment if there exists an empty section -- at the end so that that empty section will go to the current segment - add1 = lastSectionIsEmpty epData && offset /= wbsOffset + add1 = lastSectionIsEmpty epData && offset /= offset' pType = epType pFlags = epFlags pOffset = offset pVirtAddr = epVirtAddr pPhysAddr = epPhysAddr - pFileSize = wbsOffset - offset + if add1 then 1 else 0 + pFileSize = offset' - offset + if add1 then 1 else 0 pMemSize = pFileSize + epAddMemSize pAlign = epAlign - return WBuilderState - { wbsSegmentsReversed = SegmentXX{..} : wbsSegmentsReversed - , wbsDataReversed = if add1 - then WBuilderDataByteStream (BSL.singleton 0) : wbsDataReversed - else wbsDataReversed - , wbsOffset = if add1 - then wbsOffset + 1 - else wbsOffset - , .. - } - elf2WBuilder' ElfRawData{..} WBuilderState{..} = - return WBuilderState - { wbsDataReversed = WBuilderDataByteStream edData : wbsDataReversed - , wbsOffset = wbsOffset + fromIntegral (BSL.length edData) - , .. - } - elf2WBuilder' ElfRawAlign{..} s = align eaOffset eaAlign s - - elf2WBuilder :: (MonadThrow n, MonadState (WBuilderState a) n) => ElfXX a -> n () - elf2WBuilder elf = MS.get >>= elf2WBuilder' elf >>= MS.put + wbsSegmentsReversed %= (SegmentXX { .. } :) + when add1 do + wbsDataReversed %= (WBuilderDataByteStream (BSL.singleton 0) :) + wbsOffset += 1 + elf2WBuilder ElfRawData { .. } = do + wbsDataReversed %= (WBuilderDataByteStream edData :) + wbsOffset += fromIntegral (BSL.length edData) + elf2WBuilder ElfRawAlign { .. } = align eaOffset eaAlign fixSections :: [(ElfSectionIndex, SectionXX a)] -> m [SectionXX a] fixSections ss = do @@ -880,7 +881,7 @@ wbState2ByteString :: WBuilderState a -> m BSL.ByteString wbState2ByteString WBuilderState{..} = do - sections <- fixSections wbsSections + sections <- fixSections _wbsSections let f WBuilderDataHeader = @@ -893,33 +894,32 @@ hType = ehType hMachine = ehMachine hEntry = ehEntry - hPhOff = wbsPhOff - hShOff = wbsShOff + hPhOff = _wbsPhOff + hShOff = _wbsShOff hFlags = ehFlags hPhEntSize = segmentTableEntrySize elfClass - hPhNum = segmentN + hPhNum = segmentN :: Word16 hShEntSize = sectionTableEntrySize elfClass - hShNum = if sectionTable then sectionN + 1 else 0 - hShStrNdx = wbsShStrNdx + hShNum = (if sectionTable then sectionN + 1 else 0) :: Word16 + hShStrNdx = _wbsShStrNdx h :: Header h = sing @a :&: HeaderXX{..} in encode h - _ -> error "this should be ElfHeader" -- FIXME f WBuilderDataByteStream {..} = wbdData f WBuilderDataSectionTable = - serializeBList hData' $ zeroSection : sections + serializeBList (ehData header') $ zeroSection : sections f WBuilderDataSegmentTable = - serializeBList hData' $ L.reverse wbsSegmentsReversed + serializeBList (ehData header') $ L.reverse _wbsSegmentsReversed - return $ foldMap f $ L.reverse wbsDataReversed + return $ foldMap f $ L.reverse _wbsDataReversed - execStateT (mapM elf2WBuilder elfs) wbStateInit{ wbsNameIndexes = nameIndexes } >>= wbState2ByteString + execStateT (mapMElfList elf2WBuilder elfs) wbStateInit{ _wbsNameIndexes = nameIndexes } >>= wbState2ByteString -- | Serialze ELF file -serializeElf :: MonadThrow m => Elf -> m BSL.ByteString -serializeElf (classS :&: ElfList ls) = withElfClass classS serializeElf' ls +serializeElf :: MonadCatch m => Elf -> m BSL.ByteString +serializeElf (classS :&: ls) = withElfClass classS serializeElf' ls ------------------------------------------------------------------------------- -- @@ -956,19 +956,24 @@ -- | Parse symbol table parseSymbolTable :: (MonadThrow m, SingI a) => ElfData -- ^ Endianness of the ELF file - -> ElfXX a -- ^ Parsed section such that @`sectionIsSymbolTable` . `sType`@ is true. - -> [ElfXX a] -- ^ Structured ELF data + -> ElfXX 'Section a -- ^ Parsed section such that @`sectionIsSymbolTable` . `sType`@ is true. + -> ElfListXX a -- ^ Structured ELF data -> m [ElfSymbolXX a] -- ^ Symbol table -parseSymbolTable d ElfSection{ esData = ElfSectionData symbolTable, ..} elfs = do +parseSymbolTable d symbolTableSection@(ElfSection { .. }) elfs = do + + symbolTable <- case symbolTableSection of + ElfSection{ esData = ElfSectionData st } -> return st + _ -> $chainedError "wrong symbol table section data" + section <- elfFindSection elfs esLink - case section of - ElfSection{ esData = ElfSectionData stringTable } -> do - st <- parseBList d symbolTable - return (mkElfSymbolTableEntry stringTable <$> st) - _ -> $chainedError "not a section" -- FIXME -parseSymbolTable _ _ _ = $chainedError "incorrect args to parseSymbolTable" -- FIXME + stringTable <- case section of + ElfSection{ esData = ElfSectionData st } -> return st + _ -> $chainedError "wrong string table section data" -mkSymbolTableEntry :: SingI a => Word32 -> ElfSymbolXX a -> SymbolXX a + st <- parseBList d symbolTable + return (mkElfSymbolTableEntry stringTable <$> st) + +mkSymbolTableEntry :: Word32 -> ElfSymbolXX a -> SymbolXX a mkSymbolTableEntry nameIndex ElfSymbolXX{..} = let ElfSymbolBinding b = steBind @@ -976,7 +981,7 @@ stName = nameIndex stInfo = b `shift` 4 .|. t - stOther = 0 + stOther = 0 :: Word8 stShNdx = steShNdx stValue = steValue stSize = steSize @@ -994,7 +999,7 @@ (stringTable, stringIndexes) = mkStringTable $ fmap steName ss ssWithNameIndexes = L.zip ss stringIndexes - f :: SingI a => (ElfSymbolXX a, Int64) -> SymbolXX a + f :: (ElfSymbolXX a, Int64) -> SymbolXX a f (s, n) = mkSymbolTableEntry (fromIntegral n) s symbolTable = serializeBList d $ fmap f ssWithNameIndexes diff --git a/src/Data/Interval.hs b/src/Data/Interval.hs --- a/src/Data/Interval.hs +++ b/src/Data/Interval.hs @@ -9,7 +9,7 @@ data Interval a = I { offset :: !a, size :: !a } -instance (Ord a, Eq a, Num a) => Eq (Interval a) where +instance (Ord a, Num a) => Eq (Interval a) where (==) (I o1 s1) (I o2 s2) | s1 > 0 && s2 > 0 = o1 == o2 && s1 == s2 | s1 <= 0 && s2 <= 0 = o1 == o2 | otherwise = False